Implements memory profiling

eval/compile.rkt

@@ -333,6 +333,7 @@
                  (make-vector (*rival-profile-executions*))
                  (make-flvector (*rival-profile-executions*))
                  (make-vector (*rival-profile-executions*))
+                 (make-vector (*rival-profile-executions*))
                  (make-vector (*rival-profile-executions*))))
 
 ;;  Defining instructions that do not depend on input arguments

eval/machine.rkt

@@ -41,6 +41,7 @@
                    profile-instruction
                    profile-number
                    profile-time
+                   profile-memory
                    profile-precision
                    profile-iteration))
 

eval/main.rkt

@@ -24,7 +24,13 @@
          *rival-use-shorthands*
          *rival-name-constants*
          rival-profile
-         (struct-out execution)
+         make-execution
+         execution-name
+         execution-number
+         execution-precision
+         execution-time
+         execution-memory
+         execution-iteration
          *rival-profile-executions*)
 
 (define (rival-machine-full machine vhint)
@@ -40,7 +46,10 @@
 (struct exn:rival:invalid exn:rival (pt))
 (struct exn:rival:unsamplable exn:rival (pt))
 
-(struct execution (name number precision time iteration) #:prefab)
+(struct execution (name number precision time memory iteration) #:prefab)
+
+(define (make-execution name number precision time memory iteration)
+  (execution name number precision time memory iteration))
 
 (define (rival-profile machine param)
   (match param
@@ -52,15 +61,17 @@
      (define profile-instruction (rival-machine-profile-instruction machine))
      (define profile-number (rival-machine-profile-number machine))
      (define profile-time (rival-machine-profile-time machine))
+     (define profile-memory (rival-machine-profile-memory machine))
      (define profile-precision (rival-machine-profile-precision machine))
      (define profile-iteration (rival-machine-profile-iteration machine))
      (begin0 (for/vector #:length profile-ptr
                          ([instruction (in-vector profile-instruction 0 profile-ptr)]
                           [number (in-vector profile-number 0 profile-ptr)]
                           [precision (in-vector profile-precision 0 profile-ptr)]
                           [time (in-flvector profile-time 0 profile-ptr)]
+                          [memory (in-vector profile-memory 0 profile-ptr)]
                           [iter (in-vector profile-iteration 0 profile-ptr)])
-               (execution instruction number precision time iter))
+               (execution instruction number precision time memory iter))
        (set-rival-machine-profile-ptr! machine 0))]))
 
 (define (ival-real x)

eval/run.rkt

@@ -20,16 +20,18 @@
   (set-rival-machine-bumps! machine 0)
   (*bumps-activated* #f))
 
-(define (rival-machine-record machine name number precision time iter)
+(define (rival-machine-record machine name number precision time memory iter)
   (define profile-ptr (rival-machine-profile-ptr machine))
   (define profile-instruction (rival-machine-profile-instruction machine))
   (when (< profile-ptr (vector-length profile-instruction))
     (define profile-number (rival-machine-profile-number machine))
     (define profile-time (rival-machine-profile-time machine))
+    (define profile-memory (rival-machine-profile-memory machine))
     (define profile-precision (rival-machine-profile-precision machine))
     (define profile-iteration (rival-machine-profile-iteration machine))
     (vector-set! profile-instruction profile-ptr name)
     (vector-set! profile-number profile-ptr number)
+    (vector-set! profile-memory profile-ptr memory)
     (vector-set! profile-precision profile-ptr precision)
     (vector-set! profile-iteration profile-ptr iter)
     (flvector-set! profile-time profile-ptr time)
@@ -56,13 +58,15 @@
     (define out
       (match hint
         [#t ; instruction should be reevaluated
-         (define start (current-inexact-milliseconds))
+         (define start-time (current-inexact-milliseconds))
+         (define start-memory (current-memory-use 'cumulative))
          (define res
            (parameterize ([bf-precision precision])
              (apply-instruction instr vregs)))
          (define name (object-name (car instr)))
-         (define time (- (current-inexact-milliseconds) start))
-         (rival-machine-record machine name n precision time iter)
+         (define time (- (current-inexact-milliseconds) start-time))
+         (define memory (- (current-memory-use 'cumulative) start-memory))
+         (rival-machine-record machine name n precision time memory iter)
          res]
         [(? integer? _) (vector-ref vregs (list-ref instr hint))] ; result is known
         [(? ival? _) hint])) ; result is known
@@ -112,12 +116,14 @@
 
 (define (rival-machine-adjust machine vhint)
   (define iter (rival-machine-iteration machine))
-  (let ([start (current-inexact-milliseconds)])
+  (let ([start-time (current-inexact-milliseconds)]
+        [start-memory (current-memory-use 'cumulative)])
     (unless (zero? iter)
       (backward-pass machine vhint))
     (rival-machine-record machine
                           'adjust
                           -1
                           (* iter 1000)
-                          (- (current-inexact-milliseconds) start)
+                          (- (current-inexact-milliseconds) start-time)
+                          (- (current-memory-use 'cumulative) start-memory)
                           iter)))

info.rkt

@@ -1,7 +1,7 @@
 #lang info
 
 (define collection "rival")
-(define version "2.2")
+(define version "2.3")
 (define license 'MIT)
 
 ;; Packaging information

infra/run-baseline.rkt

@@ -32,6 +32,7 @@
                    profile-instruction
                    profile-number
                    profile-time
+                   profile-memory
                    profile-precision
                    profile-iteration))
 
@@ -191,6 +192,7 @@
                     (make-vector (*rival-profile-executions*))
                     (make-flvector (*rival-profile-executions*))
                     (make-vector (*rival-profile-executions*))
+                    (make-vector (*rival-profile-executions*))
                     (make-vector (*rival-profile-executions*))))
 
 ; ------------------------------------------- APPLY --------------------------------------------------
@@ -226,7 +228,8 @@
   (list (ival (or bad? stuck?) (not good?)) hint* hint*-converged?))
 
 (define (baseline-machine-adjust machine)
-  (let ([start (current-inexact-milliseconds)])
+  (let ([start-time (current-inexact-milliseconds)]
+        [start-memory (current-memory-use 'cumulative)])
     (define new-prec (bf-precision))
     (set-baseline-machine-precision! machine new-prec)
     (vector-fill! (baseline-machine-precisions machine) new-prec)
@@ -285,7 +288,8 @@
                              'adjust
                              -1
                              (* iter 1000)
-                             (- (current-inexact-milliseconds) start)
+                             (- (current-inexact-milliseconds) start-time)
+                             (- (current-memory-use 'cumulative) start-memory)
                              iter)))
 
 (define (drop-self-pointers tail-regs n)
@@ -318,13 +322,15 @@
     (define out
       (match hint
         [#t
-         (define start (current-inexact-milliseconds))
+         (define start-time (current-inexact-milliseconds))
+         (define start-memory (current-memory-use 'cumulative))
          (define res
            (parameterize ([bf-precision precision])
              (apply-instruction instr vregs)))
          (define name (object-name (car instr)))
-         (define time (- (current-inexact-milliseconds) start))
-         (baseline-machine-record machine name n precision time iter)
+         (define time (- (current-inexact-milliseconds) start-time))
+         (define memory (- (current-memory-use 'cumulative) start-memory))
+         (baseline-machine-record machine name n precision time memory iter)
          res]
         [(? integer? _) (vector-ref vregs (list-ref instr hint))]
         [(? ival? _) hint]))
@@ -382,27 +388,31 @@
      (define profile-instruction (baseline-machine-profile-instruction machine))
      (define profile-number (baseline-machine-profile-number machine))
      (define profile-time (baseline-machine-profile-time machine))
+     (define profile-memory (baseline-machine-profile-memory machine))
      (define profile-precision (baseline-machine-profile-precision machine))
      (define profile-iteration (baseline-machine-profile-iteration machine))
      (begin0 (for/vector #:length profile-ptr
                          ([instruction (in-vector profile-instruction 0 profile-ptr)]
                           [number (in-vector profile-number 0 profile-ptr)]
                           [precision (in-vector profile-precision 0 profile-ptr)]
                           [time (in-flvector profile-time 0 profile-ptr)]
+                          [memory (in-vector profile-memory 0 profile-ptr)]
                           [iter (in-vector profile-iteration 0 profile-ptr)])
-               (execution instruction number precision time iter))
+               (make-execution instruction number precision time memory iter))
        (set-baseline-machine-profile-ptr! machine 0))]))
 
-(define (baseline-machine-record machine name number precision time iter)
+(define (baseline-machine-record machine name number precision time memory iter)
   (define profile-ptr (baseline-machine-profile-ptr machine))
   (define profile-instruction (baseline-machine-profile-instruction machine))
   (when (< profile-ptr (vector-length profile-instruction))
     (define profile-number (baseline-machine-profile-number machine))
     (define profile-time (baseline-machine-profile-time machine))
+    (define profile-memory (baseline-machine-profile-memory machine))
     (define profile-precision (baseline-machine-profile-precision machine))
     (define profile-iteration (baseline-machine-profile-iteration machine))
     (vector-set! profile-instruction profile-ptr name)
     (vector-set! profile-number profile-ptr number)
+    (vector-set! profile-memory profile-ptr memory)
     (vector-set! profile-precision profile-ptr precision)
     (vector-set! profile-iteration profile-ptr iter)
     (flvector-set! profile-time profile-ptr time)

main.rkt

@@ -122,7 +122,13 @@
          *rival-profile-executions*
          *rival-use-shorthands*
          *rival-name-constants*
-         (struct-out execution))
+         make-execution
+         execution-name
+         execution-number
+         execution-precision
+         execution-time
+         execution-memory
+         execution-iteration)
 
 (require "utils.rkt")
 (provide flonum-discretization

repl.rkt

@@ -28,7 +28,7 @@
   (define iter 0)
   (define last #f)
   (for/list ([exec (in-vector execs)])
-    (match-define (execution name id precision time _) exec)
+    (define id (execution-number exec))
     (when (and last (< id last))
       (set! iter (+ iter 1)))
     (set! last id)
@@ -40,13 +40,21 @@
       (display (~a (fn row col) #:width width #:align 'right)))
     (newline)))
 
-(define-syntax-rule (list-find-match l pattern body ...)
-  (let loop ([l l])
-    (match l
-      [(cons pattern rest)
-       body ...]
-      [(cons _ rest) (loop rest)]
-      ['() ""])))
+(define (lookup-execution execs
+                          #:iter [target-iter #f]
+                          #:id [target-id #f]
+                          #:name [target-name #f]
+                          #:default [default ""]
+                          #:value [value (lambda (_iter exec) exec)])
+  (define entry
+    (for/first ([exec (in-list execs)]
+                #:when (and (or (not target-iter) (= (car exec) target-iter))
+                            (or (not target-id) (= (execution-number (cdr exec)) target-id))
+                            (or (not target-name) (= (execution-name (cdr exec)) target-name))))
+      exec))
+  (if entry
+      (value (car entry) (cdr entry))
+      default))
 
 (struct repl ([precision #:mutable] context))
 
@@ -88,58 +96,73 @@
   (printf "Executed ~a instructions for ~a iterations:\n\n" num-instructions num-iterations)
 
   (define execs* (executions-iterations execs))
-  (write-table #:rows (+ 5 num-instructions) ; 1 for the "adjust" row
-               #:cols (+ 1 (* 2 num-iterations))
-               #:width 6
-               (lambda (row col)
-                 (match* (row col)
-                   [(0 0) ""]
-                   [(0 col)
-                    #:when (= (modulo col 2) 1)
-                    "Bits"]
-                   [(0 col)
-                    #:when (= (modulo col 2) 0)
-                    "Time"]
-                   [(1 _) "------"]
-                   [(2 0) 'adjust]
-                   [(2 col)
-                    #:when (and (= (modulo col 2) 0) (> col 2))
-                    (define iter (- (/ col 2) 1))
-                    (list-find-match execs*
-                                     (cons (== iter) (execution 'adjust _ _ time _))
-                                     (~r (* time 1000) #:precision '(= 1)))]
-                   [(2 col) ""]
-                   [((== (+ 3 num-instructions)) _) "------"]
-                   [((== (+ 4 num-instructions)) 0) "Total"]
-                   [((== (+ 4 num-instructions)) col)
-                    #:when (= (modulo col 2) 1)
-                    ""]
-                   [((== (+ 4 num-instructions)) col)
-                    #:when (= (modulo col 2) 0)
-                    (define iter (/ (- col 2) 2))
-                    (define time
-                      (apply +
-                             (for/list ([exec (in-list execs*)]
-                                        #:when (= (car exec) iter))
-                               (execution-time (cdr exec)))))
-                    (~r (* time 1000) #:precision '(= 1))]
-                   [(row 0)
-                    (define id (+ (- row 3) num-args))
-                    (list-find-match execs*
-                                     (cons _ (execution name (== id) _ _ _))
-                                     (normalize-function-name (~a name)))]
-                   [(row col)
-                    #:when (= (modulo col 2) 1) ; precision
-                    (define id (+ (- row 3) num-args))
-                    (define iter (/ (- col 1) 2))
-                    (list-find-match execs* (cons (== iter) (execution _ (== id) prec _ _)) prec)]
-                   [(row col)
-                    #:when (= (modulo col 2) 0) ; time
-                    (define id (+ (- row 3) num-args))
-                    (define iter (/ (- col 2) 2))
-                    (list-find-match execs*
-                                     (cons (== iter) (execution _ (== id) _ time _))
-                                     (~r (* time 1000) #:precision '(= 1)))]))))
+  (write-table
+   #:rows (+ 5 num-instructions) ; 1 for the "adjust" row
+   #:cols (+ 1 (* 2 num-iterations))
+   #:width 6
+   (lambda (row col)
+     (match* (row col)
+       [(0 0) ""]
+       [(0 col)
+        #:when (= (modulo col 2) 1)
+        "Bits"]
+       [(0 col)
+        #:when (= (modulo col 2) 0)
+        "Time"]
+       [(1 _) "------"]
+       [(2 0) 'adjust]
+       [(2 col)
+        #:when (and (= (modulo col 2) 0) (> col 2))
+        (define iter (- (/ col 2) 1))
+        (lookup-execution execs*
+                          #:iter iter
+                          #:name 'adjust
+                          #:default ""
+                          #:value (lambda (_iter exec)
+                                    (~r (* (execution-time exec) 1000) #:precision '(= 1))))]
+       [(2 col) ""]
+       [((== (+ 3 num-instructions)) _) "------"]
+       [((== (+ 4 num-instructions)) 0) "Total"]
+       [((== (+ 4 num-instructions)) col)
+        #:when (= (modulo col 2) 1)
+        ""]
+       [((== (+ 4 num-instructions)) col)
+        #:when (= (modulo col 2) 0)
+        (define iter (/ (- col 2) 2))
+        (define time
+          (apply +
+                 (for/list ([exec (in-list execs*)]
+                            #:when (= (car exec) iter))
+                   (execution-time (cdr exec)))))
+        (~r (* time 1000) #:precision '(= 1))]
+       [(row 0)
+        (define id (+ (- row 3) num-args))
+        (lookup-execution execs*
+                          #:id id
+                          #:default ""
+                          #:value (lambda (_iter exec)
+                                    (normalize-function-name (~a (execution-name exec)))))]
+       [(row col)
+        #:when (= (modulo col 2) 1) ; precision
+        (define id (+ (- row 3) num-args))
+        (define iter (/ (- col 1) 2))
+        (lookup-execution execs*
+                          #:iter iter
+                          #:id id
+                          #:default ""
+                          #:value (lambda (_iter exec) (execution-precision exec)))]
+       [(row col)
+        #:when (= (modulo col 2) 0) ; time
+        (define id (+ (- row 3) num-args))
+        (define iter (/ (- col 2) 2))
+        (define value
+          (lookup-execution execs*
+                            #:iter iter
+                            #:id id
+                            #:default ""
+                            #:value (lambda (_iter exec)
+                                      (~r (* (execution-time exec) 1000) #:precision '(= 1)))))
+        value]))))
 
 (define (rival-repl p)
   (let/ec k