;;;
;;; gauche/time.scm - time the procedure
;;;
    Copyright ( c ) 2000 - 2022       <  >
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    " AS IS " AND ANY EXPRESS OR IMPLIED WARRANTIES , INCLUDING , BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    SPECIAL , EXEMPLARY , OR CONSEQUENTIAL DAMAGES ( INCLUDING , BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
    LIABILITY , WHETHER IN CONTRACT , STRICT LIABILITY , OR TORT ( INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(define-module gauche.time
  (use gauche.record)
  (use util.match)
  (export time time-this time-these report-time-results time-these/report
          <time-result> make-time-result time-result+ time-result-
          time-result-real time-result-user time-result-sys
          <time-counter> <real-time-counter> <user-time-counter>
          <system-time-counter> <process-time-counter>
          time-counter-start! time-counter-stop! time-counter-reset!
          time-counter-value with-time-counter
          time-counter-get-current-time time-counter-get-delta)
  )
(select-module gauche.time)

  Time , a simple measurement ------------------------------

;; TODO: Drop these once we support sane formatting of flonums in format.
(define (format-flonum val mincol digs)
  (if (finite? val)
    (let* ([scale (expt 10 digs)]
           [n (round->exact (* val scale))])
      (format "~vd.~v,'0d" mincol (div n scale) digs (mod n scale)))
    (format "~a" val)))

(define (format-delta-time delta) (format-flonum delta 3 3))

;; common stuff for 'time' macro and benchmarking
(define-syntax %with-times
  (syntax-rules ()
    [(_ expr exprs do-result)
     (begin
       (gc)
       (let*-values ([(stimes) (sys-times)]
                     [(sreal-sec sreal-msec) (sys-gettimeofday)]
                     [r (begin expr . exprs)]
                     [(etimes) (sys-times)]
                     [(ereal-sec ereal-msec) (sys-gettimeofday)])
         (let ([real (- (+ ereal-sec (/. ereal-msec 1000000))
                        (+ sreal-sec (/. sreal-msec 1000000)))]
               [user (/. (- (list-ref etimes 0) (list-ref stimes 0))
                         (list-ref stimes 4))]
               [sys  (/. (- (list-ref etimes 1) (list-ref stimes 1))
                         (list-ref stimes 4))])
           (do-result r real user sys))))]))

(define-syntax time
  (syntax-rules ()
    [(_ expr . exprs)
     (%with-times expr exprs
                  (^(r real user sys)
                    (format (current-error-port)
                            ";~,,,,75:s\n; real ~a\n; user ~a\n; sys  ~a\n"
                            '(time expr . exprs)
                            (format-delta-time real)
                            (format-delta-time user)
                            (format-delta-time sys))
                    (apply values r)))]
    [(_)
     (syntax-error "usage: (time expr expr2 ...); or you meant sys-time?")]))

;; Benchmarking ---------------------------------------

(define-record-type <time-result> make-time-result time-result?
  (count time-result-count)
  (real  time-result-real)
  (user  time-result-user)
  (sys   time-result-sys))

(define-method write-object ((obj <time-result>) port)
  (format port "#<time-result ~a times/~a real/~a user/~a sys>"
          (~ obj'count)
          (format-delta-time (~ obj'real))
          (format-delta-time (~ obj'user))
          (format-delta-time (~ obj'sys))))

(define (%time-result-op op t1 t2 with-count)
  (make-time-result (if with-count
                      (op (time-result-count t1) (time-result-count t2))
                      (time-result-count t1))
                    (op (time-result-real t1) (time-result-real t2))
                    (op (time-result-user t1) (time-result-user t2))
                    (op (time-result-sys  t1) (time-result-sys  t2))))

(define (time-result+ t1 t2 :key (with-count #f))
  (%time-result-op + t1 t2 with-count))

(define (time-result- t1 t2 :key (with-count #f))
  (%time-result-op - t1 t2 with-count))

(define (metric? sym)
  (case sym
    [(cpu user sys real) sym]
    [else
     (error "Metric must be one of cpu, user, sys, or real, but got:" sym)]))

(define (metric-time metric result)
  (ecase metric
    [(cpu)  (+ (time-result-user result) (time-result-sys result))]
    [(user) (time-result-user result)]
    [(sys)  (time-result-sys result)]
    [(real) (time-result-real result)]))

  one sample .
;; config := <integer>     ; number of repetition
;;        |  (<metric> <real>)  ; at least <real> seconds in <metric> time
(define (time-this config thunk)
  (define (with-times count thunk)
    (%with-times (thunk) ()
                 (^(_ real user sys) (make-time-result count real user sys))))
  (define (run count)
    (let* ([body (with-times count (^() (dotimes [n count] (thunk))))]
           [skin (with-times count (^() (dotimes [n count] #f)))])
      (time-result- body skin)))

  Determine the unit repetition count which takes at least 0.3 cpu secs .
  (define (estimate rep metric)
    (let* ([result (run rep)]
           [t      (metric-time metric result)])
      (cond [(< t 0.01) (estimate (* rep 50) metric)]
            [(< t 0.05) (estimate (* rep 10) metric)]
            [else (ceiling->exact (* (/. rep t) 0.3))])))

  (match config
    [(? integer?) (run config)]
    [((and metric? metric) (? real? secs))
     (when (< secs 1.0)
       (error "Benchmark duration (cpu time) should be greater than 1.0 for \
               reliable measurement.  We got:" config))
     (let1 unit (estimate 1 metric)
       (let loop ([cumu 0] [r #f])
         (if (>= cumu secs)
           r
           (let1 r1 (run unit)
             (loop (+ cumu (metric-time metric r1))
                   (if r
                     (time-result+ r r1 :with-count #t)
                     r1))))))]))

;; multiple samples.
;; samples : ((key . thunk) ...)
;; returns : (config (key . result) ...)
(define (time-these config samples)
  (cons config
        (map (^s (cons (car s) (time-this config (cdr s)))) samples)))

(define (time-these/report config samples :key (metric #f))
  (report-time-results (time-these config samples) metric))

;; Show the result of time-these nicely.
(define (report-time-results result :optional (%metric #f))
  ;; check valid format of the alist part
  (define (valid-alist? alist)
    (and (every pair? alist) (every (.$ time-result? cdr) alist)))

  ;; decompose RESULT argument
  ;;  (<config> (<name> . <time-result>) ...)
  (define-values [metric config result-alist]
    (match result
      [((? integer? config) . (? valid-alist? alist))
       (values (or %metric 'cpu) config alist)]
      [((and ((? metric? m) (? real?)) config) . (? valid-alist? alist))
       (values m config alist)]
      [_ (error "the argument doesn't seem like a time-these result:" result)]))

  ;; returns list of formatted strings and maximum width
  (define (fmt+w formatter vals)
    (let1 fs (map formatter vals)
      (values fs (apply max (map string-length fs)))))
  (define (ff val dig) (format-flonum val 0 dig))
  (define (realtime result) (~ result'real))
  (define (usertime result) (~ result'user))
  (define (systime result)  (~ result'sys))
  (define (cputime result)  (+ (usertime result) (systime result)))
  (define (rate result) (/. (~ result'count) (metric-time metric result)))
  ;; compare rates.  x, y :: <time-result>
  (define (ratio x y) (ff (/ (rate x) (rate y)) 3))

  ;; main body
  ;; header
  (format #t "Benchmark: ran ~a, each for ~a.\n"
          (string-join (map (.$ x->string car) result-alist) ", ")
          (match config
            [(_ secs) (format "at least ~a ~a seconds" secs metric)]
            [count    (format "~a times" count)]))
  ;; individual results
  (let*-values
      ([(ts) (map cdr result-alist)] ;<time-result>s
       [(ks kw) (fmt+w (.$ x->string car) result-alist)] ;name
       [(rs rw) (fmt+w (^t (ff (realtime t) 3)) ts)]  ;real time
       [(ps pw) (fmt+w (^t (ff (cputime  t)  3)) ts)] ;cpu time
       [(us uw) (fmt+w (^t (ff (usertime t) 3)) ts)]  ;user time
sys time
       [(cs cw) (fmt+w (^t (ff (rate t) 2)) ts)]      ;count/s
       )
    (for-each
     (^(k r p u s c n)
       (format #t
               "  ~v@a: ~v@a real, ~v@a cpu (~v@a user + ~v@a sys)@~v@a/s n=~a\n"
               kw k rw r pw p uw u sw s cw c n))
     ks rs ps us ss cs (map (cut ref <> 'count) ts))
    ;; matrix
    (let1 mat (map (^y (map (^x (if (eq? x y) "--" (ratio y x))) ts)) ts)
      (receive (Cs Cw) (fmt+w (^t (if (finite? (rate t))
                                    ($ x->string $ x->integer $ rate t)
                                    ($ x->string $ rate t)))
                              ts)
        (let1 Cw (max (+ Cw 2) 4)   ; minimum width for "Rate"
          (format #t "\n  ~v@a ~v@a" kw "" Cw "Rate")
          (let1 col-widths (map (pa$ apply max)
                                (map (pa$ map string-length)
                                     (map cons ks (apply map list mat))))
            (for-each (^(key col-width) (format #t " ~v@a" col-width key))
                      ks col-widths)
            (for-each (^(key row C)
                        (format #t "\n  ~v@a ~v@a/s" kw key (- Cw 2) C)
                        (for-each (^(col col-width)
                                    (format #t " ~v@a" col-width col))
                                  row col-widths))
                      ks mat Cs))))))
    (newline))

;; Timers ---------------------------------------------

(define-class <time-counter> ()
accured time , in seconds
   (start   :init-value #f)   ;start time.  format depends on the subclass.
   (nesting :init-value 0))   ;nesting level.
  )

(define-method initialize ((self <time-counter>) initargs)
  (next-method)
  (when (eq? (class-of self) <time-counter>)
    (error "you can't instantiate <time-counter> class directly; use either <real-time-counter>, <user-time-counter> or <process-time-counter>"))
  )

(define-method time-counter-start! ((self <time-counter>))
  (let1 nesting (slot-ref self 'nesting)
    (when (zero? nesting)
      (slot-set! self 'start (time-counter-get-current-time self)))
    (slot-set! self 'nesting (+ nesting 1))))


(define-method time-counter-stop! ((self <time-counter>))
  (let1 nesting (slot-ref self 'nesting)
    (cond
     [(= nesting 1)
      (inc! (slot-ref self 'value) (time-counter-get-delta self))
      (set! (slot-ref self 'nesting) 0)]
     [(> nesting 1)
      (set! (slot-ref self 'nesting) (- nesting 1))]
     [else
      ;; sprious stop.  make sure the state is sane
      (set! (slot-ref self 'nesting) 0)])))

(define-method time-counter-get-delta ((self <time-counter>))
  ;; This default method assumes time-counter-get-current-time returns
  ;; a real number of seconds.  A subclass that uses different representation
  ;; should override this method as well.
  (let1 end (time-counter-get-current-time self)
    (- end (slot-ref self 'start))))

(define-method time-counter-value ((self <time-counter>))
  (slot-ref self 'value))

(define-method time-counter-reset! ((self <time-counter>))
  (slot-set! self 'value 0)
  (slot-set! self 'nesting 0))

(define-method write-object ((self <time-counter>) port)
  (format port "#<~a ~a>"
          (class-name (class-of self))
          (format-delta-time (slot-ref self 'value))))

(define-syntax with-time-counter
  (syntax-rules ()
    [(_ counter . exprs)
     (let1 c counter
       (dynamic-wind
           (lambda () (time-counter-start! c))
           (lambda () . exprs)
           (lambda () (time-counter-stop! c))))]))

;; 'real' time counter
(define-class <real-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <real-time-counter>))
  (receive r (sys-gettimeofday) r))

(define-method time-counter-get-delta ((self <real-time-counter>))
  (receive (sec usec) (sys-gettimeofday)
    (+ (- sec (car (slot-ref self 'start)))
       (/. (- usec (cadr (slot-ref self 'start)))
           1000000))))

;; 'user' time counter
(define-class <user-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <user-time-counter>))
  (let1 times (sys-times)
    (/. (list-ref times 0) (list-ref times 4))))

;; 'system' time counter
(define-class <system-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <system-time-counter>))
  (let1 times (sys-times)
    (/. (list-ref times 1) (list-ref times 4))))

;; 'process' time counter - 'user' + 'sys'
(define-class <process-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <process-time-counter>))
  (let1 times (sys-times)
    (/. (+ (list-ref times 0) (list-ref times 1))
        (list-ref times 4))))


 gauche/time.scm - time the procedure


   Redistribution and use in source and binary forms, with or without
   modification, are permitted provided that the following conditions
   are met:

   1. Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

   2. Redistributions in binary form must reproduce the above copyright
      notice, this list of conditions and the following disclaimer in the
      documentation and/or other materials provided with the distribution.

   3. Neither the name of the authors nor the names of its contributors
      may be used to endorse or promote products derived from this
      software without specific prior written permission.

   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 TODO: Drop these once we support sane formatting of flonums in format.
 common stuff for 'time' macro and benchmarking
 Benchmarking ---------------------------------------
 config := <integer>     ; number of repetition
        |  (<metric> <real>)  ; at least <real> seconds in <metric> time
 multiple samples.
 samples : ((key . thunk) ...)
 returns : (config (key . result) ...)
 Show the result of time-these nicely.
 check valid format of the alist part
 decompose RESULT argument
  (<config> (<name> . <time-result>) ...)
 returns list of formatted strings and maximum width
 compare rates.  x, y :: <time-result>
 main body
 header
 individual results
<time-result>s
name
real time
cpu time
user time
count/s
 matrix
 minimum width for "Rate"
 Timers ---------------------------------------------
start time.  format depends on the subclass.
nesting level.
 sprious stop.  make sure the state is sane
 This default method assumes time-counter-get-current-time returns
 a real number of seconds.  A subclass that uses different representation
 should override this method as well.
 'real' time counter
 'user' time counter
 'system' time counter
 'process' time counter - 'user' + 'sys'
    Copyright ( c ) 2000 - 2022       <  >
    " AS IS " AND ANY EXPRESS OR IMPLIED WARRANTIES , INCLUDING , BUT NOT
    SPECIAL , EXEMPLARY , OR CONSEQUENTIAL DAMAGES ( INCLUDING , BUT NOT LIMITED
    LIABILITY , WHETHER IN CONTRACT , STRICT LIABILITY , OR TORT ( INCLUDING

(define-module gauche.time
  (use gauche.record)
  (use util.match)
  (export time time-this time-these report-time-results time-these/report
          <time-result> make-time-result time-result+ time-result-
          time-result-real time-result-user time-result-sys
          <time-counter> <real-time-counter> <user-time-counter>
          <system-time-counter> <process-time-counter>
          time-counter-start! time-counter-stop! time-counter-reset!
          time-counter-value with-time-counter
          time-counter-get-current-time time-counter-get-delta)
  )
(select-module gauche.time)

  Time , a simple measurement ------------------------------

(define (format-flonum val mincol digs)
  (if (finite? val)
    (let* ([scale (expt 10 digs)]
           [n (round->exact (* val scale))])
      (format "~vd.~v,'0d" mincol (div n scale) digs (mod n scale)))
    (format "~a" val)))

(define (format-delta-time delta) (format-flonum delta 3 3))

(define-syntax %with-times
  (syntax-rules ()
    [(_ expr exprs do-result)
     (begin
       (gc)
       (let*-values ([(stimes) (sys-times)]
                     [(sreal-sec sreal-msec) (sys-gettimeofday)]
                     [r (begin expr . exprs)]
                     [(etimes) (sys-times)]
                     [(ereal-sec ereal-msec) (sys-gettimeofday)])
         (let ([real (- (+ ereal-sec (/. ereal-msec 1000000))
                        (+ sreal-sec (/. sreal-msec 1000000)))]
               [user (/. (- (list-ref etimes 0) (list-ref stimes 0))
                         (list-ref stimes 4))]
               [sys  (/. (- (list-ref etimes 1) (list-ref stimes 1))
                         (list-ref stimes 4))])
           (do-result r real user sys))))]))

(define-syntax time
  (syntax-rules ()
    [(_ expr . exprs)
     (%with-times expr exprs
                  (^(r real user sys)
                    (format (current-error-port)
                            ";~,,,,75:s\n; real ~a\n; user ~a\n; sys  ~a\n"
                            '(time expr . exprs)
                            (format-delta-time real)
                            (format-delta-time user)
                            (format-delta-time sys))
                    (apply values r)))]
    [(_)
     (syntax-error "usage: (time expr expr2 ...); or you meant sys-time?")]))


(define-record-type <time-result> make-time-result time-result?
  (count time-result-count)
  (real  time-result-real)
  (user  time-result-user)
  (sys   time-result-sys))

(define-method write-object ((obj <time-result>) port)
  (format port "#<time-result ~a times/~a real/~a user/~a sys>"
          (~ obj'count)
          (format-delta-time (~ obj'real))
          (format-delta-time (~ obj'user))
          (format-delta-time (~ obj'sys))))

(define (%time-result-op op t1 t2 with-count)
  (make-time-result (if with-count
                      (op (time-result-count t1) (time-result-count t2))
                      (time-result-count t1))
                    (op (time-result-real t1) (time-result-real t2))
                    (op (time-result-user t1) (time-result-user t2))
                    (op (time-result-sys  t1) (time-result-sys  t2))))

(define (time-result+ t1 t2 :key (with-count #f))
  (%time-result-op + t1 t2 with-count))

(define (time-result- t1 t2 :key (with-count #f))
  (%time-result-op - t1 t2 with-count))

(define (metric? sym)
  (case sym
    [(cpu user sys real) sym]
    [else
     (error "Metric must be one of cpu, user, sys, or real, but got:" sym)]))

(define (metric-time metric result)
  (ecase metric
    [(cpu)  (+ (time-result-user result) (time-result-sys result))]
    [(user) (time-result-user result)]
    [(sys)  (time-result-sys result)]
    [(real) (time-result-real result)]))

  one sample .
(define (time-this config thunk)
  (define (with-times count thunk)
    (%with-times (thunk) ()
                 (^(_ real user sys) (make-time-result count real user sys))))
  (define (run count)
    (let* ([body (with-times count (^() (dotimes [n count] (thunk))))]
           [skin (with-times count (^() (dotimes [n count] #f)))])
      (time-result- body skin)))

  Determine the unit repetition count which takes at least 0.3 cpu secs .
  (define (estimate rep metric)
    (let* ([result (run rep)]
           [t      (metric-time metric result)])
      (cond [(< t 0.01) (estimate (* rep 50) metric)]
            [(< t 0.05) (estimate (* rep 10) metric)]
            [else (ceiling->exact (* (/. rep t) 0.3))])))

  (match config
    [(? integer?) (run config)]
    [((and metric? metric) (? real? secs))
     (when (< secs 1.0)
       (error "Benchmark duration (cpu time) should be greater than 1.0 for \
               reliable measurement.  We got:" config))
     (let1 unit (estimate 1 metric)
       (let loop ([cumu 0] [r #f])
         (if (>= cumu secs)
           r
           (let1 r1 (run unit)
             (loop (+ cumu (metric-time metric r1))
                   (if r
                     (time-result+ r r1 :with-count #t)
                     r1))))))]))

(define (time-these config samples)
  (cons config
        (map (^s (cons (car s) (time-this config (cdr s)))) samples)))

(define (time-these/report config samples :key (metric #f))
  (report-time-results (time-these config samples) metric))

(define (report-time-results result :optional (%metric #f))
  (define (valid-alist? alist)
    (and (every pair? alist) (every (.$ time-result? cdr) alist)))

  (define-values [metric config result-alist]
    (match result
      [((? integer? config) . (? valid-alist? alist))
       (values (or %metric 'cpu) config alist)]
      [((and ((? metric? m) (? real?)) config) . (? valid-alist? alist))
       (values m config alist)]
      [_ (error "the argument doesn't seem like a time-these result:" result)]))

  (define (fmt+w formatter vals)
    (let1 fs (map formatter vals)
      (values fs (apply max (map string-length fs)))))
  (define (ff val dig) (format-flonum val 0 dig))
  (define (realtime result) (~ result'real))
  (define (usertime result) (~ result'user))
  (define (systime result)  (~ result'sys))
  (define (cputime result)  (+ (usertime result) (systime result)))
  (define (rate result) (/. (~ result'count) (metric-time metric result)))
  (define (ratio x y) (ff (/ (rate x) (rate y)) 3))

  (format #t "Benchmark: ran ~a, each for ~a.\n"
          (string-join (map (.$ x->string car) result-alist) ", ")
          (match config
            [(_ secs) (format "at least ~a ~a seconds" secs metric)]
            [count    (format "~a times" count)]))
  (let*-values
sys time
       )
    (for-each
     (^(k r p u s c n)
       (format #t
               "  ~v@a: ~v@a real, ~v@a cpu (~v@a user + ~v@a sys)@~v@a/s n=~a\n"
               kw k rw r pw p uw u sw s cw c n))
     ks rs ps us ss cs (map (cut ref <> 'count) ts))
    (let1 mat (map (^y (map (^x (if (eq? x y) "--" (ratio y x))) ts)) ts)
      (receive (Cs Cw) (fmt+w (^t (if (finite? (rate t))
                                    ($ x->string $ x->integer $ rate t)
                                    ($ x->string $ rate t)))
                              ts)
          (format #t "\n  ~v@a ~v@a" kw "" Cw "Rate")
          (let1 col-widths (map (pa$ apply max)
                                (map (pa$ map string-length)
                                     (map cons ks (apply map list mat))))
            (for-each (^(key col-width) (format #t " ~v@a" col-width key))
                      ks col-widths)
            (for-each (^(key row C)
                        (format #t "\n  ~v@a ~v@a/s" kw key (- Cw 2) C)
                        (for-each (^(col col-width)
                                    (format #t " ~v@a" col-width col))
                                  row col-widths))
                      ks mat Cs))))))
    (newline))


(define-class <time-counter> ()
accured time , in seconds
  )

(define-method initialize ((self <time-counter>) initargs)
  (next-method)
  (when (eq? (class-of self) <time-counter>)
    (error "you can't instantiate <time-counter> class directly; use either <real-time-counter>, <user-time-counter> or <process-time-counter>"))
  )

(define-method time-counter-start! ((self <time-counter>))
  (let1 nesting (slot-ref self 'nesting)
    (when (zero? nesting)
      (slot-set! self 'start (time-counter-get-current-time self)))
    (slot-set! self 'nesting (+ nesting 1))))


(define-method time-counter-stop! ((self <time-counter>))
  (let1 nesting (slot-ref self 'nesting)
    (cond
     [(= nesting 1)
      (inc! (slot-ref self 'value) (time-counter-get-delta self))
      (set! (slot-ref self 'nesting) 0)]
     [(> nesting 1)
      (set! (slot-ref self 'nesting) (- nesting 1))]
     [else
      (set! (slot-ref self 'nesting) 0)])))

(define-method time-counter-get-delta ((self <time-counter>))
  (let1 end (time-counter-get-current-time self)
    (- end (slot-ref self 'start))))

(define-method time-counter-value ((self <time-counter>))
  (slot-ref self 'value))

(define-method time-counter-reset! ((self <time-counter>))
  (slot-set! self 'value 0)
  (slot-set! self 'nesting 0))

(define-method write-object ((self <time-counter>) port)
  (format port "#<~a ~a>"
          (class-name (class-of self))
          (format-delta-time (slot-ref self 'value))))

(define-syntax with-time-counter
  (syntax-rules ()
    [(_ counter . exprs)
     (let1 c counter
       (dynamic-wind
           (lambda () (time-counter-start! c))
           (lambda () . exprs)
           (lambda () (time-counter-stop! c))))]))

(define-class <real-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <real-time-counter>))
  (receive r (sys-gettimeofday) r))

(define-method time-counter-get-delta ((self <real-time-counter>))
  (receive (sec usec) (sys-gettimeofday)
    (+ (- sec (car (slot-ref self 'start)))
       (/. (- usec (cadr (slot-ref self 'start)))
           1000000))))

(define-class <user-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <user-time-counter>))
  (let1 times (sys-times)
    (/. (list-ref times 0) (list-ref times 4))))

(define-class <system-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <system-time-counter>))
  (let1 times (sys-times)
    (/. (list-ref times 1) (list-ref times 4))))

(define-class <process-time-counter> (<time-counter>)
  ())

(define-method time-counter-get-current-time ((self <process-time-counter>))
  (let1 times (sys-times)
    (/. (+ (list-ref times 0) (list-ref times 1))
        (list-ref times 4))))
