Use rival functions for most of baseline, just not precision adjust

Author: pavpanchekha

eval/adjust.rkt

@@ -7,7 +7,8 @@
          racket/match)
 
 (provide backward-pass
-         make-hint)
+         make-hint
+         drop-self-pointer)
 
 ; Hint is a vector with len(ivec) elements which
 ;   guides Rival on which instructions should not be executed

eval/run.rkt

@@ -13,6 +13,7 @@
          rival-machine-run
          rival-machine-return
          rival-machine-adjust
+         rival-machine-record
          apply-instruction) ; for compile.rkt
 
 (define (rival-machine-load machine args)

infra/run-baseline.rkt

@@ -6,128 +6,20 @@
 
 (require (only-in "../eval/compile.rkt" exprs->batch fn->ival-fn make-initial-repeats)
          (only-in "../eval/machine.rkt" *rival-max-precision* *rival-profile-executions*)
+         (only-in "../eval/run.rkt"
+                  rival-machine-load
+                  rival-machine-run
+                  rival-machine-return
+                  rival-machine-record)
+         (only-in "../eval/adjust.rkt" drop-self-pointer make-hint)
          "../eval/machine.rkt"
          "../eval/main.rkt"
          (only-in "../ops/core.rkt" new-ival)
          "../ops/all.rkt")
 
 (provide baseline-compile
          baseline-analyze
-         baseline-apply
-         baseline-profile)
-
-(define (make-hint machine old-hint)
-  (define args (rival-machine-arguments machine))
-  (define ivec (rival-machine-instructions machine))
-  (define rootvec (rival-machine-outputs machine))
-  (define vregs (rival-machine-registers machine))
-
-  (define varc (vector-length args))
-  (define vhint (make-vector (vector-length ivec) #f))
-  (define converged? #t)
-
-  ; helper function
-  (define (vhint-set! idx val)
-    (when (>= idx varc)
-      (vector-set! vhint (- idx varc) val)))
-
-  ; roots always should be executed
-  (for ([root-reg (in-vector rootvec)])
-    (vhint-set! root-reg #t))
-  (for ([instr (in-vector ivec (- (vector-length ivec) 1) -1 -1)]
-        [hint (in-vector vhint (- (vector-length vhint) 1) -1 -1)]
-        [o-hint (in-vector old-hint (- (vector-length old-hint) 1) -1 -1)]
-        [n (in-range (- (vector-length vhint) 1) -1 -1)]
-        #:when hint)
-    (define hint*
-      (match o-hint
-        [(? ival? _) o-hint] ; instr is already "hinted" by old hint, no children are to be recomputed
-        [(? integer? ref) ; instr is already "hinted" by old hint,
-         (define idx (list-ref instr ref)) ; however, one child needs to be recomputed
-         (when (>= idx varc)
-           (vhint-set! idx #t))
-         o-hint]
-        [#t
-         (case (object-name (car instr))
-           [(ival-assert)
-            (match-define (list _ bool-idx) instr)
-            (define bool-reg (vector-ref vregs bool-idx))
-            (match* ((ival-lo bool-reg) (ival-hi bool-reg) (ival-err? bool-reg))
-              ; assert and its children should not be reexecuted if it is true already
-              [(#t #t #f) (ival-bool #t)]
-              ; assert and its children should not be reexecuted if it is false already
-              [(#f #f #f) (ival-bool #f)]
-              [(_ _ _) ; assert and its children should be reexecuted
-               (vhint-set! bool-idx #t)
-               (set! converged? #f)
-               #t])]
-           [(ival-if)
-            (match-define (list _ cond tru fls) instr)
-            (define cond-reg (vector-ref vregs cond))
-            (match* ((ival-lo cond-reg) (ival-hi cond-reg) (ival-err? cond-reg))
-              [(#t #t #f) ; only true path should be executed
-               (vhint-set! tru #t)
-               2]
-              [(#f #f #f) ; only false path should be executed
-               (vhint-set! fls #t)
-               3]
-              [(_ _ _) ; execute both paths and cond as well
-               (vhint-set! cond #t)
-               (vhint-set! tru #t)
-               (vhint-set! fls #t)
-               (set! converged? #f)
-               #t])]
-           [(ival-fmax)
-            (match-define (list _ arg1 arg2) instr)
-            (define cmp (ival-> (vector-ref vregs arg1) (vector-ref vregs arg2)))
-            (match* ((ival-lo cmp) (ival-hi cmp) (ival-err? cmp))
-              [(#t #t #f) ; only arg1 should be executed
-               (vhint-set! arg1 #t)
-               1]
-              [(#f #f #f) ; only arg2 should be executed
-               (vhint-set! arg2 #t)
-               2]
-              [(_ _ _) ; both paths should be executed
-               (vhint-set! arg1 #t)
-               (vhint-set! arg2 #t)
-               (set! converged? #f)
-               #t])]
-           [(ival-fmin)
-            (match-define (list _ arg1 arg2) instr)
-            (define cmp (ival-> (vector-ref vregs arg1) (vector-ref vregs arg2)))
-            (match* ((ival-lo cmp) (ival-hi cmp) (ival-err? cmp))
-              [(#t #t #f) ; only arg2 should be executed
-               (vhint-set! arg2 #t)
-               2]
-              [(#f #f #f) ; only arg1 should be executed
-               (vhint-set! arg1 #t)
-               1]
-              [(_ _ _) ; both paths should be executed
-               (vhint-set! arg1 #t)
-               (vhint-set! arg2 #t)
-               (set! converged? #f)
-               #t])]
-           [(ival-< ival-<= ival-> ival->= ival-== ival-!= ival-and ival-or ival-not)
-            (define cmp (vector-ref vregs (+ varc n)))
-            (match* ((ival-lo cmp) (ival-hi cmp) (ival-err? cmp))
-              ; result is known
-              [(#t #t #f) (ival-bool #t)]
-              ; result is known
-              [(#f #f #f) (ival-bool #f)]
-              [(_ _ _) ; all the paths should be executed
-               (define srcs (rest instr))
-               (for-each (λ (x) (vhint-set! x #t)) srcs)
-               (set! converged? #f)
-               #t])]
-           [else ; at this point we are given that the current instruction should be executed
-            (define srcs
-              (drop-self-pointers (rest instr)
-                                  (+ n
-                                     varc))) ; then, children instructions should be executed as well
-            (for-each (λ (x) (vhint-set! x #t)) srcs)
-            #t])]))
-    (vector-set! vhint n hint*))
-  (values vhint converged?))
+         baseline-apply)
 
 ; ----------------------------------------- COMPILATION ----------------------------------------------
 (define (baseline-compile exprs vars discs)
@@ -189,7 +81,7 @@
   (define max-precision (rival-machine-max-precision machine))
   (define start-prec (+ (discretization-target (vector-ref discs (- (vector-length discs) 1))) 10))
   ; Load arguments
-  (baseline-machine-load machine (vector-map ival-real pt))
+  (rival-machine-load machine (vector-map ival-real pt))
   (let loop ([prec start-prec]
              [iter 0])
     (set-rival-machine-iteration! machine iter)
@@ -205,7 +97,7 @@
       [else (loop (* 2 prec) (+ iter 1))])))
 
 (define (baseline-analyze machine rect [hint #f])
-  (baseline-machine-load machine rect)
+  (rival-machine-load machine rect)
   (set-rival-machine-iteration! machine 0)
   (define-values (good? done? bad? stuck? fvec)
     (baseline-machine-full machine (or hint (rival-machine-default-hint machine))))
@@ -243,7 +135,7 @@
         (cond
           [(and (ival-lo-fixed? reg) (ival-hi-fixed? reg)) (vector-set! vuseful i #f)]
           [useful?
-           (for ([arg (in-list (drop-self-pointers (cdr instr) (+ i varc)))]
+           (for ([arg (in-list (drop-self-pointer (cdr instr) (+ i varc)))]
                  #:when (>= arg varc))
              (vector-set! vuseful (- arg varc) #t))]))
 
@@ -253,7 +145,7 @@
             [best-known-precision (in-vector vbest-precs)]
             [constant? (in-vector vinitial-repeats)]
             [n (in-naturals)])
-        (define tail-registers (drop-self-pointers (cdr instr) (+ n varc)))
+        (define tail-registers (drop-self-pointer (cdr instr) (+ n varc)))
         ; When instr is a constant instruction - keep tracks of old precision with vbest-precs vector
         (define no-need-to-reevaluate
           (and constant?
@@ -269,136 +161,15 @@
                        new-prec)) ; record new best precision for the constant instruction
         (vector-set! vrepeats n repeat)))
 
-    (baseline-machine-record machine
-                             'adjust
-                             -1
-                             (* iter 1000)
-                             (- (current-inexact-milliseconds) start-time)
-                             (- (current-memory-use 'cumulative) start-memory)
-                             iter)))
-
-(define (drop-self-pointers tail-regs n)
-  (filter (λ (x) (not (equal? x n))) tail-regs))
+    (rival-machine-record machine
+                          'adjust
+                          -1
+                          (* iter 1000)
+                          (- (current-inexact-milliseconds) start-time)
+                          (- (current-memory-use 'cumulative) start-memory)
+                          iter)))
 
 (define (baseline-machine-full machine vhint)
   (baseline-machine-adjust machine)
-  (baseline-machine-run machine vhint)
-  (baseline-machine-return machine))
-
-(define (baseline-machine-load machine args)
-  (vector-copy! (rival-machine-registers machine) 0 args))
-
-(define (baseline-machine-run machine vhint)
-  (define ivec (rival-machine-instructions machine))
-  (define varc (vector-length (rival-machine-arguments machine)))
-  (define vregs (rival-machine-registers machine))
-  (define precisions (rival-machine-precisions machine))
-  (define repeats (rival-machine-repeats machine))
-  (define initial-repeats (rival-machine-initial-repeats machine))
-  (define iter (rival-machine-iteration machine))
-  (define first-iter? (zero? (rival-machine-iteration machine)))
-
-  (for ([instr (in-vector ivec)]
-        [n (in-naturals varc)]
-        [precision (in-vector precisions)]
-        [repeat (in-vector (if first-iter? initial-repeats repeats))]
-        [hint (in-vector vhint)]
-        #:unless (or (not hint) repeat))
-    (define out
-      (match hint
-        [#t
-         (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-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]))
-    (vector-set! vregs n out)))
-
-(define (apply-instruction instr regs)
-  ;; By special-casing the 0-3 instruction case,
-  ;; we avoid any allocation in the common case.
-  ;; We could add more cases if we want wider instructions.
-  ;; At some extreme, vector->values plus call-with-values
-  ;; becomes the fastest option.
-  (match instr
-    [(list op) (op)]
-    [(list op a) (op (vector-ref regs a))]
-    [(list op a b) (op (vector-ref regs a) (vector-ref regs b))]
-    [(list op a b c) (op (vector-ref regs a) (vector-ref regs b) (vector-ref regs c))]
-    [(list op args ...) (apply op (map (curryr vector-ref regs) args))]))
-
-(define (baseline-machine-return machine)
-  (define discs (rival-machine-discs machine))
-  (define vregs (rival-machine-registers machine))
-  (define rootvec (rival-machine-outputs machine))
-  (define ovec (make-vector (vector-length rootvec)))
-  (define good? #t)
-  (define done? #t)
-  (define bad? #f)
-  (define stuck? #f)
-  (define fvec
-    (for/vector #:length (vector-length rootvec)
-                ([root (in-vector rootvec)]
-                 [disc (in-vector discs)]
-                 [n (in-naturals)])
-      (define out (vector-ref vregs root))
-      (define lo ((discretization-convert disc) (ival-lo out)))
-      (define hi ((discretization-convert disc) (ival-hi out)))
-      (define distance ((discretization-distance disc) lo hi))
-      (unless (= distance 0)
-        (set! done? #f)
-        (when (and (ival-lo-fixed? out) (ival-hi-fixed? out))
-          (set! stuck? #t)))
-      (cond
-        [(ival-err out) (set! bad? #t)]
-        [(ival-err? out) (set! good? #f)])
-      lo))
-  (values good? (and good? done?) bad? stuck? fvec))
-
-; ---------------------------------------- PROFILING -------------------------------------------------
-(define (baseline-profile machine param)
-  (match param
-    ['iteration (rival-machine-iteration machine)]
-    ['precision (bf-precision)]
-    ['instructions (vector-length (rival-machine-instructions machine))]
-    ['executions
-     (define profile-ptr (rival-machine-profile-ptr machine))
-     (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)])
-               (make-execution instruction number precision time memory iter))
-       (set-rival-machine-profile-ptr! machine 0))]))
-
-(define (baseline-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)
-    (set-rival-machine-profile-ptr! machine (add1 profile-ptr))))
+  (rival-machine-run machine vhint)
+  (rival-machine-return machine))

main.rkt

@@ -108,8 +108,7 @@
           [baseline-apply
            (->* (rival-machine? (vectorof value?))
                 ((or/c (vectorof any/c) boolean?))
-                (vectorof any/c))]
-          [baseline-profile (-> rival-machine? symbol? any/c)])
+                (vectorof any/c))])
          (struct-out discretization)
          (struct-out exn:rival)
          (struct-out exn:rival:invalid)

time.rkt

@@ -94,9 +94,9 @@
             (define exs (vector-ref (baseline-apply baseline-machine (list->vector (map bf pt))) 1))
             (list 'valid exs))))
       (define baseline-apply-time (- (current-inexact-milliseconds) baseline-start-apply))
-      (define baseline-precision (baseline-profile baseline-machine 'precision))
-      (define baseline-executions (baseline-profile baseline-machine 'executions))
-      (define baseline-iteration (baseline-profile baseline-machine 'iteration))
+      (define baseline-precision (bf-precision))
+      (define baseline-executions (rival-profile baseline-machine 'executions))
+      (define baseline-iteration (rival-profile baseline-machine 'iterations))
 
       ; Store histograms data
       (when (> baseline-iteration 0)