diff --git a/.gitignore b/.gitignore index b2857b2cc..7437e4076 100644 --- a/.gitignore +++ b/.gitignore @@ -1,19 +1,9 @@ *~ graphs -compile/*.o -compile/*.bin -compile/tc*.c -compile/tc*.out -compile/tc.json -compile/nr*.c -compile/nr*.out -compile/nr.json -compile/cost -compiled/ -ml-toy papers www/demo demo.log *.class -cost +infra/cost previous +*.swp diff --git a/.travis.yml b/.travis.yml index efda69ce8..d5657acb3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,31 +4,22 @@ env: global: - RACKET_DIR=~/racket TBENCHES="bench/tutorial.fpcore bench/hamming/" - HERBIE_SEED="#(2749829514 1059579101 312104142 915324965 966790849 1349306526)" - TSEED="racket $TRAVIS_BUILD_DIR/infra/travis.rkt --seed '${HERBIE_SEED}' $TBENCHES" - TRAND="racket $TRAVIS_BUILD_DIR/infra/travis.rkt $TBENCHES" - UTEST="raco test src" + HERBIE_SEED="0" + UNIT="raco test src/ infra/" + INTEGRATION="racket $TRAVIS_BUILD_DIR/infra/travis.rkt --seed '${HERBIE_SEED}' $TBENCHES" + STABILITY="racket $TRAVIS_BUILD_DIR/infra/travis.rkt $TBENCHES" matrix: # separate builds for travis benches and unit tests - - RACKET_VERSION="6.7" - JOB="${TSEED}" - - RACKET_VERSION="6.9" - JOB="${TSEED}" - - RACKET_VERSION="6.11" - JOB="${TSEED}" - - RACKET_VERSION="6.7" - JOB="${UTEST}" - - RACKET_VERSION="6.9" - JOB="${UTEST}" - - RACKET_VERSION="6.11" - JOB="${UTEST}" + - RACKET_VERSION="7.3" JOB="${UNIT}" + - RACKET_VERSION="7.0" JOB="${INTEGRATION}" + - RACKET_VERSION="7.2" JOB="${INTEGRATION}" + - RACKET_VERSION="7.3" JOB="${INTEGRATION}" # remember to change the `allow_failures` key below! - - RACKET_VERSION="6.11" - JOB="${TRAND}" + - RACKET_VERSION="7.3" JOB="${STABILITY}" matrix: allow_failures: - - env: RACKET_VERSION="6.11" - JOB="${TRAND}" + - env: RACKET_VERSION="7.3" JOB="${STABILITY}" + fast_finish: true before_install: - git clone https://github.com/greghendershott/travis-racket.git ../travis-racket - cat ../travis-racket/install-racket.sh | bash diff --git a/Dockerfile b/Dockerfile index 58a218809..aa2759bdb 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,4 +1,4 @@ -FROM jackfirth/racket:6.12 +FROM jackfirth/racket:7.3 MAINTAINER Pavel Panchekha RUN apt-get update \ && apt-get install -y libcairo2-dev libjpeg62 libpango1.0-dev \ diff --git a/EDITING.md b/EDITING.md deleted file mode 100644 index 44b4b8006..000000000 --- a/EDITING.md +++ /dev/null @@ -1,25 +0,0 @@ - -Editing -======= - -You should use Emacs to edit Racket code; Dr. Racket, which ships with -Racket, is a bit too limited an editor for the number of files and -complexity of Herbie. You’ll want to use the `quack` and `geiser` Emacs -packages to give you Racket-specific highlighting and a Racket REPL. -The easiest way to install these is to run - - (require 'package) - (add-to-list 'package-archives - '("marmalade" . "http://marmalade-repo.org/packages/")) - (package-initialize) - (mapcar #'package-install '(quack geiser)) - -This needs to be done once. You can now open a Racket file, like -`herbie/main.rkt`, and the mode-line will read `Scheme Racket/A`, -indicating that Quack, the Scheme mode, is running. - -If you hit `C-c C-a` in a Racket buffer, you’ll open up a REPL and -“enter” that module, allowing you to refer to definitions in it. The -same `C-c C-a` binding reloads the file, while `C-M-x` reloads -individual definitions and `C-c C-e` executes individual -S-expressions. \ No newline at end of file diff --git a/LICENSE.md b/LICENSE.md index 65958a1da..72c48ee95 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright (c) 2015 Herbie Project +Copyright (c) 2015-2019 Herbie Project Modified work Copyright 2016 Google Inc. Permission is hereby granted, free of charge, to any person obtaining diff --git a/Makefile b/Makefile index dc77b0d3d..c8a39a5ae 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -.PHONY: all install update nightly index clean publish start-server package loc deploy +.PHONY: all install update nightly index publish start-server package deploy all: @echo "Type 'make install' to install Herbie as a Racket package," @@ -23,28 +23,23 @@ herbie.zip herbie.zip.CHECKSUM: mv src.zip herbie.zip mv src.zip.CHECKSUM herbie.zip.CHECKSUM -clean: - rm -f cost - rm -rf graphs/ - publish: bash infra/publish.sh upload graphs/ bash infra/publish.sh index start-server: - racket src/herbie.rkt web --seed '#(2775764126 3555076145 3898259844 1891440260 2599947619 1948460636)' --timeout 60 --num-iters 2 --demo --prefix /demo/ --port 4053 --save-session www/demo/ --log infra/server.log --quiet 2>&1 + racket src/herbie.rkt web --seed 1 --timeout 150 --num-iters 2 \ + --demo --public --prefix /demo/ --port 4053 --save-session www/demo/ \ + --log infra/server.log --quiet 2>&1 package: raco pkg -loc: - find herbie/ -type f -exec cat {} \; | wc -l - # This rule is run by herbie.uwplse.org on every commit to Github. # It does not restart the demo server, but it does pull new static content deploy: cd $(shell ~/uwplse/getdir) && git pull -cost: infra/cost.c +infra/cost: infra/cost.c $(CC) -O0 $^ -lm -o $@ diff --git a/README.md b/README.md index 131a5e553..6221682d0 100644 --- a/README.md +++ b/README.md @@ -3,11 +3,11 @@ [![Build Status](https://travis-ci.org/uwplse/herbie.svg?branch=master)](https://travis-ci.org/uwplse/herbie) -Herbie synthesizes floating-point programs from real-number programs, -automatically handling simple numerical instabilities. Visit [our -website](https://herbie.uwplse.org) for tutorials, documentation, and -an online demo. Herbie has semi-regular releases twice a year, -maintains backwards compatibility, and uses standardized formats. +Herbie automatically improves the error of floating point expressions. +Visit [our website](https://herbie.uwplse.org) for tutorials, +documentation, and an online demo. Herbie has semi-regular releases +once a year, maintains backwards compatibility, and uses standardized +formats. Installing ---------- @@ -15,10 +15,10 @@ Installing For full details on installing Herbie, please see the [tutorial](http://herbie.uwplse.org/doc/latest/installing.html). -Herbie requires Racket 6.7 or later, and supports Windows, OS X, and +Herbie requires Racket 7.0 or later, and supports Windows, macOS, and Linux. Install it with: - raco pkg install herbie + raco pkg install --auto herbie This will install a `herbie` binary to somewhere in your home directory. You can also run `src/herbie.rkt` directly instead of using @@ -35,15 +35,14 @@ Herbie's input is a Scheme-based language called [FPCore](http://fpbench.org/spe you can several examples in `bench/`. For example, consider this simple expression: - (FPCore (x) - (- (+ 1 x) x)) + (FPCore (x) (- (+ 1 x) x)) Run Herbie from the top-level directory of the repo, and enter the cancellation test: $ herbie shell - Herbie 1.2 with seed #(349461420 3681359142 2680361770 2900531005 1939065059 1779362427) - Find help on , exit with Ctrl-D + Herbie 1.3 with seed 1866513483 + Find help on https://herbie.uwplse.org/, exit with Ctrl-D herbie> (FPCore (x) (- (+ 1 x) x)) (FPCore (x) ... 1) @@ -53,7 +52,7 @@ the constant `1`. Besides the `shell`, Herbie also has a `web` interface, and can run on files of FPCore expressions with the `improve` and `report` commands. Consult the -[documentation](http://herbie.uwplse.org/doc/latest/options.html). +[documentation](http://herbie.uwplse.org/doc/latest/tutorial.html). for more. Helping Out diff --git a/bench/hamming/complex.fpcore b/bench/hamming/complex.fpcore index 4aa8508fa..520c09780 100644 --- a/bench/hamming/complex.fpcore +++ b/bench/hamming/complex.fpcore @@ -1,23 +1,22 @@ ; -*- mode: scheme -*- -; TODO: exp function unimplemented. -#;(FPCore (xre xim) +(FPCore (xre xim) :name "exp with complex power real part (p55)" (let ([x (complex xre xim)]) (re (/ (+ (exp x) (exp (- x))) (complex 2 0))))) -#;(FPCore (xre xim) +(FPCore (xre xim) :name "exp with complex power imaginary part (p55)" (let ([x (complex xre xim)]) (im (/ (+ (exp x) (exp (- x))) (complex 2 0))))) -#;(FPCore (x y) +(FPCore (x y) :name "Euler formula real part (p55)" (let ([a (/ (+ (exp x) (exp (- x))) 2)] [b (/ (- (exp x) (exp (- x))) 2)]) (re (complex (* a (cos y)) (* b (sin y)))))) -#;(FPCore (x y) +(FPCore (x y) :name "Euler formula imaginary part (p55)" (let ([a (/ (+ (exp x) (exp (- x))) 2)] [b (/ (- (exp x) (exp (- x))) 2)]) diff --git a/bench/hamming/machine-decide.fpcore b/bench/hamming/machine-decide.fpcore index bb84b7421..f2dd3aae1 100644 --- a/bench/hamming/machine-decide.fpcore +++ b/bench/hamming/machine-decide.fpcore @@ -2,6 +2,7 @@ (FPCore (a x) :name "expax (section 3.5)" + :herbie-expected 14 :herbie-target (if (< (fabs (* a x)) 1/10) (* (* a x) (+ 1 (+ (/ (* a x) 2) (/ (pow (* a x) 2) 6)))) diff --git a/bench/haskell.fpcore b/bench/haskell.fpcore index 7c923df13..f00d6c63b 100644 --- a/bench/haskell.fpcore +++ b/bench/haskell.fpcore @@ -945,7 +945,10 @@ (if (< z 7.636950090573675e+176) (* 2.0 (sqrt (+ (* (+ x y) z) (* x y)))) (* - (sqr + (* + (+ + (* 1/4 (* (* (pow y -3/4) (* (pow z -3/4) x)) (+ y z))) + (* (pow z 1/4) (pow y 1/4))) (+ (* 1/4 (* (* (pow y -3/4) (* (pow z -3/4) x)) (+ y z))) (* (pow z 1/4) (pow y 1/4)))) diff --git a/bench/libraries/mathjs/arithmetic.fpcore b/bench/libraries/mathjs/arithmetic.fpcore index c0be790ea..1604a66cf 100644 --- a/bench/libraries/mathjs/arithmetic.fpcore +++ b/bench/libraries/mathjs/arithmetic.fpcore @@ -11,12 +11,21 @@ (FPCore (x.re x.im) :name "math.cube on complex, real part" + :herbie-target + (+ (* (* x.re x.re) (- x.re x.im)) + (* (* x.re x.im) (- x.re (* 3 x.im)))) + (- (* (- (* x.re x.re) (* x.im x.im)) x.re) (* (+ (* x.re x.im) (* x.im x.re)) x.im))) (FPCore (x.re x.im) :name "math.cube on complex, imaginary part" + :herbie-target + (+ + (* (* x.re x.im) (* 2 x.re)) + (* (* x.im (- x.re x.im)) (+ x.re x.im))) + (+ (* (- (* x.re x.re) (* x.im x.im)) x.im) (* (+ (* x.re x.im) (* x.im x.re)) x.re))) @@ -107,7 +116,7 @@ (FPCore (re im) :name "math.sqrt on complex, imaginary part, im greater than 0 branch" - (* 0.5 (sqrt (* 2.0 (+ (sqrt (- (* re re) (* im im))) re))))) + (* 0.5 (sqrt (* 2.0 (- (sqrt (+ (* re re) (* im im))) re))))) (FPCore (re im) :name "math.square on complex, real part" diff --git a/bench/mathematics/excel.fpcore b/bench/mathematics/excel.fpcore new file mode 100644 index 000000000..e15a2d3ce --- /dev/null +++ b/bench/mathematics/excel.fpcore @@ -0,0 +1,5 @@ +(FPCore (x0 x1) + :name "(- (/ x0 (- 1 x1)) x0)" + :pre (or (and (== x0 1.855) (== x1 0.000209)) (and (== x0 2.985) (== x1 0.0186))) + :herbie-target (/ (* x0 x1) (- 1 x1)) + (- (/ x0 (- 1 x1)) x0)) diff --git a/bench/mathematics/latlong.fpcore b/bench/mathematics/latlong.fpcore index 265af14b0..815f3fee6 100644 --- a/bench/mathematics/latlong.fpcore +++ b/bench/mathematics/latlong.fpcore @@ -47,6 +47,7 @@ (lambdam (+ lambda1 (atan2 By (+ (cos phi1) Bx))))) lambdam)))) +;; TODO: phi2 unused (FPCore (lambda1 phi1 phi2 delta theta) :name "Destination given bearing on a great circle" (let ((phi2 diff --git a/bench/mathematics/sarnoff.fpcore b/bench/mathematics/sarnoff.fpcore index bd6129821..2cf453406 100644 --- a/bench/mathematics/sarnoff.fpcore +++ b/bench/mathematics/sarnoff.fpcore @@ -25,25 +25,25 @@ (< 4.930380657631324e-32 c 2.028240960365167e31)) (/ (+ (- b) (sqrt (- (* b b) (* 4 a c)))) (* 2 a))) -(FPCore (a b c d) +(FPCore (a b c) :name "Cubic critical" (/ (+ (- b) (sqrt (- (* b b) (* 3 a c)))) (* 3 a))) -(FPCore (a b c d) +(FPCore (a b c) :name "Cubic critical, narrow range" :pre (and (< 1.0536712127723509e-8 a 9.490626562425156e7) (< 1.0536712127723509e-8 b 9.490626562425156e7) (< 1.0536712127723509e-8 c 9.490626562425156e7)) (/ (+ (- b) (sqrt (- (* b b) (* 3 a c)))) (* 3 a))) -(FPCore (a b c d) +(FPCore (a b c) :name "Cubic critical, medium range" :pre (and (< 1.1102230246251565e-16 a 9.007199254740992e15) (< 1.1102230246251565e-16 b 9.007199254740992e15) (< 1.1102230246251565e-16 c 9.007199254740992e15)) (/ (+ (- b) (sqrt (- (* b b) (* 3 a c)))) (* 3 a))) -(FPCore (a b c d) +(FPCore (a b c) :name "Cubic critical, wide range" :pre (and (< 4.930380657631324e-32 a 2.028240960365167e31) (< 4.930380657631324e-32 b 2.028240960365167e31) diff --git a/bench/numerics/great-debate.fpcore b/bench/numerics/great-debate.fpcore new file mode 100644 index 000000000..794c508d9 --- /dev/null +++ b/bench/numerics/great-debate.fpcore @@ -0,0 +1,39 @@ +(FPCore (y) + :name "Kahan's Monster" + :pre (<= 1 y 9999) ; Integers only in Kahan's example but this is not essential + (let ([Qx (- (fabs (- y (sqrt (+ (* y y) 1)))) + (/ 1 (+ y (sqrt (+ (* y y) 1)))))]) + (let ([z (* Qx Qx)]) + (if (== z 0) 1 (/ (- (exp z) 1) z))))) + +(FPCore (y) + :name "Kahan's Unum-Targeted Monster" + :pre (<= 1 y 9999) ; Integers only in Kahan's example but this is not essential + (let ([Qx (- (fabs (- y (sqrt (+ (* y y) 1)))) (/ 1 (+ y (sqrt (+ (* y y) 1)))))]) + (let ([z (+ (* Qx Qx) (pow (pow 10 -300) (* 10000 (+ y 1))))]) + (if (== z 0) 1 (/ (- (exp z) 1) z))))) + +(FPCore (x y) + :name "Kahan p9 Example" + :pre (and (< 0 x 1) (< y 1)) + :herbie-target + (if (< 0.5 (fabs (/ x y)) 2) + (/ (* (- x y) (+ x y)) (+ (* x x) (* y y))) + (- 1 (/ 2 (+ 1 (* (/ x y) (/ x y)))))) + + (/ (* (- x y) (+ x y)) (+ (* x x) (* y y)))) + +(FPCore (t) + :name "Kahan p13 Example 1" + (let ([u (/ (* 2 t) (+ 1 t))]) + (/ (+ 1 (* u u)) (+ 2 (* u u))))) + +(FPCore (t) + :name "Kahan p13 Example 2" + (let ([v (- 2 (/ (/ 2 t) (+ 1 (/ 1 t))))]) + (/ (+ 1 (* v v)) (+ 2 (* v v))))) + +(FPCore (t) + :name "Kahan p13 Example 3" + (let ([v (- 2 (/ (/ 2 t) (+ 1 (/ 1 t))))]) + (- 1 (/ 1 (+ 2 (* v v)))))) diff --git a/bench/numerics/rump.fpcore b/bench/numerics/rump.fpcore new file mode 100644 index 000000000..6a214b52c --- /dev/null +++ b/bench/numerics/rump.fpcore @@ -0,0 +1,28 @@ +(FPCore (x y) + :name "Rump's expression from Stadtherr's award speech" + :pre (and (== x 77617) (== y 33096)) + :spec -54767/66192 + (+ (* 333.75 (pow y 6)) + (* (* x x) + (- (* 11 x x y y) + (pow y 6) + (* 121 (pow y 4)) + 2)) + (* 5.5 (pow y 8)) + (/ x (* 2 y)))) + +;; From +;; How Reliable are the Results of Computers +;; Jahrbuch Uberblicke Mathematik (1983) + +(FPCore (x y) + :name "From Rump in a 1983 paper" + :pre (and (== x 10864) (== y 18817)) + ;:pre (and (< 10500 x 11000) (< 18500 y 19000)) + (+ (- (* 9 (pow x 4)) (pow y 4)) (* 2 (* y y)))) + +(FPCore (x y) + :name "From Rump in a 1983 paper, rewritten" + :pre (and (== x 10864) (== y 18817)) + ;:pre (and (< 10500 x 11000) (< 18500 y 19000)) + (- (* 9 (pow x 4)) (* (* y y) (- (* y y) 2)))) diff --git a/bench/physics/sidey.fpcore b/bench/physics/sidey.fpcore new file mode 100644 index 000000000..964eb76df --- /dev/null +++ b/bench/physics/sidey.fpcore @@ -0,0 +1,14 @@ +;; Code courtesy of Sidey P. Timmins of NASA + +;; In the original, x was (- q r) +(FPCore (p x) + :name "Given's Rotation SVD example" + :pre (< 1e-150 (fabs x) 1e150) + :herbie-target + (sqrt (+ 1/2 (/ (copysign 1/2 x) (hypot 1 (/ (* 2 p) x))))) + (sqrt (* 0.5 (+ 1 (/ x (sqrt (+ (* 4 p p) (* x x)))))))) + +;; Here, I'm doing (1 - the above), and x here is (2p / x) +(FPCore (x) + :name "Given's Rotation SVD example, simplified" + (- 1 (sqrt (* 1/2 (+ 1 (/ 1 (hypot 1 x))))))) diff --git a/infra/all.sh b/infra/all.sh deleted file mode 100755 index 52ce2d9d6..000000000 --- a/infra/all.sh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/sh - -line () { tail $1 -n+$2 | head -n1; } - -for i in $1*.out; do - line $i 1 | paste -d, - "$2/shortnames.csv" -done > $1.names.csv -for i in $1*.out; do line $i 2; done > $1.pf.csv -for i in $1*.out; do line $i 3; done > $1.pd.csv -for i in $1*.out; do line $i 5; done > $1.if.csv -for i in $1*.out; do line $i 6; done > $1.id.csv -for i in $1*.out; do line $i 7; done > $1.of.csv -for i in $1*.out; do line $i 8; done > $1.od.csv -for i in $1*.out; do line $i 9; done > $1.df.csv -for i in $1*.out; do line $i 10; done > $1.dd.csv diff --git a/infra/backfill-index.rkt b/infra/backfill-index.rkt deleted file mode 100644 index f90e5c2ae..000000000 --- a/infra/backfill-index.rkt +++ /dev/null @@ -1,44 +0,0 @@ -#lang racket - -(require "../src/common.rkt") -(require "../src/formats/datafile.rkt") -(require "make-index.rkt") - -(define allowed-suites - '("tutorial" "regression" "physics" "numerics" "mathematics" "libraries" "hamming" "haskell")) - -(define (write-report-info folder info) - (let ([info-file (build-path report-output-path "reports" folder "results.json")]) - (write-datafile info-file info))) - -(define (same-tests? info1 info2) - (and (report-info-tests info1) (report-info-tests info2) - (set=? - (map table-row-input (report-info-tests info1)) - (map table-row-input (report-info-tests info2))))) - -(define (backfill-index) - (define dirs (directory-list (build-path report-output-path "reports/"))) - - (define folders - (map (λ (dir) (cons dir (read-report-info dir))) - (remove-duplicates - (sort (filter name->timestamp dirs) > #:key name->timestamp) - #:key name->timestamp))) - - (define reps - (for/list ([suite allowed-suites]) - (for/first ([(folder info) (in-dict folders)] #:when (equal? (report-info-note info) suite)) - info))) - - (for ([(folder info) (in-dict folders)]) - (define suite - (for/first ([suite allowed-suites] [rep reps] #:when (and info rep (same-tests? info rep))) - suite)) - (when (and suite (not (report-info-note info))) - (eprintf "Updating ~a to ~a\n" folder suite) - (set-report-info-note! info suite) - (write-report-info folder info)))) - -(module+ main - (backfill-index)) diff --git a/infra/bash-pred-test.rkt b/infra/bash-pred-test.rkt deleted file mode 100644 index dd10898d9..000000000 --- a/infra/bash-pred-test.rkt +++ /dev/null @@ -1,57 +0,0 @@ -#lang racket - -(require "../src/common.rkt") -(require "../src/points.rkt") -(require "../src/formats/test.rkt") -(require "../src/main.rkt") -(require "../src/alternative.rkt") -(require "../src/programs.rkt") -(require racket/engine) - -(define *seed* #f) -(define *timeout* (* 1000 60 10)) -(define *lenient* #f) -(define *reeval-pts* 8000) - -(define (bash-pred-test benchdir testname) - (let* ([all-tests (load-tests benchdir)] - [test (findf (λ (t) (string=? (test-name t) testname)) all-tests)]) - (if (not test) (begin (println "Couldn't find the test!") (exit 1)) - (let ([eng (engine (λ _ (improve (test-program test) (*num-iterations*) - #:samplers (test-samplers test))))]) - (begin (engine-run *timeout* eng) - (let ([result-alt (engine-result eng)]) - (cond - [result-alt - (define newcontext - (parameterize ([*num-points* *reeval-pts*]) - (prepare-points (test-program test) (test-samplers test)))) - (match-define (list newpoints newexacts) (sorted-context-list newcontext 0)) - (let* ([start-errors (errors (test-program test) newcontext)] - [end-errors (errors (alt-program result-alt) newcontext)] - [start-score (errors-score start-errors)] - [end-score (errors-score end-errors)]) - (if (not (test-output test)) (if (start-score . < . end-score) (exit 0) (exit 1)) - (let* ([target-errors (errors `(λ ,(program-variables (test-program test)) - ,(test-output test)) newcontext)] - [target-score (errors-score target-errors)]) - (if (or *lenient* (target-score . <= . end-score)) (exit 0) (exit 1)))))] - [#f (println "Timeout.") (exit 1)]))))))) - -(command-line - #:program "bash-pred-test" - #:once-each - [("-r") rs "The random seed vector to use in point generation." - (set-seed! (read (open-input-string rs)))] - [("-n") fu "The amount of 'fuel' to use" - (*num-iterations* (string->number fu))] - [("-s") points "The number of points to use during search" - (*num-points* (string->number points))] - [("-e") epoints "The number of points to use during eval" - (set! *reeval-pts* epoints)] - [("-t") timeout "The number of seconds to wait before killing the test." - (set! *timeout* timeout)] - [("-l") "Return true as long as we finish and are better than start program." - (set! *lenient* #t)] - #:args (benchdir testname) - (bash-pred-test benchdir testname)) diff --git a/infra/bruteforce.c b/infra/bruteforce.c deleted file mode 100644 index f4195943b..000000000 --- a/infra/bruteforce.c +++ /dev/null @@ -1,112 +0,0 @@ -#define _POSIX_C_SOURCE 199309L -#include -#include -#include -#include -#include -#include - -void setup_mpfr_f_im(void); -void setup_mpfr_f_fm(void); -void setup_mpfr_f_dm(void); -double f_if(float); -double f_id(double); -double f_im(double); -double f_of(float); -double f_od(double); -double f_om(double); -extern char *name; - -typedef unsigned long long int u64; -typedef unsigned int u32; - -unsigned int ulpf(float x, float y) { - if (x == 0) x = fabsf(x); // -0 == 0 - if (y == 0) y = fabsf(y); // -0 == 0 - - if (x != x && y != y) return 0; - if (x != x) return INT_MIN; // Maximum error - if (y != y) return INT_MIN; // Maximum error - - u32 xx = *((u32*) &x); - xx = xx < 0 ? INT_MIN - xx : xx; - - u32 yy = *((u32*) &y); - yy = yy < 0 ? INT_MIN - yy : yy; - - return xx >= yy ? xx - yy : yy - xx; -} - -unsigned long long ulpd(double x, double y) { - if (x == 0) x = fabs(x); // -0 == 0 - if (y == 0) y = fabs(y); // -0 == 0 - - if (x != x && y != y) return 0; - if (x != x) return LLONG_MIN; // Maximum error - if (y != y) return LLONG_MIN; // Maximum error - - u64 xx = *((u64*) &x); - xx = xx < 0 ? LLONG_MIN - xx : xx; - - u64 yy = *((u64*) &y); - yy = yy < 0 ? LLONG_MIN - yy : yy; - - return xx >= yy ? xx - yy : yy - xx; -} - -char ordinaryf(float x) { - return 1 / x != 0 && x == x; -} - -char ordinaryd(double x) { - return 1 / x != 0 && x == x; -} - -int main(int argc, char** argv) { - u32 x = 0; - u32 stop = 0; - u32 parts, part; - float xf = 0.0, exact = 0.0, approxi = 0.0, approxo; - u32 ei = 0, eo = 0; - u32 maxi = 0, maxo = 0, numbad = 0, maxbad = 0; - - setup_mpfr_f_im(); - - if (argc < 3) { - printf("Usage: bfN.bin [log2(parts)] [part]\n"); - exit(1); - } - - parts = atoi(argv[1]); - part = atoi(argv[2]); - - x = (part << (32 - parts)); - if (part == (1 << parts)) { - stop = ~1u + 1u; // The last float is a NaN, so we don't care about it. - } else { - stop = (part + 1) << (32 - parts); - } - - fprintf(stderr, "// %s, %08x to %08x\n", name, x, stop); - - for (; x != stop; x++) { - if ((x & 0xffff) == 0) { - fprintf(stderr, "%08x,%u,%u,%u,%u\n", x, maxi, maxo, numbad, maxbad); - } - xf = *(float*)(void*)&x; - if (!ordinaryf(xf)) continue; - exact = f_im(xf); - if (!ordinaryf(exact)) continue; - approxi = f_if(xf); - approxo = f_of(xf); - ei = ulpf(approxi, exact); - eo = ulpf(approxo, exact); - if (maxi < ei) maxi = ei; - if (maxo < eo) maxo = eo; - if (eo > ei) { - numbad++; - if (maxbad < eo - ei) maxbad = eo - ei; - } - } - printf("%i,%u,%u,%u,%u\n", part, maxi, maxo, numbad, maxbad); -} diff --git a/infra/convergence.c b/infra/convergence.c deleted file mode 100644 index 20bdf2544..000000000 --- a/infra/convergence.c +++ /dev/null @@ -1,197 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include - -#ifndef NARGS -#define NARGS 1 -#endif - -#if NARGS == 1 -#define ARGS float -#elif NARGS == 2 -#define ARGS float, float -#elif NARGS == 3 -#define ARGS float, float, float -#elif NARGS == 4 -#define ARGS float, float, float, float -#elif NARGS == 5 -#define ARGS float, float, float, float, float -#elif NARGS == 6 -#define ARGS float, float, float, float, float, float -#else -#define ARGS -#endif - -void setup_mpfr_f_im(void); -void setup_mpfr_f_om(void); -double f_if(ARGS); -double f_id(ARGS); -double f_il(ARGS); -double f_of(ARGS); -double f_od(ARGS); -double f_ol(ARGS); -double f_im(ARGS); -double f_om(ARGS); - -unsigned long long ulp(double x, double y) { - if (x == 0) x = fabs(x); // -0 == 0 - if (y == 0) y = fabs(y); // -0 == 0 - - if (x != x && y != y) return 0; - if (x != x) return LLONG_MIN; - if (y != y) return LLONG_MIN; - - long long xx = *((unsigned long long*) &x); - xx = xx < 0 ? LLONG_MIN - xx : xx; - - long long yy = *((unsigned long long*)&y); - yy = yy < 0 ? LLONG_MIN - yy : yy; - - return xx >= yy ? xx - yy : yy - xx; -} - -float rand_float() { - unsigned int c0 = rand()&0xffff; - unsigned int c1 = rand()&0xffff; - unsigned int c = ((c1<<16) | c0); - return *(float*)&c; -} - -float *get_random(int nums) { - int i; - float *arr = malloc(sizeof(float) * nums * NARGS); - for (i = 0; i < nums * NARGS; i++) { - arr[i] = rand_float(); - } - return arr; -} - -#define SETUP() \ - clock_t start, end, zero; \ - int i, j, k; \ - double total, r1, r2, r1old; \ - float *rands, *out, *correct; \ - int count, mcount; \ - srand(time(NULL)); \ - setup_mpfr_f_im(); - -#define CALIBRATE(iter) \ - start = clock(); \ - for (i = 0; i < iter; i++) { \ - out[i] = 1 / rands[NARGS*i]; \ - } \ - end = clock(); \ - zero = end - start; - -#if NARGS == 1 -#define TEST(type, iter) \ - start = clock(); \ - for (i = 0; i < iter; i++) { \ - out[i] = f_##type (rands[i]); \ - } \ - end = clock(); - -#elif NARGS == 2 -#define TEST(type, iter) \ - start = clock(); \ - for (i = 0; i < iter; i++) { \ - out[i] = f_##type (rands[2*i], rands[2*i + 1]); \ - } \ - end = clock(); - -#elif NARGS == 3 -#define TEST(type, iter) \ - start = clock(); \ - for (i = 0; i < iter; i++) { \ - out[i] = f_##type (rands[3*i], rands[3*i + 1], rands[3*i + 2]); \ - } \ - end = clock(); - -#elif NARGS == 4 -#define TEST(type, iter) \ - start = clock(); \ - for (i = 0; i < iter; i++) { \ - out[i] = f_##type (rands[4*i], rands[4*i + 1], rands[4*i + 2], rands[4*i + 3]); \ - } \ - end = clock(); - -#elif NARGS == 5 -#define TEST(type, iter) \ - start = clock(); \ - for (i = 0; i < iter; i++) { \ - out[i] = f_##type (rands[5*i], rands[5*i + 1], rands[5*i + 2], \ - rands[5*i + 3], rands[5*i + 4]); \ - } \ - end = clock(); - -#elif NARGS == 6 -#define TEST(type, iter) \ - start = clock(); \ - for (i = 0; i < iter; i++) { \ - out[i] = f_##type (rands[6*i], rands[6*i + 1], rands[6*i + 2], \ - rands[6*i + 3], rands[6*i + 4], rands[6*i + 5]); \ - } \ - end = clock(); - -#else -#define TEST(type, iter) abort(); -#endif - -#define SAMPLE(iter) \ - rands = get_random(iter); \ - out = malloc(sizeof(float) * iter); - -#define SAVE(iter) \ - correct = malloc(sizeof(float) * iter); \ - memcpy((void *) correct, (void *) out, sizeof(float) * iter); \ - count = 0; \ - for (i = 0; i < iter; i++) { \ - if (1 / correct[i] != 0 && correct[i] == correct[i]) { \ - count += 1; \ - } /*else { printf("Bad point %g\n", correct[i]); }*/ \ - } - -int main(int argc, char** argv) { - SETUP(); - - int iter, repet; - iter = 1 << 15; - repet = 100; - if (argc > 1) iter = atoi(argv[1]); - if (argc > 2) repet = atoi(argv[2]); - - printf("pts,repet,avg,se\n"); - for (j = 2; j < iter; j *= 2) { - r1 = r2 = 0; - mcount = -1; - for (k = 0; k < repet; k++) { - SAMPLE(j); - TEST(im, j); - SAVE(j); - - TEST(if, j); - total = 0; - for (i = 0; i < j; i++) { - if (1 / correct[i] != 0 && correct[i] == correct[i]) { - unsigned long long int error = ulp(out[i], correct[i]); - total += log(error + 1.0) / log(2); - } - } - r1old = r1; - r1 += (total / count - r1) / (k + 1); - r2 += (total / count - r1old) * (total / count - r1); - if (mcount == -1 || count < mcount) mcount = count; - - free(rands); - free(out); - free(correct); - } - printf("%i,%i,%g,%g\n", mcount, repet, - r1, sqrt(r2 / (repet - 1.5)) / sqrt(repet)); - } -} diff --git a/infra/convert.rkt b/infra/convert.rkt deleted file mode 100644 index 1d3342938..000000000 --- a/infra/convert.rkt +++ /dev/null @@ -1,114 +0,0 @@ -#lang racket - -(require "../src/common.rkt") - -(provide convert) - -(define (args&body* args) - (match args - [(list (? keyword? name) value args* ...) - (define out* (args&body* args*)) - (cons (car out*) (cons (cons name value) (cdr out*)))] - [(list body args* ...) - (define out* (args&body* args*)) - (assert (not (car out*)) #:extra-info (λ () (format "Two body expressions ~a and ~a" (car out*) body))) - (cons body (cdr out*))] - [(list) - (cons #f '())])) - -(define (args&body args) - (define out* (args&body* args)) - (assert (car out*) #:extra-info (λ () "No body expression")) - out*) - -(define (var&dist expr) - (match expr - [(list var samp) (list var samp)] - [var (list var 'default)])) - -; parse old herbie syntax into FPCore -(define (convert expr) - (define-values (vars* args*) - (match expr - [(list 'herbie-test (list vars ...) (? string? name) input) - (values vars (list '#:name name input))] - [(list 'herbie-test (list vars ...) (? string? name) input output) - (values vars (list '#:name name '#:target output input))] - [(list 'herbie-test (list vars ...) input output) - (values vars (list '#:name "Unnamed Test" '#:target output input))] - [(list 'lambda (list vars ...) args ...) - (values vars args)] - [(list 'define name (list vars ...) args ...) - (values vars (list*'#:name name args))])) - (match-define (list body args ...) (args&body args*)) - (match-define (list (list vars samps) ...) (map var&dist vars*)) - - (define (translate-prop old-name new-name [transformer identity]) - (if (dict-has-key? args old-name) - (list new-name (transformer (dict-ref args old-name))) - (list))) - - (define (translate-samplers) - (define-values (samplers pre) - (reap [samplers pre] - (for ([var vars] [samp samps]) - (define samp* - (match samp - [(list (and (or '> '< '<= '>=) op) (? number? lb) samp) - (pre (list op lb var)) - samp] - [(list (and (or '> '< '<= '>=) op) samp (? number? ub)) - (pre (list op var ub)) - samp] - [(list (and (or '> '< '<= '>=) op) (? number? lb) samp (? number? ub)) - (pre (list op lb var)) - (pre (list op var ub)) - samp] - [_ samp])) - (unless (equal? samp* 'default) - (samplers (list var samp*)))))) - (append - (if (null? samplers) '() (list ':herbie-samplers samplers)) - (if (null? pre) '() (list ':pre (cons 'and pre))))) - - `(FPCore ,vars - ,@(translate-samplers) - ,@(translate-prop '#:name ':name) - ,@(translate-prop '#:expected ':herbie-expected) - ,@(translate-prop '#:target ':herbie-target (curryr search-replace vars)) - ,(search-replace body vars))) - -; we assume vars and vals are of the same length -(define (expand-let* vars vals body) - (if (and (null? vars) (null? vals)) - body - `(let ([,(car vars) ,(car vals)]) - ,(expand-let* (cdr vars) (cdr vals) body)))) - -(define (search-replace expr bound) - (match expr - [`(let* ([,vars ,vals] ...) ,body) - (define vals* - (let loop ([vars vars] [vals vals] [bound bound]) - (if (null? vars) - '() - (cons (search-replace (car vals) bound) - (loop (cdr vars) (cdr vals) (cons (car vars) bound)))))) - (expand-let* vars vals* (search-replace body (append vars bound)))] - [(list (and (or 'abs 'expt 'mod) f) elements ...) - (define replacements '((abs . fabs) (expt . pow) (mod . fmod))) - (cons (dict-ref replacements f) (map (curryr search-replace bound) elements))] - [(list elements ...) - (map (curryr search-replace bound) elements)] - [(or 'e 'pi) - (define replacements '((e . E) (pi . PI))) - (if (member expr bound) expr (dict-ref replacements expr))] - [_ expr])) - -(module+ main - (command-line - #:program "herbie-to-fpcore" - #:args (file) - (for ([test (in-port read (open-input-file file))]) - (pretty-print (convert test) (current-output-port) 1)))) - diff --git a/infra/index.css b/infra/index.css index 39565ab0e..5d74ce81f 100644 --- a/infra/index.css +++ b/infra/index.css @@ -14,19 +14,20 @@ a:hover {text-decoration: underline; color: #295785} figure { margin: 0; overflow: auto; } -#graph { float: left; } -#graph text { text-anchor: end; } -#graph .guide { stroke: rgb(60%, 60%, 60%); stroke-width: 1px; } -#graph .gridline { stroke: black; stroke-width: 3px; } -#graph .arrow {pointer-events: all; stroke-width: 7px; cursor: pointer;} -#graph:hover .arrow {stroke-opacity: .7; fill-opacity: 0.7;} -#graph:hover .arrow:hover { stroke-opacity: 1.0; fill-opacity: 1.0; } +svg { float: left; } +svg text { text-anchor: end; } +svg text.guide { fill: rgb(30%, 30%, 30%); } +svg line.guide { stroke: rgb(60%, 60%, 60%); stroke-width: 1px; } +svg .gridline { stroke: black; stroke-width: 3px; } +svg .arrow {pointer-events: all; stroke-width: 7px; cursor: pointer;} +svg:hover .arrow {stroke-opacity: .7; fill-opacity: 0.7;} +svg:hover .arrow:hover { stroke-opacity: 1.0; fill-opacity: 1.0; } figure ul { margin: 0; padding: 0; list-style-type: none; list-style-position: inside; text-align: center; } figure li { padding: .5ex; display: inline-block; margin: .1em; } figure li:hover { background: #e4e4e4; } figure li.selected { background: #d3d3d3; } figure a { color: black; text-decoration: none; display: block; } -#graph .no-data { text-anchor: middle; font-size: 18px; fill: rgb(60%, 60%, 60%)} +svg .no-data { text-anchor: middle; font-size: 18px; fill: rgb(60%, 60%, 60%)} #toc { clear: both; @@ -43,8 +44,8 @@ figure a { color: black; text-decoration: none; display: block; } #reports tr.crash { color: red; } #reports td { text-align: right; padding: .5em; overflow: hidden; font-size: 15pt; } #reports tbody tr:hover {background-color: #e0f8d8; cursor: pointer;} -#reports td:nth-child(2), #reports th:nth-child(2) { text-align: center; display: none; } -#reports td:nth-child(3) { text-align: center; } +#reports td:nth-child(3), #reports th:nth-child(2) { text-align: center; display: none; } +#reports td:nth-child(4) { text-align: center; } #reports thead { border-bottom: 1px solid black; height: 5em; vertical-align: bottom; } #reports a { position: absolute; left: 0; right: 0; z-index: 100; diff --git a/infra/make-index.rkt b/infra/make-index.rkt index 46a405588..95540cd1e 100644 --- a/infra/make-index.rkt +++ b/infra/make-index.rkt @@ -1,15 +1,12 @@ #lang racket + (require racket/runtime-path) (require (only-in xml write-xexpr) json) -(define-runtime-path report-json-path "../previous/") - - -(require racket/date) -(require "../src/common.rkt") -(require "../src/formats/datafile.rkt") - +(require racket/date "../src/common.rkt" "../src/formats/datafile.rkt") (provide directory-jsons name->timestamp) +(define-runtime-path report-json-path "../previous/") + (define (name->timestamp path) (define rpath (find-relative-path (simple-form-path report-json-path) path)) (define folder (path-element->string (first (explode-path rpath)))) @@ -52,7 +49,8 @@ (or/c string? false) '(note) exact-nonnegative-integer? '(date-unix tests-passed tests-available tests-crashed) (listof string?) '(options) - (and/c real? (curryr >= 0)) '(bits-improved bits-available))) + (and/c real? (curryr >= 0)) '(bits-available) + real? '(bits-improved))) (define cache-row? (apply and/c hash? @@ -82,9 +80,12 @@ (define total-crashed (count (compose (curry equal? "crash") table-row-status) (or tests '()))) + (define speed (apply + (map table-row-time (or tests '())))) + (hash 'date-full (format "~a:~a on ~a" (date-hour date) (~r (date-minute date) #:min-width 2 #:pad-string "0") (date->string date)) 'date-short (date->string/short date) 'date-unix (date->seconds date) + 'speed speed 'folder (path->string folder) 'hostname hostname 'commit commit @@ -108,7 +109,7 @@ (define (print-rows infos #:name name) `((thead ((id ,(format "reports-~a" name)) (data-branch ,name)) - (th "Date") (th "Branch") (th "Collection") (th "Tests") (th "Bits")) + (th "Date") (th "Speed") (th "Branch") (th "Collection") (th "Tests") (th "Bits")) (tbody ,@(for/list ([info infos]) (define field (curry dict-ref info)) @@ -118,6 +119,7 @@ ;; but Racket doesn't make that easy. (td ([title ,(field 'date-full)]) (time ([data-unix ,(~a (field 'date-unix))]) ,(field 'date-short))) + (td (time ([data-ms ,(~a (field 'speed))]) ,(format-time (field 'speed)))) (td ([title ,(field 'commit)]) ,(field 'branch)) (td ([title ,(string-join (field 'options) " ")] [class ,(if (field 'note) "note" "")]) @@ -125,7 +127,7 @@ (td ,(if (> (field 'tests-available) 0) (format "~a/~a" (field 'tests-passed) (field 'tests-available)) "")) (td ,(if (field 'bits-improved) (format "~a/~a" (round* (field 'bits-improved)) (round* (field 'bits-available))) "")) (td ([title ,(format "At ~a\nOn ~a\nFlags ~a" (field 'date-full) (field 'hostname) (string-join (field 'options) " "))]) - (a ([href ,(format "./~a/report.html" (field 'folder))]) "»"))))))) + (a ([href ,(format "./~a/results.html" (field 'folder))]) "»"))))))) (define (make-index-page) (when (file-exists? (build-path report-json-path "index.cache")) @@ -136,7 +138,9 @@ (define dirs (directory-jsons report-json-path)) (define folders - (map read-row (sort (filter name->timestamp dirs) > #:key name->timestamp))) + (filter + (λ (x) (< (- (current-seconds) (dict-ref x 'date-unix)) (* 60 60 24 30))) + (map read-row (sort (filter name->timestamp dirs) > #:key name->timestamp)))) (define branch-infos* (sort @@ -147,10 +151,14 @@ (partition (λ (x) (set-member? '("master" "develop") (dict-ref (first x) 'branch))) branch-infos*)) + (define crashes + (filter (λ (x) (> (dict-ref x 'tests-crashed) 0)) (apply append mainline-infos))) (define last-crash - (argmax (curryr dict-ref 'date-unix) (apply append mainline-infos))) + (if (null? crashes) + #f + (argmax (curryr dict-ref 'date-unix) crashes))) (define since-last-crash - (/ (- (date->seconds (current-date)) (dict-ref last-crash 'date-unix)) (* 60 60 24))) + (and last-crash (/ (- (date->seconds (current-date)) (dict-ref last-crash 'date-unix)) (* 60 60 24)))) (write-file "index.html" (printf "\n") @@ -164,22 +172,24 @@ (script ((src "regression-chart.js"))) (script ((src "report.js")))) (body - ((onload "index()")) (div ((id "large")) (div "Reports: " (span ((class "number")) ,(~a (length folders)))) (div "Mainline: " (span ((class "number")) ,(~a (length (apply append mainline-infos))))) (div "Branches: " (span ((class "number")) ,(~a (length branch-infos*)))) - (div "Crash-free: " (span ((class "number")) ,(~a (inexact->exact (round since-last-crash))) "d"))) + (div "Crash-free: " (span ((class "number")) ,(if since-last-crash + (format "~ad" (inexact->exact (round since-last-crash))) + "∞")))) (ul ((id "toc")) ,@(for/list ([rows (append mainline-infos other-infos)]) (define branch (dict-ref (first rows) 'branch)) `(li (a ((href ,(format "#reports-~a" branch))) ,branch)))) (figure (ul ((id "classes"))) - (svg ((id "graph") (width "800"))) + (svg ((id "accuracy-graph") (width "400"))) + (svg ((id "speed-graph") (width "400"))) (ul ((id "suites"))) - (script "window.addEventListener('load', function(){draw_results(d3.select('#graph'))})")) + (script "window.addEventListener('load', function(){draw_results(d3.select('#accuracy-graph'), d3.select('#speed-graph'))})")) (table ((id "reports")) ,@(apply diff --git a/infra/makejson.py b/infra/makejson.py deleted file mode 100644 index d1a0a6460..000000000 --- a/infra/makejson.py +++ /dev/null @@ -1,39 +0,0 @@ -#!/bin/python - -import sys - -if len(sys.argv) < 2: - print("USAGE: makejson.py [prefix]") - sys.exit() -else: - PREFIX = sys.argv[1] - -import csv - -def rows(file): - with open(file) as csvfile: - return list(csv.reader(csvfile)) - -with open(PREFIX + ".names.csv") as namefile: - NAMES = [line[3:-1] for line in namefile] - -def read(base, type, col): - IDROWS = rows("{}.i{}.csv".format(base, type)) - IDERRS = [float(row[col]) for row in IDROWS] - - ODROWS = rows("{}.o{}.csv".format(base, type)) - ODERRS = [float(row[col]) for row in ODROWS] - return zip(IDERRS, ODERRS) - -import json - -with open(PREFIX + ".json", "w") as jsonfile: - DOUBLEAVG = read(PREFIX, "d", 3) - DOUBLEMAX = read(PREFIX, "d", 2) - SINGLEAVG = read(PREFIX, "f", 3) - SINGLEMAX = read(PREFIX, "f", 2) - - json.dump( - [ { "name": name, "doubleAvg": da, "doubleMax": dm, "singleAvg": sa, "singleMax": sm } - for name, da, dm, sa, sm - in zip(NAMES, DOUBLEAVG, DOUBLEMAX, SINGLEAVG, SINGLEMAX)], jsonfile) diff --git a/infra/max-error-hour.c b/infra/max-error-hour.c deleted file mode 100644 index 839c161fc..000000000 --- a/infra/max-error-hour.c +++ /dev/null @@ -1,181 +0,0 @@ -#define _POSIX_C_SOURCE 199309L -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#ifndef NARGS -#define NARGS 1 -#endif - - -#if NARGS == 1 -#define ARGS(t) t -#define INVOKE(f,args) f(args[0]) -#define RANDARGS(argsName) argsName[0] = rand_double() -#elif NARGS == 2 -#define ARGS(t) t, t -#define INVOKE(f,args) f(args[0], args[1]) -#define RANDARGS(argsName) \ - argsName[0] = rand_double();\ - argsName[1] = rand_double() -#elif NARGS == 3 -#define ARGS(t) t, t, t -#define INVOKE(f,args) f(args[0], args[1], args[2]) -#define RANDARGS(argsName) \ - argsName[0] = rand_double();\ - argsName[1] = rand_double();\ - argsName[2] = rand_double() -#elif NARGS == 4 -#define ARGS(t) t, t, t, t -#define INVOKE(f,args) f(args[0], args[1], args[2], args[3]) -#define RANDARGS(argsName) \ - argsName[0] = rand_double();\ - argsName[1] = rand_double();\ - argsName[2] = rand_double();\ - argsName[3] = rand_double() -#elif NARGS == 5 -#define ARGS(t) t, t, t, t, t -#define INVOKE(f,args) f(args[0], args[1], args[2], args[3], args[4]) -#define RANDARGS() \ - argsName[0] = rand_double();\ - argsName[1] = rand_double();\ - argsName[2] = rand_double();\ - argsName[3] = rand_double();\ - argsName[4] = rand_double() -#elif NARGS == 6 -#define ARGS(t) t, t, t, t, t, t -#define INVOKE(f,args) f(args[0], args[1], args[2], args[3], args[4], args[5]) -#define RANDARGS() \ - argsName[0] = rand_double();\ - argsName[1] = rand_double();\ - argsName[2] = rand_double();\ - argsName[3] = rand_double();\ - argsName[4] = rand_double();\ - argsName[5] = rand_double() -#else -#define ARGS(t) abort() -#define INVOKE(f,args) abort() -#define RANDARGS() abort() -#endif - -void setup_mpfr_f_im(void); -double f_id(ARGS(double)); -double f_im(ARGS(double)); -double f_od(ARGS(double)); -double f_om(ARGS(double)); -extern char *name; - -unsigned long long ulpd(double x, double y) { - if (x == 0) x = fabs(x); // -0 == 0 - if (y == 0) y = fabs(y); // -0 == 0 - - if (x != x && y != y) return 0; - if (x != x) return LLONG_MIN; // Maximum error - if (y != y) return LLONG_MIN; // Maximum error - - long long xx = *((long long*) &x); - xx = xx < 0 ? LLONG_MIN - xx : xx; - - long long yy = *((long long*) &y); - yy = yy < 0 ? LLONG_MIN - yy : yy; - - return xx >= yy ? xx - yy : yy - xx; -} -double rand_double() { - long long c0 = rand()&0xffff; - long long c1 = rand()&0xffff; - long long c2 = rand()&0xffff; - long long c3 = rand()&0xffff; - long long c = ((c3 << 48) | (c2 << 32) | (c1<<16) | c0); - return *(double*)&c; -} -char ordinaryd(double x) { - return 1 / x != 0 && x == x; -} -unsigned int maxOrigErr, maxImprErr, numUnimproved, maxUnimproved; -unsigned long long pointsTested; -void finish(){ - printf("%u,%u,%u,%u,%llu\n", maxOrigErr, maxImprErr, numUnimproved, maxUnimproved, pointsTested); - exit(0); -} - -int main(int argc, char** argv){ - struct timespec start, cur; - double args[NARGS]; - double exact, origApprox, improvedApprox; - bool ordinaryArgs; - int i; - unsigned int origErr, imprErr, unimprovement; - - time_t timeout = 10; - if (argc > 1){ - timeout = atoi(argv[1]); - } - - // Set up the initial time variables - clock_gettime(CLOCK_MONOTONIC, &start); - cur = start; - - // Set up mpfr - setup_mpfr_f_im(); - - // Handle interrupts properly. - struct sigaction sigIntHandler; - sigIntHandler.sa_handler = finish; - sigemptyset(&sigIntHandler.sa_mask); - sigIntHandler.sa_flags = 0; - sigaction(SIGINT, &sigIntHandler, NULL); - - // While the allotted time hasn't passed - while(cur.tv_sec - start.tv_sec < timeout){ - // Get some randome arguments - RANDARGS(args); - - // See if they're all normal floats - ordinaryArgs = true; - for(i = 0; i < NARGS; ++i){ - if (!ordinaryd(args[i])){ - ordinaryArgs = false; - break; - } - } - // If not, skip them. - if(!ordinaryArgs) - continue; - - // Get the exact result from those args - exact = INVOKE(f_im, args); - - // If that isn't exact, skip it. - if(!ordinaryd(exact)) - continue; - - // Get the approxmiate answers with the input and output programs - origApprox = INVOKE(f_id, args); - improvedApprox = INVOKE(f_od, args); - - // Get the errors for both. - origErr = ulpd(origApprox, exact); - imprErr = ulpd(improvedApprox, exact); - - // Update the maxes - if (maxOrigErr < origErr) maxOrigErr = origErr; - if (maxImprErr < imprErr) maxImprErr = imprErr; - - // Update unimprovement numbers - if (origErr < imprErr){ - numUnimproved++; - unimprovement = imprErr - origErr; - if (maxUnimproved < unimprovement) maxUnimproved = unimprovement; - } - clock_gettime(CLOCK_MONOTONIC, &cur); - ++pointsTested; - } - finish(); -} diff --git a/infra/nightly.sh b/infra/nightly.sh index 4eefd8302..7990e5212 100644 --- a/infra/nightly.sh +++ b/infra/nightly.sh @@ -6,26 +6,19 @@ function run { bench=$1; shift name=$1; shift + echo "Running $name test with flags $@" racket "src/herbie.rkt" report \ --note "$name" \ --profile \ + --debug \ --threads $CORES \ "$@" \ "$bench" "reports/$name" bash infra/publish.sh upload "reports/$name" } -function runEach { - for bench in bench/*; do - name=$(basename "$bench" .fpcore) - # add cases to skip large or misbehaving benchmarks - case $name in - haskell) ;; - random) ;; - *) run "$bench" "$name" "$@" ;; - esac - done -} - mkdir -p reports -runEach --seed $(date "+%Y%j") "$@" +for bench in bench/*; do + name=$(basename "$bench" .fpcore) + run "$bench" "$name" --seed $(date "+%Y%j") "$@" +done diff --git a/infra/overhead.c b/infra/overhead.c deleted file mode 100644 index 8721a1657..000000000 --- a/infra/overhead.c +++ /dev/null @@ -1,277 +0,0 @@ -#define _POSIX_C_SOURCE 199309L -#include -#include -#include -#include -#include -#include -#include -#include - -#ifdef __MACH__ -#include -#include -#endif - -#define ITERS 1000000 - -#ifndef NARGS -#define NARGS 1 -#endif - -#if NARGS == 1 -#define ARGMAP(f, ...) f(0, __VA_ARGS__) -#elif NARGS == 2 -#define ARGMAP(f, ...) f(0, __VA_ARGS__), f(1, __VA_ARGS__) -#elif NARGS == 3 -#define ARGMAP(f, ...) f(0, __VA_ARGS__), f(1, __VA_ARGS__), f(2, __VA_ARGS__) -#elif NARGS == 4 -#define ARGMAP(f, ...) f(0, __VA_ARGS__), f(1, __VA_ARGS__), f(2, __VA_ARGS__), f(3, __VA_ARGS__) -#elif NARGS == 5 -#define ARGMAP(f, ...) f(0, __VA_ARGS__), f(1, __VA_ARGS__), f(2, __VA_ARGS__), f(3, __VA_ARGS__), f(4, __VA_ARGS__) -#elif NARGS == 6 -#define ARGMAP(f, ...) f(0, __VA_ARGS__), f(1, __VA_ARGS__), f(2, __VA_ARGS__), f(3, __VA_ARGS__), f(4, __VA_ARGS__), f(5, __VA_ARGS__) -#else -#define ARGMAP(f, ...) abort() -#endif - -#define SND(a, b) b -#define ARGS(t) ARGMAP(SND, t) - -void setup_mpfr_f_im(void); -void setup_mpfr_f_fm(void); -void setup_mpfr_f_dm(void); -double f_if(ARGS(float)); -double f_id(ARGS(double)); -double f_im(ARGS(double)); -double f_of(ARGS(float)); -double f_od(ARGS(double)); -double f_om(ARGS(double)); -extern char *name; - -typedef unsigned long long int u64; -typedef unsigned int u32; -typedef signed long long int i64; -typedef signed int i32; - -u32 ulpf(float x, float y) { - i32 xx, yy; - - if (x == 0) x = fabsf(x); // -0 == 0 - if (y == 0) y = fabsf(y); // -0 == 0 - - if (x != x && y != y) return 0; - if (x != x) return INT_MIN; // Maximum error - if (y != y) return INT_MIN; // Maximum error - - memcpy(&xx, &x, sizeof(float)); - memcpy(&yy, &y, sizeof(float)); - - xx = xx > INT_MAX ? INT_MIN - xx : xx; - yy = yy > INT_MAX ? INT_MIN - yy : yy; - - return xx >= yy ? xx - yy : yy - xx; -} - -u64 ulpd(double x, double y) { - i64 xx, yy; - - if (x == 0) x = fabs(x); // -0 == 0 - if (y == 0) y = fabs(y); // -0 == 0 - - if (x != x && y != y) return 0; - if (x != x) return LLONG_MIN; // Maximum error - if (y != y) return LLONG_MIN; // Maximum error - - memcpy(&xx, &x, sizeof(double)); - memcpy(&yy, &y, sizeof(double)); - - xx = xx < 0 ? LLONG_MIN - xx : xx; - yy = yy < 0 ? LLONG_MIN - yy : yy; - - return xx >= yy ? xx - yy : yy - xx; -} - -char ordinaryf(float x) { - return 1 / x != 0 && x == x; -} - -char ordinaryd(double x) { - return 1 / x != 0 && x == x; -} - -#define ulpl ulpd -#define ulpm ulpd - -double rand_double() { - u64 c0 = rand()&0xffff; - u64 c1 = rand()&0xffff; - u64 c2 = rand()&0xffff; - u64 c3 = rand()&0xffff; - u64 c = ((c3 << 48) | (c2 << 32) | (c1<<16) | c0); - - double cc; - memcpy(&cc, &c, sizeof(double)); - return cc; -} - -float rand_float() { - u32 c0 = rand()&0xffff; - u32 c1 = rand()&0xffff; - u32 c = ((c1<<16) | c0); - - double cc; - memcpy(&cc, &c, sizeof(double)); - return cc; -} - -float *get_random_floats(int nums) { - int i; - float *arr = malloc(sizeof(float) * nums * NARGS); - for (i = 0; i < nums * NARGS; i++) { - float rand; - do { - rand = rand_float(); - } while (!ordinaryf(rand)); - arr[i] = rand; - } - return arr; -} - -double *get_random_doubles(int nums) { - int i; - double *arr = malloc(sizeof(double) * nums * NARGS); - for (i = 0; i < nums * NARGS; i++) { - double rand; - do { - rand = rand_double(); - } while (!ordinaryd(rand)); - arr[i] = rand; - } - return arr; -} - -#ifdef __MACH__ // OS X does not have clock_gettime, use clock_get_time - -#define CLOCK(ts) \ - clock_get_time(cclock, &mts); \ - ts.tv_sec = mts.tv_sec; \ - ts.tv_nsec = mts.tv_nsec; - -#else - -#define CLOCK(ts) \ - clock_gettime(CLOCK_REALTIME, &ts); - -#endif - -/* Some macros to make looping a bit easier */ - -#define LOOP(iter) \ - CLOCK(start); \ - for (i = 0; i < iter; i++) - -#define END() \ - CLOCK(end); \ - rtime = (end.tv_sec - start.tv_sec) * 1.0e9 + (end.tv_nsec - start.tv_nsec); - -/* Calling a function with some number of arguments */ -#define EVALAUX(n, rands) rands[NARGS*i] + n -#define EVAL(rands, f) f(ARGMAP(EVALAUX, rands)) - -#define CHECK(io, type, iter) \ - max = total = 0; \ - for (i = 0; i < iter; i++) { \ - if (ordinary##type(true##type[i])) { \ - u64 error = ulp##type(out##io##type[i], true##type[i]); \ - if (error > max) max = error; \ - total += log(error + 1.0) / log(2); \ - } \ - } \ - printf("%s%s,%15g,%15g,%15g\n", #io, #type, rtime, \ - log(max + 1.0) / log(2), total / count##type); - -int main(int argc, char** argv) { - -#ifdef __MACH__ - clock_serv_t cclock; - mach_timespec_t mts; - host_get_clock_service(mach_host_self(), SYSTEM_CLOCK, &cclock); -#endif - - struct timespec start, end; - int i; - u64 max = 0, maxcount = 0; - double rtime, total = 0; - int countf = 0, countd = 0; - double *ind, *outid, *outod, *trued; - float *inf, *outif, *outof, *truef; - setup_mpfr_f_im(); - - int iter = ITERS; - if (argc > 1) iter = atoi(argv[1]); - - inf = get_random_floats(NARGS * iter); - ind = get_random_doubles(NARGS * iter); - outif = malloc(sizeof(float) * iter); - outid = malloc(sizeof(double) * iter); - outof = malloc(sizeof(float) * iter); - outod = malloc(sizeof(double) * iter); - truef = malloc(sizeof(float) * iter); - trued = malloc(sizeof(double) * iter); - - LOOP(iter) { truef[i] = (float) EVAL(inf, f_im); } END(); - LOOP(iter) { trued[i] = EVAL(ind, f_im); } END(); - - LOOP(iter) { countf += (int) ordinaryf(truef[i]); } END(); - LOOP(iter) { countd += (int) ordinaryd(trued[i]); } END(); - - printf("%s\n", name); - printf("pf,%11d\n", countf); - printf("pd,%11d\n", countd); - printf("test, time, max, avg\n"); - - LOOP(iter) { outif[i] = EVAL(inf, f_if); } END(); - CHECK(i, f, iter); - - LOOP(iter) { outid[i] = EVAL(ind, f_id); } END(); - CHECK(i, d, iter); - - LOOP(iter) { outof[i] = EVAL(inf, f_of); } END(); - CHECK(o, f, iter); - - LOOP(iter) { outod[i] = EVAL(ind, f_od); } END(); - CHECK(o, d, iter); - - max = maxcount = 0; - for (i = 0; i < iter; i++) { - if (ordinaryd(trued[i])) { - u32 ierror = ulpf(outif[i], truef[i]); - u32 oerror = ulpf(outof[i], truef[i]); - if (ierror < oerror) { - maxcount++; - if (max < oerror - ierror) max = oerror - ierror; - } - } - } - printf("df,%15g,%15llu\n", log(max + 1.0) / log(2), maxcount); - - max = maxcount = 0; - for (i = 0; i < iter; i++) { - if (ordinaryd(trued[i])) { - u64 ierror = ulpd(outid[i], trued[i]); - u64 oerror = ulpd(outod[i], trued[i]); - if (ierror < oerror) { - maxcount++; - if (max < oerror - ierror) max = oerror - ierror; - } - } - } - printf("dd,%15g,%15llu\n", log(max + 1.0) / log(2), maxcount); - -#ifdef __MACH__ - mach_port_deallocate(mach_task_self(), cclock); -#endif - - return 0; -} diff --git a/infra/overhead.mk b/infra/overhead.mk deleted file mode 100644 index 59ffb8d53..000000000 --- a/infra/overhead.mk +++ /dev/null @@ -1,67 +0,0 @@ -# Find all compiled test-cases -# If Herbie times out or crashes, no compiled.c is generated. -TESTCASES = $(sort $(dir $(wildcard */compiled.c))) - -# Flags for building and running C files -GCC_FLAGS = -std=c11 -Wall -Wextra -Wpedantic -Werror -SLOW_FLAGS = $(GCC_FLAGS) -O0 -g -FAST_FLAGS = $(GCC_FLAGS) -march=native -mtune=native -O3 -flto -UNSAFE_FLAGS = $(GCC_FLAGS) -march=native -mtune=native -Ofast -flto - -%/slow.o: %/compiled.c - gcc $(SLOW_FLAGS) -c $< -o $@ - -%/fast.o: %/compiled.c - gcc $(FAST_FLAGS) -c $< -o $@ - -%/unsafe.o: %/compiled.c - gcc $(UNSAFE_FLAGS) -c $< -o $@ - -%/overhead: overhead.c %/fast.o - gcc $(FAST_FLAGS) $^ -o $@ \ - -lm -lmpfr -lgmp \ - -DNARGS=$(shell grep f_if $*/compiled.c | tr '()_ ,' '\n' | tail -n+2 | grep float -c) - -# How many samples to use for evaluation -POINTS = 100000 - -%/overhead.csv: %/overhead - ./$< $(POINTS) > $@ - -# The output CSV files contain a bunch of fields. -# These rules aggregate each one into its own file. - -names.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 1p > names.csv - -pf.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 2p > pf.csv - -pd.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 3p > pd.csv - -if.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 5p > if.csv - -id.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 6p > id.csv - -of.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 7p > of.csv - -od.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 8p > od.csv - -df.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 9p > df.csv - -dd.csv: $(patsubst %/,%/overhead.csv,$(TESTCASES)) - echo $^ | xargs -n1 sed -n 10p > dd.csv - -DATAFILES = $(patsubst %,%.csv,names pf pd if id of od df dd) - -# The top-level target is `overhead` to make the overhead numbers - -.PHONY: overhead - -overhead: $(DATAFILES) diff --git a/infra/publish.sh b/infra/publish.sh index f51215ff5..ff14ea89e 100755 --- a/infra/publish.sh +++ b/infra/publish.sh @@ -9,7 +9,7 @@ upload () { B=$(git rev-parse --abbrev-ref HEAD) C=$(git rev-parse HEAD | sed 's/\(..........\).*/\1/') RDIR="$(date +%s):$(hostname):$B:$C" - find "$DIR" -name "debug.txt" -exec gzip -f {} \; + find "$DIR" -name "profile.txt" -or -name "debug.txt" -exec gzip -f {} \; rsync --recursive "$DIR" --exclude reports/ "$RHOST:$RHOSTDIR/$RDIR" ssh "$RHOST" chmod a+rx "$RHOSTDIR/$RDIR" -R } @@ -23,10 +23,6 @@ index () { rm index.html } -backfill () { - racket infra/backfill-index.rkt -} - download_reports () { rsync --recursive --checksum --inplace --ignore-existing \ --include 'results.json' --include '*/' --exclude '*' \ @@ -60,9 +56,6 @@ if [[ $CMD = "upload" ]]; then elif [[ $CMD = "index" ]]; then download_reports index -elif [[ $CMD = "backfill" ]]; then - download_reports - backfill elif [[ $CMD = "update-reports" ]]; then upload_reports index diff --git a/infra/random-test.rkt b/infra/random-test.rkt new file mode 100644 index 000000000..2f8f9af96 --- /dev/null +++ b/infra/random-test.rkt @@ -0,0 +1,76 @@ +#lang racket +(require racket/random) +(require "../src/syntax/syntax.rkt" (submod "../src/syntax/syntax.rkt" internals)) +(require "../src/common.rkt" "../src/float.rkt") + +(define (parse-range N) + (if (string-contains? N "-") + (match-let ([(list min max) (string-split N "-")]) + (cons (string->number min) (string->number max))) + (cons (string->number N) (string->number N)))) + + +(define (generate-fpcore i size nvars) + (define name (format "Random test ~a" i)) + (define vars (take '(a b c d e f g h i j k l m n o p q r s t u v) nvars)) + (define expr (generate-expr vars size 'real)) + `(FPCore ,vars :name ,name ,expr)) + +(define (generate-expr vars fuel type) + (cond + [(<= fuel 1) + (define valid-consts + (for/list ([const (in-hash-keys (cdr constants))] + #:when (equal? (constant-info const 'type) type)) + const)) + (match type + ['real + (if (or (null? vars) (< (random) 0.2)) + (if (< (random) 0.1) + (random-ref valid-consts) + (sample-double)) + (random-ref vars))] + [else + (random-ref valid-consts)])] + [(and (<= fuel 3) (equal? type 'complex) (< (random) 0.9)) + ;; Force the "complex" call to create good constants + `(complex ,(generate-expr vars 1 'real) ,(generate-expr vars 1 'real))] + [else + (define valid-ops + (for/list ([(op _) (in-hash (cdr operators))] + #:when true + [argnum (operator-info op 'args)] + #:when (< (match argnum ['* 2] [n n]) fuel) + #:when (equal? (last (car (hash-ref (operator-info op 'type) argnum))) type)) + (define atypes + (match argnum + ['* + (define reptype (second (car (car (hash-ref (operator-info op 'type) '*))))) + (list reptype reptype)] + [n + (car (car (hash-ref (operator-info op 'type) n)))])) + (cons op atypes))) + (match-define (cons op atypes) (random-ref valid-ops)) + (define subfuels (random-ref (filter (λ (x) (= (length x) (length atypes))) + (all-partitions (- fuel 1))))) + `(,op ,@(map (curry generate-expr vars) subfuels atypes))])) + +(module+ main + (define size (cons 1 1)) + (define vars (cons 1 1)) + (define tests 1) + + (command-line + #:once-each + [("--size") N "Size of expressions to generate (default 1)" + (set! size (parse-range N))] + [("--vars") N "Number of variables in generated expressions (default 1)" + (set! vars (parse-range N))] + [("--tests") N "Number of tests to generate (default 1)" + (set! tests (string->number N))] + #:args () + (for ([i (in-range tests)]) + (define s (random (car size) (+ 1 (cdr size)))) + (define v (random (car vars) (+ 1 (cdr vars)))) + (pretty-print (generate-fpcore i s v) (current-output-port) 1) + (newline)))) diff --git a/infra/regression-chart.js b/infra/regression-chart.js index d4aa1bed8..d75006c95 100644 --- a/infra/regression-chart.js +++ b/infra/regression-chart.js @@ -1,8 +1,9 @@ -margin = 10; -width = 740; +vmargin = 10; +hmargin = 5; +width = 340; height = 200; -labels = 40; +labels = 50; precision = 64; precision_step = 8; @@ -11,9 +12,9 @@ used_branch = {}; used_tag = {}; function get_point(tr) { - var tests = tr.children[3].textContent.split("/"); - var bits = tr.children[4].textContent.split("/"); - var flags = tr.children[2].getAttribute("title"); + var tests = tr.children[4].textContent.split("/"); + var bits = tr.children[5].textContent.split("/"); + var flags = tr.children[3].getAttribute("title"); flags = flags !== "" ? flags.split(" ") : []; var note = tr.getElementsByClassName("note")[0]; @@ -23,8 +24,9 @@ function get_point(tr) { tag: trtag, tests: { got: +tests[0], total: +tests[1]}, bits: { got: +bits[0], total: +bits[1] }, - branch: tr.children[1].textContent, + branch: tr.children[2].textContent, time: +tr.children[0].children[0].getAttribute("data-unix"), + speed: +tr.children[1].children[0].getAttribute("data-ms") / 1000 / 60, elt: tr, flags: flags, }; @@ -40,56 +42,75 @@ function get_data(table) { return data; } +function print_date(d) { + var date = "" + new Date(d * 1000); + return date.split(" ").slice(1, 4).join(" "); +} + function step_size(max) { - if (max > 400) { - return Math.round(max / 400) * 100; - } else if (max > 40) { - return Math.round(max / 40) * 10; - } else if (max > 4) { - return Math.round(max / 4); - } else if (max > .4) { - return Math.round(max / .4) / 10; - } else { - throw "Data points error"; - } + var step = Math.pow(10, Math.floor(Math.log10(max / 4))) + if (max / step > 20) return step * 5; + if (max / step > 8) return step * 2; + return step; } -function make_graph(node, data, type) { - if (!data.length) { - console.log("hi!!", data.length); - node.append("text") - .attr("x", width / 2) - .attr("y", height / 2 + 9) - .attr("class", "no-data").text("No tests found with these parameters."); - return; - } +function make_accuracy_graph(node, data, type) { + if (!data.length) return no_data(node); - var len = data.length; - var spacing = width / len; + var spacing = width / data.length; - var max = 0; - for (var i = 0; i < len; i++) { - if (data[i][type].total > max) max = data[i][type].total; - } + var max = Math.max.apply(null, data.map(function(x) { return x[type].total })) var step = step_size(max); var steps = max ? Math.ceil(max / step) : 0; var max = steps * step; - var svg = node - .attr("width", width + 2 * margin + labels) - .attr("height", height + 2 * margin) - .append("g").attr("transform", "translate(" + (margin + labels) + "," + margin + ")"); + var svg = initialize_svg(node); + add_axes(svg); + add_gridlines(svg, step, steps, "b"); + + var g = mk_datum(svg, data); + + g.append("line") + .attr("stroke", function(d) { return key(d.branch) }) + .attr("x1", function(d, i) { return (i + .5) * spacing }) + .attr("x2", function(d, i) { return (i + .5) * spacing }) + .attr("y1", function(d) { return height - height * d[type].total / max }) + .attr("y2", function(d) { return height - height * (d[type].total - d[type].got) / max - 5 }); + g.append("polygon").attr("points", "-3.5,-6,3.5,-6,0,0") + .attr("fill", function(d) { return key(d.branch) }) + .attr("transform", function(d, i) { + return "translate(" + spacing*(i + .5) + ", " + (height - height * (d[type].total - d[type].got) / max) + ")"; + }); +} + +function no_data(node) { + node.append("text") + .attr("x", width / 2) + .attr("y", height / 2 + 9) + .attr("class", "no-data").text("No tests found with these parameters."); +} + +function initialize_svg(node) { + return node + .attr("width", width + 2 * hmargin + labels) + .attr("height", height + 2 * vmargin) + .append("g").attr("transform", "translate(" + (hmargin + labels) + "," + vmargin + ")"); +} + +function add_axes(svg) { svg.append("line") .attr("class", "gridline") .attr("x1", 0) - .attr("x2", width) + .attr("x2", width-5) .attr("y1", height) .attr("y2", height); svg.append("polygon").attr("class", "gridline").attr("points", "0,3,0,-3,5,0") - .attr("transform", "translate(" + width + "," + height + ")"); + .attr("transform", "translate(" + (width - 5) + "," + height + ")"); +} +function add_gridlines(svg, step, steps, unit) { for (var i = 1; i <= steps; i++) { svg.append("line") .attr("class", "guide") @@ -98,34 +119,53 @@ function make_graph(node, data, type) { .attr("y1", height - (i / steps) * height) .attr("y2", height - (i / steps) * height); - svg.append("text").text(i * step).attr("class", "guide") + svg.append("text").text((step > 1 ? i * step : i / (1 / step)) + (unit ? unit : "")) + .attr("class", "guide") .attr("x", -5) .attr("y", height - (i / steps) * height + 6); } +} +function mk_datum(svg, data) { var bar = svg.selectAll("g").data(data).enter(); - var g = bar.append("g").attr("class", "arrow"); + var g = bar.append("a") + .attr("xlink:href", function(d) { + return d.elt.querySelector("a").href; + }).append("g").attr("class", "arrow"); g.append("title") - .text(function(d) { return "At " + new Date(d.time * 1000) + "\nOn " + d.branch }); + .text(function(d) { + return print_date(d.time) + + "\nOn " + d.branch + + "\nTook " + Math.round(d.speed * 10) / 10 + "m"; + }); + + return g; +} - g.append("line") - .attr("stroke", function(d) { return key(d.branch) }) - .attr("x1", function(d, i) { return (i + .5) * spacing }) - .attr("x2", function(d, i) { return (i + .5) * spacing }) - .attr("y1", function(d) { return height - height * d[type].total / max }) - .attr("y2", function(d) { return height - height * (d[type].total - d[type].got) / max - 5 }); +function make_speed_graph(node, data) { + if (!data.length) return no_data(node); - g.append("polygon").attr("points", "-3.5,-6,3.5,-6,0,0") - .attr("fill", function(d) { return key(d.branch) }) - .attr("transform", function(d, i) { - return "translate(" + spacing*(i + .5) + ", " + (height - height * (d[type].total - d[type].got) / max) + ")"; - }); + var spacing = width / data.length; - g.on("click", function(d) { - d.elt.querySelector("a").click(); - }); + var max = Math.max.apply(null, data.map(function(x) { return x.speed })); + var step = step_size(max); + var steps = max ? Math.ceil(max / step) : 0; + var max = steps * step; + + var svg = initialize_svg(node); + add_axes(svg); + add_gridlines(svg, step, steps, "m"); + + var g = mk_datum(svg, data); + + g.append("circle") + .attr("fill", function(d) { return key(d.branch) }) + .attr("cx", function(d, i) { return (i + .5) * spacing }) + .attr("cy", function(d) { return height - height * d.speed / max }) + .attr("r", spacing * .75 / 2); + } function select_data(data, options, tag) { @@ -138,8 +178,9 @@ function select_data(data, options, tag) { }); } -function render(node, data, options, tag) { - node.selectAll("*").remove(); +function render(node1, node2, data, options, tag) { + node1.selectAll("*").remove(); + node2.selectAll("*").remove(); // Update classes var olds = Array.prototype.slice.call(document.getElementsByClassName("selected")); olds.forEach(function(old) { old.classList.remove("selected") }) @@ -147,26 +188,29 @@ function render(node, data, options, tag) { for (var flag in options) { if (options[flag]) document.getElementById("flag-" + flag).classList.add("selected"); } - make_graph(node, select_data(data, options, tag), "bits"); + var data = select_data(data, options, tag); + make_accuracy_graph(node1, data, "bits"); + make_speed_graph(node2, data); } -function draw_results(node) { +function draw_results(node1, node2) { DATA = get_data(document.getElementById("reports")); OPTIONS = {"rules:numerics": false}; TAG = null; - NODE = node; + NODE1 = node1; + NODE2 = node2; function toggle_tag(tag) { return function(evt) { TAG = tag; - render(NODE, DATA, OPTIONS, TAG); + render(NODE1, NODE2, DATA, OPTIONS, TAG); } } function toggle_flag(flag) { return function(evt) { OPTIONS[flag] = !OPTIONS[flag]; - render(NODE, DATA, OPTIONS, TAG); + render(NODE1, NODE2, DATA, OPTIONS, TAG); } } @@ -207,7 +251,7 @@ function draw_results(node) { } key = d3.scale.category20().domain(branches); - render(NODE, DATA, OPTIONS, TAG); + render(NODE1, NODE2, DATA, OPTIONS, TAG); var branches = []; var toclinks = document.getElementById("toc").querySelectorAll("li a"); diff --git a/infra/run.sh b/infra/run.sh deleted file mode 100755 index 6f20e6220..000000000 --- a/infra/run.sh +++ /dev/null @@ -1,149 +0,0 @@ -#!/usr/bin/env bash - -# This is where herbie lives on warfa for nightlies. -# You may change HERBROOT to test locally, -# but do not push any changes to HERBROOT! -HERBROOT="$HOME/herbie" - -# example crontab entry for nightlies -# 30 2 * * * $HOME/herbie/infra/run.sh - -CORES=4 - -LOG="$HERBROOT/infra/$(date +%y%m%d%H%M%S).log" -ln -sf "$LOG" "$HERBROOT/infra/latest.log" - -EXC="$HERBROOT/infra/exceptions-$(date +%y%m%d%H%M%S).rkt" -ln -sf "$EXC" "$HERBROOT/infra/latest-exceptions.rkt" - -function main { - cd "$HERBROOT" - git pull --quiet - - COMMIT="$HERBROOT/infra/latest-commit.txt" - C=$(git rev-parse HEAD | sed 's/\(..........\).*/\1/') - if [ -f "$COMMIT" -a "$C" = "$(cat "$COMMIT")" ]; then - echo "No new commits, exiting." - exit 0 - else - echo "$C" > "$COMMIT" - echo "Latest commit updated to $C." - fi - -## make --quiet --directory="$HERBROOT/randTest" -## java -classpath "$HERBROOT/randTest/" RandomTest \ -## --size 5 --size-wiggle 5 \ -## --nvars 1 --nvars-wiggle 3 \ -## --ntests 20 \ -## > "$HERBROOT/bench/random.fpcore" - - # choose configs based on day of year - d=$(date "+%j") - - # use common seed across every 4 day cycle - qseed=$(racket -e " \ - (random-seed $(expr $d / 4)) \ - (pseudo-random-generator->vector \ - (current-pseudo-random-generator))") - seed="${qseed:1}" # :1 removes leading quote - -## # toggle fuel every two days -## if [ $(expr \( $d / 2 \) % 2) -eq 0 ]; then -## fuel="--fuel 2" -## else -## fuel="--fuel 3" -## fi - -## # toggle regimes every other day -## if [ $(expr $d % 2) -eq 0 ]; then -## regime="" -## else -## regime="--disable reduce:regimes" -## fi - -## # toggle some configs every day -## for prec in "" "--disable precision:double"; do -## for postproc in "" "--enable reduce:post-process"; do -## for num in "" "--enable rules:numerics"; do -## runEach --seed "$seed" $fuel $regime $prec $postproc $num -## done -## done -## done - - runEach --seed "$seed" -} - -function run { - bench=$1; shift - name=$1; shift - - GRAPHS="$HERBROOT/infra/graphs-$(date +%y%m%d%H%M%S)" - mkdir -p "$GRAPHS" - - cat << EOF - -================================================================================ - $name -================================================================================ - -run $@ - -EOF - time xvfb-run --auto-servernum \ - racket "$HERBROOT/src/herbie.rkt" report \ - --note "$name" \ - --profile \ - --threads $CORES \ - "$@" \ - "$bench" "$GRAPHS" - cat << EOF >> "$EXC" - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; $name -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -EOF - cat "$GRAPHS/exceptions.rkt" >> "$EXC" - -## echo -## echo "Evaluating extracted C" -## time make \ -## --quiet --directory="$HERBROOT/graphs" \ -## --jobs=$CORES \ -## overhead -## echo - - echo - echo "Publishing to uwplse.org" - # NOTE: the trailing slash at the end of GRAPHS is required for rsync! - time "$HERBROOT/infra/publish.sh" upload "$GRAPHS/" - - echo - echo "Rebuilding reports index" - time "$HERBROOT/infra/publish.sh" index - - rm -rf "$GRAPHS" -} - -function runEach { - ##for bench in $HERBROOT/bench/hamming; do - for bench in $HERBROOT/bench/*; do - name=$(basename "$bench" .fpcore) - # add cases to skip large or misbehaving benchmarks - case $name in - haskell|random) - continue - ;; - esac - run "$bench" "$name" "$@" - done -} - -# on some machines, this will cause Racket VM to exhaust memory -function runAll { - bench="$HERBROOT/bench" - name="all" - run "$bench" "$name" "$@" -} - -main &> "$LOG" diff --git a/infra/travis.rkt b/infra/travis.rkt index 856b9d5b7..c6f80fa64 100644 --- a/infra/travis.rkt +++ b/infra/travis.rkt @@ -1,47 +1,55 @@ #lang racket -(require racket/date) -(require racket/cmdline) -(require "../src/common.rkt") -(require "../src/points.rkt") -(require "../src/alternative.rkt") -(require "../src/sandbox.rkt") -(require "../src/formats/test.rkt") -(require "../src/formats/datafile.rkt") +(require racket/date racket/cmdline) +(require "../src/common.rkt" "../src/points.rkt") +(require "../src/alternative.rkt" "../src/sandbox.rkt") +(require "../src/formats/test.rkt" "../src/formats/datafile.rkt") + +(define (test-successful? test input-bits target-bits output-bits) + (match* ((test-output test) (test-expected test)) + [(_ #f) #t] + [(_ (? number? n)) (>= n output-bits)] + [(#f #t) (>= input-bits output-bits)] + [(_ #t) (>= target-bits (- output-bits 1))])) (define (run-tests . bench-dirs) (define tests (append-map load-tests bench-dirs)) - (define seed (get-seed)) - (printf "Running Herbie on ~a tests (seed: ~a)...\n" (length tests) seed) - (for/and ([test tests]) + (define seed (pseudo-random-generator->vector (current-pseudo-random-generator))) + (printf "Running Herbie on ~a tests, seed: ~a\n" (length tests) seed) + (for/and ([test tests] [i (in-naturals)]) + (printf "~a/~a\t" (~a (+ 1 i) #:width 3 #:align 'right) (length tests)) (match (get-test-result test #:seed seed) - [(test-result test time prec input output pts exs - start-errors end-error newpts newexs - start-newerrors end-newerrors target-newerrors timeline) - (printf "[ ~ams]\t(~a→~a)\t~a\n" - (~a time #:width 8) - (~r (errors-score start-newerrors) #:min-width 2 #:precision 0) - (~r (errors-score end-newerrors) #:min-width 2 #:precision 0) + [(test-success test bits time timeline warnings + start-alt end-alt points exacts start-est-error end-est-error + newpoints newexacts start-error end-error target-error + baseline-error oracle-error all-alts) + (printf "[ ~as] ~a→~a\t~a\n" + (~r (/ time 1000) #:min-width 7 #:precision '(= 3)) + (~r (errors-score start-error) #:min-width 2 #:precision 0) + (~r (errors-score end-error) #:min-width 2 #:precision 0) (test-name test)) (define success? (test-successful? test - (errors-score start-newerrors) - (and target-newerrors (errors-score target-newerrors)) - (errors-score end-newerrors))) + (errors-score start-error) + (and target-error (errors-score target-error)) + (errors-score end-error))) (when (not success?) - (printf "Input: ~a\n" (alt-program input)) - (printf "Output:\n") - (pretty-print (alt-program output)) - (when (test-output test) (printf "Target: ~a\n" (test-output test)))) + (printf "\nInput (~a bits):\n" (errors-score start-error)) + (pretty-print (alt-program start-alt) (current-output-port) 1) + (printf "\nOutput (~a bits):\n" (errors-score end-error)) + (pretty-print (alt-program end-alt) (current-output-port) 1) + (when (test-output test) + (printf "\nTarget (~a bits):\n" (errors-score target-error)) + (pretty-print (test-output test) (current-output-port) 1))) success?] - [(test-failure test prec exn time timeline) - (printf "[ CRASH ]\t\t\t~a\n" (test-name test)) + [(test-failure test bits time timeline warnings exn) + (printf "[ CRASH ]\t\t~a\n" (test-name test)) ((error-display-handler) (exn-message exn) exn) #f] - [(test-timeout test prec time timeline) - (printf "[ timeout ]\t\t\t~a\n" (test-name test)) + [(test-timeout test bits time timeline warnings) + (printf "[ TIMEOUT]\t\t~a\n" (test-name test)) #f]))) (module+ main diff --git a/infra/travis_times.py b/infra/travis_times.py new file mode 100644 index 000000000..b3f791262 --- /dev/null +++ b/infra/travis_times.py @@ -0,0 +1,42 @@ +#!/bin/python3 + +import urllib.request +import json + +REPO="uwplse/herbie" + +def travis_req(after_number=None): + url = "http://api.travis-ci.org/repos/{}/builds".format(REPO) + if after_number: + url += "?after_number=" + after_number + req = urllib.request.Request(url) + req.add_header("Accept", "application/vnd.travis-ci.2.1+json") + resp = urllib.request.urlopen(req) + data = json.load(resp) + return data["builds"], data["commits"] + +def get_travis(): + commits = {} + last = None + while True: + data, coms = travis_req(after_number=last) + for x in coms: + commits[x["id"]] = x + for x in data: + last = x["number"] + if "commit_id" in x: + x["commit"] = commits[x["commit_id"]] + yield x + +def times(): + for build in get_travis(): + if build["event_type"] != "push": continue + if not build["commit"]["committed_at"]: continue + if build["commit"]["committed_at"] < "2018-06-15": break + if build["commit"]["branch"] == "master": continue + if build["state"] != "passed": continue + yield build["started_at"], build["duration"] + +if __name__ == "__main__": + for d, t in times(): + print(d.replace("T", " ").replace("Z", ""), t, sep="\t") diff --git a/randTest/Makefile b/randTest/Makefile deleted file mode 100644 index fbd9bd19a..000000000 --- a/randTest/Makefile +++ /dev/null @@ -1,9 +0,0 @@ -JAVAC = javac - -all: - $(JAVAC) RandomTest.java - -clean: - rm -rf *.class - -.PHONY: all diff --git a/randTest/OperatorTree.java b/randTest/OperatorTree.java deleted file mode 100644 index bb3614ebd..000000000 --- a/randTest/OperatorTree.java +++ /dev/null @@ -1,139 +0,0 @@ -import java.util.Random; -import java.util.Arrays; -import java.nio.ByteBuffer; - -public class OperatorTree { - public static final String[] UNOP = - { "-" - , "sqrt" - , "sqr" - , "exp" - , "log" - , "sin" - , "cos" - , "tan" - , "asin" - , "acos" - , "atan" - , "sinh" - , "cosh" - , "tanh" - , "fabs" - , "expm1" - , "log1p" - }; - - public static final String[] BINOP = - { "+" - , "-" - , "*" - , "/" - , "pow" - , "atan2" - , "fmod" - , "hypot" - }; - - public static final String[] VARS = - "abcdefghijklmnopqrstuvwxyz".split(""); - - private static Random rnd = new Random(); - - private static String choose(String[] a) { - return a[rnd.nextInt(a.length)]; - } - - private static String getDoubleStr() { - byte[] bytes = new byte[8]; - rnd.nextBytes(bytes); - double val = ByteBuffer.wrap(bytes).getDouble(); - return Double.toString(val); - } - - private static int count = 0; - - private final String name; - private final String[] vars; - private final Node expr; - private final String[] dist; - - public OperatorTree(int size, int nVars, String[] dist) { - if(size < 1) throw new Error("size < 1"); - if(nVars > VARS.length) throw new Error("nVars > VARS.length"); - - count++; - this.name = String.format("\"Random Jason Test %03d\"", count); - this.vars = Arrays.copyOf(VARS, nVars); - this.expr = genExpr(size); - this.dist = dist; - } - - private Node genExpr(int fuel) { - fuel--; - - Node n; - if(fuel < 1) { - if(vars.length == 0 || rnd.nextInt(5) == 0) { - n = new Node(getDoubleStr(), null, null); - } else { - n = new Node(choose(vars), null, null); - } - } else if(fuel < 2 || rnd.nextInt(4) == 0) { - n = new Node(choose(UNOP), genExpr(fuel), null); - } else { - int l = rnd.nextInt(fuel - 1) + 1; - int r = fuel - l; - n = new Node(choose(BINOP), genExpr(l), genExpr(r)); - } - return n; - } - - private String makeDist() { - if (dist != null) { - StringBuilder sb = new StringBuilder(); - int minLen = Math.min(dist.length, vars.length); - for (int i = 0; i < minLen; i++) { - sb.append("(" + vars[i] + " (" + dist[i] + ")) "); - } - for (int i = minLen; i < vars.length; i++) { - sb.append(vars[i] + " "); - } - return sb.toString(); - } else { - return String.join(" ", vars); - } - } - - public String toString() { - return String.format( - "(FPCore (%s)\n %s)" - , String.join(" ", makeDist()) - , expr.toString()); - } - - public class Node { - private final String label; - private final Node l; - private final Node r; - - public Node(String label, Node l, Node r) { - this.label = label; - this.l = l; - this.r = r; - } - - public String toString() { - if(l == null && r == null) { - return label; - } - if(l != null && r == null) { - return String.format("(%s %s)", label, l.toString()); - } - if(l != null && r != null) { - return String.format("(%s %s %s)", label, l.toString(), r.toString()); - } - throw new Error("l == null but r != null"); - } - } -} - diff --git a/randTest/RandomTest.java b/randTest/RandomTest.java deleted file mode 100644 index aefe4797f..000000000 --- a/randTest/RandomTest.java +++ /dev/null @@ -1,152 +0,0 @@ -import java.util.Random; - -public class RandomTest { - private static int size = 1; - private static int nVars = 1; - private static int nTests = 1; - - private static int sizeWiggle = 0; - private static int nVarsWiggle = 0; - private static String[] dist; - - private static final String usage = - String.join("\n" - , "Usage: java RandomTest OPTIONS" - , "" - , "where OPTIONS include:" - , " --help print this usage info and exit" - , " --size N size of expressions to generate (default 1)" - , " --size-wiggle N how much to wiggle to randomly add to size (default 0)" - , " --nvars N number of variables in generated expressions (default 1)" - , " --nvars-wiggle N how much wiggle to randomly add to number of vars (default 0)" - , " --ntests N number of tests to generate (default 1)" - , " --samplers N args define samplers for each variable (default default sampler)" - ); - - private static class BogusCL extends Exception { - String msg; - - public BogusCL(String m) { - msg = m; - } - } - - private static int parseArgInt(String[] args, int i) throws BogusCL { - try { - return Integer.parseInt(args[i]); - } - catch(ArrayIndexOutOfBoundsException e) { - throw new BogusCL( - String.format("expected integer argument at position %d", i)); - } - catch(NumberFormatException e) { - throw new BogusCL( - String.format("could not parse '%s' as integer", args[i])); - } - } - - private static void parseArgs(String[] args) throws BogusCL { - int i = 0; - while(i < args.length) { - switch(args[i]) { - case "-h": - case "--help": - System.out.println(usage); - System.exit(0); - case "-s": - case "--size": - i++; - size = parseArgInt(args, i); - if(size < 1) { - throw new BogusCL( - String.format("size must be positive, but got %d", size)); - } - break; - case "-sw": - case "--size-wiggle": - i++; - sizeWiggle = parseArgInt(args, i); - if(sizeWiggle < 0) { - throw new BogusCL( - String.format("wiggle must be nonnegative, but got %d", sizeWiggle)); - } - break; - case "-v": - case "--nvars": - i++; - nVars = parseArgInt(args, i); - if(nVars < 0) { - throw new BogusCL( - String.format("number of vars must be nonnegative, but got %d", nVars)); - } - if(nVars + nVarsWiggle > 26) { - throw new BogusCL( - String.format("number of vars plus wiggle must be <= 26, but got %d" - , nVars + nVarsWiggle)); - } - break; - case "-vw": - case "--nvars-wiggle": - i++; - nVarsWiggle = parseArgInt(args, i); - if(nVarsWiggle < 0) { - throw new BogusCL( - String.format("wiggle must be nonnegative, but got %d", nVarsWiggle)); - } - if(nVars + nVarsWiggle > 26) { - throw new BogusCL( - String.format("number of vars plus wiggle must be <= 26, but got %d" - , nVars + nVarsWiggle)); - } - break; - case "-t": - case "--ntests": - i++; - nTests = parseArgInt(args, i); - if(size < 1) { - throw new BogusCL( - String.format("number of tests must be positive, but got %d", nTests)); - } - break; - case "-sp": - case "--samplers": - i++; - int numSp = Integer.parseInt(args[i]); - i++; - dist = new String[numSp]; - for (int j = 0; j < numSp; j++) { - dist[j] = args[i].replace('_', ' '); - i++; - } - i--; - break; - default: - throw new BogusCL( - String.format("invalid argument '%s'", args[i])); - } - i++; - } - } - - public static void main(String[] args) { - try { - parseArgs(args); - } - catch(BogusCL e) { - System.err.println("ERROR: " + e.msg); - System.err.println(); - System.err.println(usage); - System.exit(1); - } - - Random rnd = new Random(); - - for(int i=0; i" port))]) -(struct alt-event (program event prevs) - #:methods gen:custom-write - [(define (write-proc alt port mode) - (display "#" port))]) - -(define alternative? (or/c alt-delta? alt-event?)) - (define (make-alt prog) - (alt-event prog 'start '())) - -(define (alt? altn) - (or (alt-delta? altn) (alt-event? altn))) - -(define (alt-program altn) - (match altn - [(alt-delta prog _ _) prog] - [(alt-event prog _ _) prog])) - -(define (alt-change altn) - (match altn - [(alt-delta _ cng _) cng] - [(alt-event _ _ '()) #f] - [(alt-event _ _ `(,prev ,_ ...)) (alt-change prev)])) - -(define (alt-prev altn) - (match altn - [(alt-delta _ _ prev) prev] - [(alt-event _ _ '()) #f] - [(alt-event _ _ `(,prev ,_ ...)) (alt-prev prev)])) - -(define (alt-errors altn) - (errors (alt-program altn) (*pcontext*))) + (alt prog 'start '())) (define (alt-cost altn) (program-cost (alt-program altn))) -(define (alt-apply altn . changes) - (foldl (λ (cng altn) - (alt-delta (change-apply cng (alt-program altn)) cng altn)) - altn changes)) - -;; Gets the initial version of the current alt. -(define (alt-initial altn) - (if (alt-prev altn) - (alt-initial (alt-prev altn)) - altn)) - -;; Get a list of every change that's happened to the current alt, in application order. -(define (alt-changes altn) - (let loop ([cur-alt altn] [acc '()]) - (if (alt-prev cur-alt) - (loop (alt-prev cur-alt) (cons (alt-change cur-alt) acc)) - acc))) - -(define (alt-rewrite-expression alt #:destruct [destruct? #f] #:root [root-loc '()]) - (let ([subtree (location-get root-loc (alt-program alt))]) - (map (curry alt-apply alt) - (rewrite-expression subtree #:destruct destruct? #:root root-loc)))) - -(define (alt-rewrite-rm alt #:root [root-loc '()]) - (let ([subtree (location-get root-loc (alt-program alt))]) - (map (curry apply alt-apply alt) - (map reverse - (rewrite-expression-head subtree #:root root-loc))))) - -(define (alt-history-length alt) - (if (alt-prev alt) - (+ 1 (alt-history-length (alt-prev alt))) - 0)) - -(define (alt-set-prev altn prev) - (alt-delta (alt-program altn) (alt-change altn) prev)) - (define (alt-add-event altn event) - (alt-event (alt-program altn) event (list altn))) - -(define (make-regime-alt new-prog altns splitpoints) - (alt-event new-prog (list 'regimes splitpoints) altns)) + (alt (alt-program altn) event (list altn))) diff --git a/src/bigcomplex.rkt b/src/bigcomplex.rkt index a0bdab7be..75e710f52 100644 --- a/src/bigcomplex.rkt +++ b/src/bigcomplex.rkt @@ -11,35 +11,29 @@ [bf-complex-neg (-> bigcomplex? bigcomplex?)] [bf-complex-mult (-> bigcomplex? bigcomplex? bigcomplex?)] [bf-complex-conjugate (-> bigcomplex? bigcomplex?)] - [bf-complex-sqr (-> bigcomplex? bigcomplex?)] [bf-complex-exp (-> bigcomplex? bigcomplex?)] [bf-complex-log (-> bigcomplex? bigcomplex?)] [bf-complex-sqrt (-> bigcomplex? bigcomplex?)] [bf-complex-pow (-> bigcomplex? bigcomplex? bigcomplex?)] - [bf-complex-div (-> bigcomplex? bigcomplex? bigcomplex?)]) - exact+ exact- exact* exact/ exact-sqr exact-log exact-pow exact-sqrt exact-exp) - -(define (bf-complex-add x y) - (bigcomplex (bf+ (bigcomplex-re x) (bigcomplex-re y)) (bf+ (bigcomplex-im x) (bigcomplex-im y)))) - -(define (bf-complex-sub x [y #f]) - (if y - (bf-complex-add x (bf-complex-neg y)) - (bf-complex-neg x))) + [bf-complex-div (-> bigcomplex? bigcomplex? bigcomplex?)])) (define (bf-complex-neg x) (bigcomplex (bf- (bigcomplex-re x)) (bf- (bigcomplex-im x)))) +(define (bf-complex-add x y) + (bigcomplex (bf+ (bigcomplex-re x) (bigcomplex-re y)) + (bf+ (bigcomplex-im x) (bigcomplex-im y)))) + +(define (bf-complex-sub x y) + (bf-complex-add x (bf-complex-neg y))) + (define (bf-complex-mult x y) (bigcomplex (bf+ (bf* (bigcomplex-re x) (bigcomplex-re y)) (bf- (bf* (bigcomplex-im x) (bigcomplex-im y)))) - (bf+ (bf* (bigcomplex-im x) (bigcomplex-re y)) (bf* (bigcomplex-re x) (bigcomplex-im y))))) + (bf+ (bf* (bigcomplex-im x) (bigcomplex-re y)) (bf* (bigcomplex-re x) (bigcomplex-im y))))) (define (bf-complex-conjugate x) (bigcomplex (bigcomplex-re x) (bf- (bigcomplex-im x)))) -(define (bf-complex-sqr x) - (bf-complex-mult x x)) - (define (bf-complex-exp x) (match-define (bigcomplex re im) x) (define scale (bfexp re)) @@ -62,26 +56,6 @@ (define denom (bf-complex-mult y (bf-complex-conjugate y))) (bigcomplex (bf/ (bigcomplex-re numer) (bigcomplex-re denom)) (bf/ (bigcomplex-im numer) (bigcomplex-re denom)))) -(define (make-exact-fun bf-fun bf-complex-fun) - (lambda args - (match args - [(list (? bigfloat?) ...) - (apply bf-fun args)] - [(list (? bigcomplex?) ...) - (apply bf-complex-fun args)]))) - -(require (only-in racket/base [exp e])) - -(define exact+ (make-exact-fun bf+ bf-complex-add)) -(define exact- (make-exact-fun bf- bf-complex-sub)) -(define exact* (make-exact-fun bf* bf-complex-mult)) -(define exact/ (make-exact-fun bf/ bf-complex-div)) -(define exact-exp (make-exact-fun bfexp bf-complex-exp)) -(define exact-log (make-exact-fun bflog bf-complex-log)) -(define exact-pow (make-exact-fun bfexpt bf-complex-pow)) -(define exact-sqr (make-exact-fun bfsqr bf-complex-sqr)) -(define exact-sqrt (make-exact-fun bfsqrt bf-complex-sqrt)) - (module+ test (define (bf-complex-eq-approx bf1 bf2) (check-equal? (bfround (bigcomplex-re bf1)) (bigcomplex-re bf2)) diff --git a/src/biginterval.rkt b/src/biginterval.rkt new file mode 100644 index 000000000..75709e96c --- /dev/null +++ b/src/biginterval.rkt @@ -0,0 +1,625 @@ +#lang racket + +(require math/private/bigfloat/mpfr) +(require "common.rkt" "syntax/types.rkt") + +(struct ival (lo hi err? err) #:transparent) + +(provide (contract-out + [struct ival ([lo bigvalue?] [hi bigvalue?] [err? boolean?] [err boolean?])] + [mk-ival (-> (or/c real? boolean?) ival?)] + [ival-pi (-> ival?)] + [ival-e (-> ival?)] + [ival-bool (-> boolean? ival?)] + [ival-add (-> ival? ival? ival?)] + [ival-sub (-> ival? ival? ival?)] + [ival-neg (-> ival? ival?)] + [ival-mult (-> ival? ival? ival?)] + [ival-div (-> ival? ival? ival?)] + [ival-fma (-> ival? ival? ival? ival?)] + [ival-fabs (-> ival? ival?)] + [ival-sqrt (-> ival? ival?)] + [ival-cbrt (-> ival? ival?)] + [ival-hypot (-> ival? ival? ival?)] + [ival-exp (-> ival? ival?)] + [ival-expm1 (-> ival? ival?)] + [ival-log (-> ival? ival?)] + [ival-log1p (-> ival? ival?)] + [ival-pow (-> ival? ival? ival?)] + [ival-sin (-> ival? ival?)] + [ival-cos (-> ival? ival?)] + [ival-tan (-> ival? ival?)] + [ival-asin (-> ival? ival?)] + [ival-acos (-> ival? ival?)] + [ival-atan (-> ival? ival?)] + [ival-atan2 (-> ival? ival? ival?)] + [ival-sinh (-> ival? ival?)] + [ival-cosh (-> ival? ival?)] + [ival-tanh (-> ival? ival?)] + [ival-asinh (-> ival? ival?)] + [ival-acosh (-> ival? ival?)] + [ival-atanh (-> ival? ival?)] + [ival-erf (-> ival? ival?)] + [ival-erfc (-> ival? ival?)] + [ival-fmod (-> ival? ival? ival?)] + [ival-remainder (-> ival? ival? ival?)] + [ival-and (->* () #:rest (listof ival?) ival?)] + [ival-or (->* () #:rest (listof ival?) ival?)] + [ival-not (-> ival? ival?)] + [ival-< (->* () #:rest (listof ival?) ival?)] + [ival-<= (->* () #:rest (listof ival?) ival?)] + [ival-> (->* () #:rest (listof ival?) ival?)] + [ival->= (->* () #:rest (listof ival?) ival?)] + [ival-== (->* () #:rest (listof ival?) ival?)] + [ival-!= (->* () #:rest (listof ival?) ival?)] + [ival-if (-> ival? ival? ival? ival?)])) + +(define (mk-ival x) + (match x + [(? real?) + (define err? (or (nan? x) (infinite? x))) + (define x* (bf x)) ;; TODO: Assuming that float precision < bigfloat precision + (ival x* x* err? err?)] + [(? boolean?) + (ival x x #f #f)])) + +(define -inf.bf (bf -inf.0)) +(define -1.bf (bf -1)) +(define 0.bf (bf 0)) +(define half.bf (bf 0.5)) +(define 1.bf (bf 1)) +(define 2.bf (bf 2)) +(define +inf.bf (bf +inf.0)) +(define +nan.bf (bf +nan.0)) + +(define (ival-pi) + (ival (rnd 'down identity (pi.bf)) (rnd 'up identity (pi.bf)) #f #f)) + +(define (ival-e) + (ival (rnd 'down bfexp 1.bf) (rnd 'up bfexp 1.bf) #f #f)) + +(define (ival-bool b) + (ival b b #f #f)) + +(define ival-true (ival-bool #t)) + +(define-syntax-rule (rnd mode op args ...) + (parameterize ([bf-rounding-mode mode]) + (op args ...))) + +(define (ival-neg x) + ;; No rounding, negation is exact + (ival (bfneg (ival-hi x)) (bfneg (ival-lo x)) (ival-err? x) (ival-err x))) + +(define (ival-add x y) + (ival (rnd 'down bfadd (ival-lo x) (ival-lo y)) + (rnd 'up bfadd (ival-hi x) (ival-hi y)) + (or (ival-err? x) (ival-err? y)) + (or (ival-err x) (ival-err y)))) + +(define (ival-sub x y) + (ival (rnd 'down bfsub (ival-lo x) (ival-hi y)) + (rnd 'up bfsub (ival-hi x) (ival-lo y)) + (or (ival-err? x) (ival-err? y)) + (or (ival-err x) (ival-err y)))) + +(define (bfmin* a . as) + (if (null? as) a (apply bfmin* (bfmin2 a (car as)) (cdr as)))) + +(define (bfmax* a . as) + (if (null? as) a (apply bfmax* (bfmax2 a (car as)) (cdr as)))) + +(define (ival-mult x y) + (define err? (or (ival-err? x) (ival-err? y))) + (define err (or (ival-err x) (ival-err y))) + (match* ((classify-ival x) (classify-ival y)) + [(1 1) + (ival (rnd 'down bfmul (ival-lo x) (ival-lo y)) + (rnd 'up bfmul (ival-hi x) (ival-hi y)) err? err)] + [(1 -1) + (ival (rnd 'down bfmul (ival-hi x) (ival-lo y)) + (rnd 'up bfmul (ival-lo x) (ival-hi y)) err? err)] + [(1 0) + (ival (rnd 'down bfmul (ival-hi x) (ival-lo y)) + (rnd 'up bfmul (ival-hi x) (ival-hi y)) err? err)] + [(-1 0) + (ival (rnd 'down bfmul (ival-lo x) (ival-hi y)) + (rnd 'up bfmul (ival-lo x) (ival-lo y)) err? err)] + [(-1 1) + (ival (rnd 'down bfmul (ival-lo x) (ival-hi y)) + (rnd 'up bfmul (ival-hi x) (ival-lo y)) err? err)] + [(-1 -1) + (ival (rnd 'down bfmul (ival-hi x) (ival-hi y)) + (rnd 'up bfmul (ival-lo x) (ival-lo y)) err? err)] + [(0 1) + (ival (rnd 'down bfmul (ival-lo x) (ival-hi y)) + (rnd 'up bfmul (ival-hi x) (ival-hi y)) err? err)] + [(0 -1) + (ival (rnd 'down bfmul (ival-hi x) (ival-lo y)) + (rnd 'up bfmul (ival-lo x) (ival-lo y)) err? err)] + [(0 0) ; The "else" case is always correct, but is slow + ;; We round only down, and approximate rounding up with bfnext below + (define opts + (rnd 'down list + (bfmul (ival-lo x) (ival-lo y)) (bfmul (ival-hi x) (ival-lo y)) + (bfmul (ival-lo x) (ival-hi y)) (bfmul (ival-hi x) (ival-hi y)))) + (ival (apply bfmin* opts) (bfnext (apply bfmax* opts)) err? err)])) + +(define (ival-div x y) + (define err? (or (ival-err? x) (ival-err? y) (and (bflte? (ival-lo y) 0.bf) (bfgte? (ival-hi y) 0.bf)))) + (define err (or (ival-err x) (ival-err y) (and (bf=? (ival-lo y) 0.bf) (bf=? (ival-hi y) 0.bf)))) + ;; We round only down, and approximate rounding up with bfnext below + (match* ((classify-ival x) (classify-ival y)) + [(_ 0) + (ival -inf.bf +inf.bf err? err)] + [(1 1) + (ival (rnd 'down bfdiv (ival-lo x) (ival-hi y)) + (rnd 'up bfdiv (ival-hi x) (ival-lo y)) err? err)] + [(1 -1) + (ival (rnd 'down bfdiv (ival-hi x) (ival-hi y)) + (rnd 'up bfdiv (ival-lo x) (ival-lo y)) err? err)] + [(-1 1) + (ival (rnd 'down bfdiv (ival-lo x) (ival-lo y)) + (rnd 'up bfdiv (ival-hi x) (ival-hi y)) err? err)] + [(-1 -1) + (ival (rnd 'down bfdiv (ival-hi x) (ival-lo y)) + (rnd 'up bfdiv (ival-lo x) (ival-hi y)) err? err)] + [(0 1) + (ival (rnd 'down bfdiv (ival-lo x) (ival-lo y)) + (rnd 'up bfdiv (ival-hi x) (ival-lo y)) err? err)] + [(0 -1) + (ival (rnd 'down bfdiv (ival-hi x) (ival-hi y)) + (rnd 'up bfdiv (ival-lo x) (ival-hi y)) err? err)] + [(_ _) + (define opts + (rnd 'down list + (bfdiv (ival-lo x) (ival-lo y)) (bfdiv (ival-hi x) (ival-lo y)) + (bfdiv (ival-lo x) (ival-hi y)) (bfdiv (ival-hi x) (ival-hi y)))) + (ival (apply bfmin* opts) (bfnext (apply bfmax* opts)) err? err)])) + +(define (ival-exp x) + (ival (rnd 'down bfexp (ival-lo x)) (rnd 'up bfexp (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-expm1 x) + (ival (rnd 'down bfexpm1 (ival-lo x)) (rnd 'up bfexpm1 (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-log x) + (define err (or (ival-err x) (bflte? (ival-hi x) 0.bf))) + (define err? (or err (ival-err? x) (bflte? (ival-lo x) 0.bf))) + (ival (rnd 'down bflog (ival-lo x)) (rnd 'up bflog (ival-hi x)) + err? err)) + +(define (ival-log1p x) + (define err (or (ival-err x) (bflte? (ival-hi x) -1.bf))) + (define err? (or err (ival-err? x) (bflte? (ival-lo x) -1.bf))) + (ival (rnd 'down bflog1p (ival-lo x)) (rnd 'up bflog1p (ival-hi x)) + err? err)) + +(define (ival-sqrt x) + (define err (or (ival-err x) (bflte? (ival-hi x) 0.bf))) + (define err? (or err (ival-err? x) (bflte? (ival-lo x) 0.bf))) + (ival (rnd 'down bfsqrt (ival-lo x)) (rnd 'up bfsqrt (ival-hi x)) + err? err)) + +(define (ival-cbrt x) + (ival (rnd 'down bfcbrt (ival-lo x)) (rnd 'up bfcbrt (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-hypot x y) + (define err? (or (ival-err? x) (ival-err? y))) + (define err (or (ival-err x) (ival-err y))) + (define x* (ival-fabs x)) + (define y* (ival-fabs y)) + (ival (rnd 'down bfhypot (ival-lo x*) (ival-lo y*)) + (rnd 'up bfhypot (ival-hi x*) (ival-hi y*)) + err? err)) + +(define (ival-pow x y) + (define err? (or (ival-err? x) (ival-err? y))) + (define err (or (ival-err x) (ival-err y))) + (cond + [(bfgte? (ival-lo x) 0.bf) + (let ([lo + (if (bflt? (ival-lo x) 1.bf) + (rnd 'down bfexpt (ival-lo x) (ival-hi y)) + (rnd 'down bfexpt (ival-lo x) (ival-lo y)))] + [hi + (if (bfgt? (ival-hi x) 1.bf) + (rnd 'up bfexpt (ival-hi x) (ival-hi y)) + (rnd 'up bfexpt (ival-hi x) (ival-lo y)))]) + (ival lo hi err? err))] + [(and (bf=? (ival-lo y) (ival-hi y)) (bfinteger? (ival-lo y))) + (ival (rnd 'down bfexpt (ival-lo x) (ival-lo y)) + (rnd 'up bfexpt (ival-lo x) (ival-lo y)) + err? err)] + [else + ;; In this case, the base range includes negatives and the exp range includes reals + ;; Focus first on just the negatives in the base range + ;; All the reals in the exp range just make NaN a possible output + ;; If there are no integers in the exp range, those NaNs are the only output + ;; If there are, the min of the negative base values is from the biggest odd integer in the range + ;; and the max is from the biggest even integer in the range + (define a (bfceiling (ival-lo y))) + (define b (bffloor (ival-hi y))) + (define lo (ival-lo x)) + (define neg-range + (cond + [(bflt? b a) + (ival +nan.bf +nan.bf #t #t)] + [(bf=? a b) + (ival (rnd 'down bfexpt (ival-lo x) a) (rnd 'up bfexpt (ival-hi x) a) err? err)] + [(bfodd? b) + (ival (rnd 'down bfexpt (ival-lo x) b) + (rnd 'up bfmax2 (bfexpt (ival-hi x) (bfsub b 1.bf)) (bfexpt (ival-lo x) (bfsub b 1.bf))) err? err)] + [(bfeven? b) + (ival (rnd 'down bfexpt (ival-lo x) (bfsub b 1.bf)) + (rnd 'up bfmax2 (bfexpt (ival-hi x) b) (bfexpt (ival-lo x) b)) err? err)] + [else (ival +nan.bf +nan.bf #f #t)])) + (if (bfgt? (ival-hi x) 0.bf) + (ival-union neg-range (ival-pow (ival 0.bf (ival-hi x) err? err) y)) + neg-range)])) + +(define (ival-fma a b c) + (ival-add (ival-mult a b) c)) + +(define (ival-and . as) + (ival (andmap ival-lo as) (andmap ival-hi as) + (ormap ival-err? as) (ormap ival-err as))) + +(define (ival-or . as) + (ival (ormap ival-lo as) (ormap ival-hi as) + (ormap ival-err? as) (ormap ival-err as))) + +(define (ival-not x) + (ival (not (ival-hi x)) (not (ival-lo x)) (ival-err? x) (ival-err x))) + +(define (ival-cos x) + (define lopi (rnd 'down identity (pi.bf))) + (define hipi (rnd 'up identity (pi.bf))) + (define a (rnd 'down bffloor (bfdiv (ival-lo x) (if (bflt? (ival-lo x) 0.bf) lopi hipi)))) + (define b (rnd 'up bffloor (bfdiv (ival-hi x) (if (bflt? (ival-hi x) 0.bf) hipi lopi)))) + (cond + [(and (bf=? a b) (bfeven? a)) + (ival (rnd 'down bfcos (ival-hi x)) (rnd 'up bfcos (ival-lo x)) (ival-err? x) (ival-err x))] + [(and (bf=? a b) (bfodd? a)) + (ival (rnd 'down bfcos (ival-lo x)) (rnd 'up bfcos (ival-hi x)) (ival-err? x) (ival-err x))] + [(and (bf=? (bfsub b a) 1.bf) (bfeven? a)) + (ival -1.bf (rnd 'up bfmax2 (bfcos (ival-lo x)) (bfcos (ival-hi x))) (ival-err? x) (ival-err x))] + [(and (bf=? (bfsub b a) 1.bf) (bfodd? a)) + (ival (rnd 'down bfmin2 (bfcos (ival-lo x)) (bfcos (ival-hi x))) 1.bf (ival-err? x) (ival-err x))] + [else + (ival -1.bf 1.bf (ival-err? x) (ival-err x))])) + +(define (ival-sin x) + (define lopi (rnd 'down identity (pi.bf))) + (define hipi (rnd 'up identity (pi.bf))) + (define a (rnd 'down bffloor (bfsub (bfdiv (ival-lo x) (if (bflt? (ival-lo x) 0.bf) lopi hipi)) half.bf))) ; half.bf is exact + (define b (rnd 'up bffloor (bfsub (bfdiv (ival-hi x) (if (bflt? (ival-hi x) 0.bf) hipi lopi)) half.bf))) + (cond + [(and (bf=? a b) (bfeven? a)) + (ival (rnd 'down bfsin (ival-hi x)) (rnd 'up bfsin (ival-lo x)) (ival-err? x) (ival-err x))] + [(and (bf=? a b) (bfodd? a)) + (ival (rnd 'down bfsin (ival-lo x)) (rnd 'up bfsin (ival-hi x)) (ival-err? x) (ival-err x))] + [(and (bf=? (bfsub b a) 1.bf) (bfeven? a)) + (ival -1.bf (rnd 'up bfmax2 (bfsin (ival-lo x)) (bfsin (ival-hi x))) (ival-err? x) (ival-err x))] + [(and (bf=? (bfsub b a) 1.bf) (bfodd? a)) + (ival (rnd 'down bfmin2 (bfsin (ival-lo x)) (bfsin (ival-hi x))) 1.bf (ival-err? x) (ival-err x))] + [else + (ival -1.bf 1.bf (ival-err? x) (ival-err x))])) + +(define (ival-tan x) + (ival-div (ival-sin x) (ival-cos x))) + +(define (ival-atan x) + (ival (rnd 'down bfatan (ival-lo x)) (rnd 'up bfatan (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (classify-ival x) + (cond [(bfgte? (ival-lo x) 0.bf) 1] [(bflte? (ival-hi x) 0.bf) -1] [else 0])) + +(define (ival-atan2 y x) + (define err? (or (ival-err? x) (ival-err? y))) + (define err (or (ival-err x) (ival-err y))) + + (define tl (list (ival-hi y) (ival-lo x))) + (define tr (list (ival-hi y) (ival-hi x))) + (define bl (list (ival-lo y) (ival-lo x))) + (define br (list (ival-lo y) (ival-hi x))) + + (define-values (a-lo a-hi) + (match* ((classify-ival x) (classify-ival y)) + [(-1 -1) (values tl br)] + [( 0 -1) (values tl tr)] + [( 1 -1) (values bl tr)] + [( 1 0) (values bl tl)] + [( 1 1) (values br tl)] + [( 0 1) (values br bl)] + [(-1 1) (values tr bl)] + [( _ _) (values #f #f)])) + + (if a-lo + (ival (rnd 'down apply bfatan2 a-lo) (rnd 'up apply bfatan2 a-hi) err? err) + (ival (rnd 'down bfneg (pi.bf)) (rnd 'up identity (pi.bf)) + (or err? (bfgte? (ival-hi x) 0.bf)) + (or err (and (bf=? (ival-lo x) 0.bf) (bf=? (ival-hi x) 0.bf) (bf=? (ival-lo y) 0.bf) (bf=? (ival-hi y) 0.bf)))))) + +(define (ival-asin x) + (ival (rnd 'down bfasin (ival-lo x)) (rnd 'up bfasin (ival-hi x)) + (or (ival-err? x) (bflt? (ival-lo x) -1.bf) (bfgt? (ival-hi x) 1.bf)) + (or (ival-err x) (bflt? (ival-hi x) -1.bf) (bfgt? (ival-lo x) 1.bf)))) + +(define (ival-acos x) + (ival (rnd 'down bfacos (ival-hi x)) (rnd 'up bfacos (ival-lo x)) + (or (ival-err? x) (bflt? (ival-lo x) -1.bf) (bfgt? (ival-hi x) 1.bf)) + (or (ival-err x) (bflt? (ival-hi x) -1.bf) (bfgt? (ival-lo x) 1.bf)))) + +(define (ival-fabs x) + (cond + [(bfgt? (ival-lo x) 0.bf) x] + [(bflt? (ival-hi x) 0.bf) + (ival (bfneg (ival-hi x)) (bfneg (ival-lo x)) (ival-err? x) (ival-err x))] + [else ; interval stradles 0 + (ival 0.bf (bfmax2 (bfneg (ival-lo x)) (ival-hi x)) (ival-err? x) (ival-err x))])) + +(define (ival-sinh x) + (ival (rnd 'down bfsinh (ival-lo x)) (rnd 'up bfsinh (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-cosh x) + (define y (ival-fabs x)) + (ival (rnd 'down bfcosh (ival-lo y)) (rnd 'up bfcosh (ival-hi y)) (ival-err? y) (ival-err y))) + +(define (ival-tanh x) + (ival (rnd 'down bftanh (ival-lo x)) (rnd 'up bftanh (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-asinh x) + (ival (rnd 'down bfasinh (ival-lo x)) (rnd 'up bfasinh (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-acosh x) + (ival (rnd 'down bfacosh (bfmax2 (ival-lo x) 1.bf)) (rnd 'up bfacosh (ival-hi x)) + (or (bflte? (ival-lo x) 1.bf) (ival-err? x)) (or (bflt? (ival-hi x) 1.bf) (ival-err x)))) + +(define (ival-atanh x) + (ival (rnd 'down bfatanh (ival-lo x)) (rnd 'up bfatanh (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-fmod x y) + (define y* (ival-fabs y)) + (define quot (ival-div x y*)) + (define a (rnd 'down bftruncate (ival-lo quot))) + (define b (rnd 'up bftruncate (ival-hi quot))) + (define err? (or (ival-err? x) (ival-err? y) (bf=? (ival-lo y*) 0.bf))) + (define err (or (ival-err x) (ival-err y) (bf=? (ival-hi y*) 0.bf))) + (define tquot (ival a b err? err)) + + (cond + [(bf=? a b) (ival-sub x (ival-mult tquot y*))] + [(bflte? b 0.bf) (ival (bfneg (ival-hi y*)) 0.bf err? err)] + [(bfgte? a 0.bf) (ival 0.bf (ival-hi y*) err? err)] + [else (ival (bfneg (ival-hi y*)) (ival-hi y*) err? err)])) + +(define (ival-remainder x y) + (define y* (ival-fabs y)) + (define quot (ival-div x y*)) + (define a (rnd 'down bfround (ival-lo quot))) + (define b (rnd 'up bfround (ival-hi quot))) + (define err? (or (ival-err? x) (ival-err? y) (bf=? (ival-lo y*) 0.bf))) + (define err (or (ival-err x) (ival-err y) (bf=? (ival-hi y*) 0.bf))) + + (if (bf=? a b) + (ival-sub x (ival-mult (ival a b err? err) y*)) + (ival (bfneg (bfdiv (ival-hi y*) 2.bf)) (bfdiv (ival-hi y*) 2.bf) err? err))) + +(define (ival-erf x) + (ival (rnd 'down bferf (ival-lo x)) (rnd 'up bferf (ival-hi x)) (ival-err? x) (ival-err x))) + +(define (ival-erfc x) + (ival (rnd 'down bferfc (ival-hi x)) (rnd 'up bferfc (ival-lo x)) (ival-err? x) (ival-err x))) + +(define (ival-cmp x y) + (define can-< (bflt? (ival-lo x) (ival-hi y))) + (define must-< (bflt? (ival-hi x) (ival-lo y))) + (define can-> (bfgt? (ival-hi x) (ival-lo y))) + (define must-> (bfgt? (ival-lo x) (ival-hi y))) + (values can-< must-< can-> must->)) + +(define (ival-<2 x y) + (define-values (c< m< c> m>) (ival-cmp x y)) + (ival m< c< (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))) + +(define (ival-<=2 x y) + (define-values (c< m< c> m>) (ival-cmp x y)) + (ival (not c>) (not m>) (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))) + +(define (ival->2 x y) + (define-values (c< m< c> m>) (ival-cmp x y)) + (ival m> c> (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))) + +(define (ival->=2 x y) + (define-values (c< m< c> m>) (ival-cmp x y)) + (ival (not c<) (not m<) (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))) + +(define (ival-==2 x y) + (define-values (c< m< c> m>) (ival-cmp x y)) + (ival (and (not c<) (not c>)) (or (not m<) (not m>)) (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))) + +(define (ival-comparator f name) + (procedure-rename + (λ as + (if (null? as) + ival-true + (let loop ([head (car as)] [tail (cdr as)] [acc ival-true]) + (match tail + ['() acc] + [(cons next rest) + (loop next rest (ival-and (f head next) ival-true))])))) + name)) + +(define ival-< (ival-comparator ival-<2 'ival-<)) +(define ival-<= (ival-comparator ival-<=2 'ival-<=)) +(define ival-> (ival-comparator ival->2 'ival->)) +(define ival->= (ival-comparator ival->=2 'ival->=)) +(define ival-== (ival-comparator ival-==2 'ival-==)) + +(define (ival-!=2 x y) + (define-values (c< m< c> m>) (ival-cmp x y)) + (ival (or c< c>) (or m< m>) (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))) + +(define (ival-!= . as) + (if (null? as) + ival-true + (let loop ([head (car as)] [tail (cdr as)]) + (if (null? tail) + ival-true + (ival-and + (foldl ival-and ival-true (map (curry ival-!=2 head) tail)) + (loop (car tail) (cdr tail))))))) + +(define (ival-union x y) + (match (ival-lo x) + [(? bigfloat?) + (ival (bfmin2 (ival-lo x) (ival-lo y)) (bfmax2 (ival-hi x) (ival-hi y)) + (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))] + [(? boolean?) + (ival (and (ival-lo x) (ival-lo y)) (or (ival-hi x) (ival-hi y)) + (or (ival-err? x) (ival-err? y)) (or (ival-err x) (ival-err y)))])) + +(define (propagate-err c x) + (ival (ival-lo x) (ival-hi x) + (or (ival-err? c) (ival-err? x)) + (or (ival-err c) (ival-err x)))) + +(define (ival-if c x y) + (cond + [(ival-lo c) (propagate-err c x)] + [(not (ival-hi c)) (propagate-err c y)] + [else (propagate-err c (ival-union x y))])) + + +(module+ test + (require rackunit math/flonum) + + (define num-tests 1000) + + (define (sample-interval) + (if (= (random 0 2) 0) + (let ([v1 (sample-double)] [v2 (sample-double)]) + (ival (bf (min v1 v2)) (bf (max v1 v2)) (or (nan? v1) (nan? v2)) (and (nan? v1) (nan? v2)))) + (let* ([v1 (bf (sample-double))] [exp (random 0 31)] [mantissa (random 0 (expt 2 exp))] [sign (- (* 2 (random 0 2)) 1)]) + (define v2 (bfstep v1 (* sign (+ exp mantissa)))) + (if (= sign -1) + (ival v2 v1 (or (bfnan? v1) (bfnan? v2)) (and (bfnan? v1) (bfnan? v2))) + (ival v1 v2 (or (bfnan? v1) (bfnan? v2)) (and (bfnan? v1) (bfnan? v2))))))) + + (define (sample-bf) + (bf (sample-double))) + + (define (sample-from ival) + (if (bigfloat? (ival-lo ival)) + (let ([p (random)]) + (bfadd (bfmul (bf p) (ival-lo ival)) (bfmul (bfsub 1.bf (bf p)) (ival-hi ival)))) + (let ([p (random 0 2)]) + (if (= p 0) (ival-lo ival) (ival-hi ival))))) + + (define (ival-valid? ival) + (or (boolean? (ival-lo ival)) + (bfnan? (ival-lo ival)) + (bfnan? (ival-hi ival)) + (bflte? (ival-lo ival) (ival-hi ival)))) + + (define (ival-contains? ival pt) + (or (ival-err? ival) + (if (bigfloat? pt) + (if (bfnan? pt) + (ival-err? ival) + (and (bflte? (ival-lo ival) pt) (bflte? pt (ival-hi ival)))) + (or (equal? pt (ival-lo ival)) (equal? pt (ival-hi ival)))))) + + (check ival-contains? (ival-bool #f) #f) + (check ival-contains? (ival-bool #t) #t) + (check ival-contains? (ival-pi) (pi.bf)) + (check ival-contains? (ival-e) (bfexp 1.bf)) + (test-case "mk-ival" + (for ([i (in-range num-tests)]) + (define pt (sample-double)) + (with-check-info (['point pt]) + (check-pred ival-valid? (mk-ival pt)) + (check ival-contains? (mk-ival pt) (bf pt))))) + + (define arg1 + (list (cons ival-neg bfneg) + (cons ival-fabs bfabs) + (cons ival-sqrt bfsqrt) + (cons ival-cbrt bfcbrt) + (cons ival-exp bfexp) + (cons ival-expm1 bfexpm1) + (cons ival-log bflog) + (cons ival-log1p bflog1p) + (cons ival-sin bfsin) + (cons ival-cos bfcos) + (cons ival-tan bftan) + (cons ival-asin bfasin) + (cons ival-acos bfacos) + (cons ival-atan bfatan) + (cons ival-sinh bfsinh) + (cons ival-cosh bfcosh) + (cons ival-tanh bftanh))) + + (for ([(ival-fn fn) (in-dict arg1)]) + (test-case (~a (object-name ival-fn)) + (for ([n (in-range num-tests)]) + (define i (sample-interval)) + (define x (sample-from i)) + (with-check-info (['fn ival-fn] ['interval i] ['point x] ['number n]) + (check-pred ival-valid? (ival-fn i)) + (check ival-contains? (ival-fn i) (fn x)))))) + + (define arg2 + (list (cons ival-add bfadd) + (cons ival-sub bfsub) + (cons ival-mult bfmul) + (cons ival-div bfdiv) + (cons ival-hypot bfhypot) + (cons ival-atan2 bfatan2) + (cons ival-< bflt?) + (cons ival-> bfgt?) + (cons ival-<= bflte?) + (cons ival->= bfgte?) + (cons ival-== bf=?) + (cons ival-!= (compose not bf=?)))) + + (for ([(ival-fn fn) (in-dict arg2)]) + (test-case (~a (object-name ival-fn)) + (for ([n (in-range num-tests)]) + (define i1 (sample-interval)) + (define i2 (sample-interval)) + (define x1 (sample-from i1)) + (define x2 (sample-from i2)) + + (with-check-info (['fn ival-fn] ['interval1 i1] ['interval2 i2] ['point1 x1] ['point2 x2] ['number n]) + (define iy (ival-fn i1 i2)) + (check-pred ival-valid? iy) + (check ival-contains? iy (fn x1 x2)))))) + + (define (bffmod x y) + (bfsub x (bfmul (bftruncate (bfdiv x y)) y))) + + (define (bfremainder x mod) + (bfsub x (bfmul (bfround (bfdiv x mod)) mod))) + + (define weird (list (cons ival-fmod bffmod) (cons ival-remainder bfremainder))) + + (for ([(ival-fn fn) (in-dict weird)]) + (test-case (~a (object-name ival-fn)) + (for ([n (in-range num-tests)]) + (define i1 (sample-interval)) + (define i2 (sample-interval)) + (define x1 (sample-from i1)) + (define x2 (sample-from i2)) + + (define y (parameterize ([bf-precision 8000]) (fn x1 x2))) + + ;; Known bug in bffmod where rounding error causes invalid output + (unless (or (bflte? (bfmul y x1) 0.bf) (bfgt? (bfabs y) (bfabs x2))) + (with-check-info (['fn ival-fn] ['interval1 i1] ['interval2 i2] + ['point1 x1] ['point2 x2] ['number n]) + (define iy (ival-fn i1 i2)) + (check-pred ival-valid? iy) + (check ival-contains? iy y)))))) + ) diff --git a/src/common.rkt b/src/common.rkt index 9f173d049..6588e9f00 100644 --- a/src/common.rkt +++ b/src/common.rkt @@ -1,21 +1,18 @@ #lang racket -(require math/flonum) -(require math/bigfloat) -(require "config.rkt" "errors.rkt" "debug.rkt") +(require math/flonum math/bigfloat racket/runtime-path) +(require "config.rkt" "errors.rkt" "debug.rkt" "interface.rkt") +(module+ test (require rackunit)) -(module+ test - (require rackunit)) - -(provide *start-prog* +(provide *start-prog* *all-alts* reap define-table table-ref table-set! table-remove! - first-value assert for/append - ordinary-value? =-or-nan? log2 i ([tbl (cons/c (listof (cons/c symbol? contract?)) (hash/c symbol? (listof any/c)))] - [key symbol?] - [field symbol?]) - [_ (tbl field) (dict-ref (car tbl) field)]) + (define name (cons (list (cons 'field type) ...) (make-hash)))) + +(define (table-ref tbl key field) (match-let ([(cons header rows) tbl]) (for/first ([(field-name type) (in-dict header)] - [value (in-list (dict-ref rows key))] + [value (in-list (hash-ref rows key))] #:when (equal? field-name field)) value))) -(define/contract (table-set! tbl key fields) - (->i ([tbl (cons/c (listof (cons/c symbol? contract?)) (hash/c symbol? (listof any/c)))] - [key symbol?] - [fields (tbl) - ;; Don't check value types because the contract gets pretty rough :( - (and/c dict? (λ (d) (andmap (curry dict-has-key? d) (dict-keys (car tbl)))))]) - any) +(define (table-set! tbl key fields) (match-let ([(cons header rows) tbl]) (define row (for/list ([(hkey htype) (in-dict header)]) (dict-ref fields hkey))) - (dict-set! rows key row))) + (hash-set! rows key row))) -(define/contract (table-remove! tbl key) - ((cons/c (listof (cons/c symbol? contract?)) (hash/c symbol? (listof any/c))) symbol? . -> . void?) - (match-let ([(cons header rows) tbl]) - (dict-remove! rows key))) +(define (table-remove! tbl key) + (hash-remove! (cdr tbl) key)) ;; More various helpful values -(define-syntax-rule (first-value expr) - (call-with-values - (λ () expr) - (compose car list))) - -(module+ test - (check-equal? (first-value (values 1 2 3)) 1)) - (define-syntax assert (syntax-rules () [(assert pred #:loc location) (when (not pred) (error location "~a returned false!" 'pred))] - [(assert pred #:extra-info func) - (when (not pred) - (error 'assert (format "~a returned false! Extra info: ~a" - 'pred (func))))] [(assert pred) (when (not pred) (error 'assert "~a returned false!" 'pred))])) @@ -103,47 +74,16 @@ (check-equal? (for/append ([v (in-range 5)]) (list v v v)) '(0 0 0 1 1 1 2 2 2 3 3 3 4 4 4))) -;; Simple floating-point functions - -(define (ordinary-value? x) - (match x - [(? real?) - (not (or (infinite? x) (nan? x)))] - [(? complex?) - (and (ordinary-value? (real-part x)) (ordinary-value? (imag-part x)))] - [(? boolean?) - true])) - -(module+ test - (check-true (ordinary-value? 2.5)) - (check-false (ordinary-value? +nan.0)) - (check-false (ordinary-value? -inf.f))) - -(define (=-or-nan? x1 x2) - (or (= x1 x2) - (and (nan? x1) (nan? x2)))) - -(module+ test - (check-true (=-or-nan? 2.3 2.3)) - (check-false (=-or-nan? 2.3 7.8)) - (check-true (=-or-nan? +nan.0 -nan.f)) - (check-false (=-or-nan? 2.3 +nan.f))) - -(define (syntax stx (cons #'list parts))))] [(_ a) #'(app syntax-e 'a)]))) + +;; String formatting operations + +(define (format-time ms) + (cond + [(< ms 1000) (format "~ams" (round ms))] + [(< ms 60000) (format "~as" (/ (round (/ ms 100.0)) 10))] + [(< ms 3600000) (format "~am" (/ (round (/ ms 6000.0)) 10))] + [else (format "~ahr" (/ (round (/ ms 360000.0)) 10))])) + +(define (format-bits r #:sign [sign #f] #:unit [unit? #f]) + (define unit (if unit? "b" "")) + (cond + [(not r) ""] + [(and (> r 0) sign) (format "+~a~a" (/ (round (* r 10)) 10) unit)] + [else (format "~a~a" (/ (round (* r 10)) 10) unit)])) + +(define (call-with-output-files names k) + (let loop ([names names] [ps '()]) + (if (null? names) + (apply k (reverse ps)) + (if (car names) + (call-with-output-file + (car names) #:exists 'replace + (λ (p) (loop (cdr names) (cons p ps)))) + (loop (cdr names) (cons #f ps)))))) + +(define-syntax-rule (when-dict d (arg ...) body ...) + (if (and (dict-has-key? d 'arg) ...) + (let ([arg (dict-ref d 'arg)] ...) + body ...) + '())) + +(define (in-sorted-dict d #:key [key identity]) + (in-dict (sort (dict->list d) > #:key (compose key cdr)))) + +(define-runtime-path web-resource-path "web/") + +(define (web-resource [name #f]) + (if name + (build-path web-resource-path name) + web-resource-path)) + +(define (all-partitions n #:from [k 1]) + (cond + [(= n 0) '(())] + [(< n k) '()] + [else + (append (map (curry cons k) (all-partitions (- n k) #:from k)) + (all-partitions n #:from (+ k 1)))])) + +(define ((comparator test) . args) + (for/and ([left args] [right (cdr args)]) + (test left right))) + +(define (sample-double) + (floating-point-bytes->real (integer->integer-bytes (random-exp 64) 8 #f))) diff --git a/src/config.rkt b/src/config.rkt index 87c04414d..2590decc9 100644 --- a/src/config.rkt +++ b/src/config.rkt @@ -1,26 +1,20 @@ #lang racket -(require racket/runtime-path) (provide (all-defined-out)) -(define-runtime-path viz-output-path "../www/viz/") -(define-runtime-path web-resource-path "web/") - -;; Flag Stuff +;;; Flags (define all-flags #hash([precision . (double fallback)] - [fn . (cbrt)] ;; TODO: This is a bad way to disable functions: figure out a better one [setup . (simplify early-exit)] - [generate . (rr taylor simplify)] - [reduce . (regimes taylor simplify avg-error post-process binary-search branch-expressions)] + [generate . (rr taylor simplify better-rr)] + [reduce . (regimes avg-error binary-search branch-expressions)] [rules . (arithmetic polynomials fractions exponents trigonometry hyperbolic numerics complex special bools branches)])) (define default-flags #hash([precision . (double fallback)] - [fn . (cbrt)] [setup . (simplify)] [generate . (rr taylor simplify)] - [reduce . (regimes taylor simplify avg-error binary-search branch-expressions)] + [reduce . (regimes avg-error binary-search branch-expressions)] [rules . (arithmetic polynomials fractions exponents trigonometry hyperbolic complex special bools branches)])) (define (enable-flag! category flag) @@ -47,32 +41,32 @@ [(#t #f) (list 'enabled class flag)] [(#f #t) (list 'disabled class flag)])))) +;;; Herbie internal parameters + ;; Number of points to sample for evaluating program accuracy (define *num-points* (make-parameter 256)) ;; Number of iterations of the core loop for improving program accuracy (define *num-iterations* (make-parameter 4)) -;; The step size with which arbitrary-precision precision is increased -;; DANGEROUS TO CHANGE -(define *precision-step* (make-parameter 256)) +;; The maximum number of consecutive skipped points for sampling valid points +(define *max-skipped-points* (make-parameter 100)) ;; Maximum MPFR precision allowed during exact evaluation (define *max-mpfr-prec* (make-parameter 10000)) -;; In periodicity analysis, -;; this is how small the period of a function must be to count as periodic -(define *max-period-coeff* 20) +;; The maximum size of an egraph +(define *node-limit* (make-parameter 5000)) ;; In localization, the maximum number of locations returned (define *localize-expressions-limit* (make-parameter 4)) -(define *binary-search-test-points* (make-parameter 16)) - ;; How accurate to make the binary search +(define *binary-search-test-points* (make-parameter 16)) (define *binary-search-accuracy* (make-parameter 48)) ;;; About Herbie: + (define (run-command cmd) (parameterize ([current-error-port (open-output-nowhere)]) (string-trim (with-output-to-string (λ () (system cmd)))))) @@ -84,7 +78,7 @@ (if (equal? out "") default out)) default)) -(define *herbie-version* "1.2") +(define *herbie-version* "1.3") (define *hostname* (run-command "hostname")) @@ -93,3 +87,23 @@ (define *herbie-branch* (git-command "rev-parse" "--abbrev-ref" "HEAD" #:default "release")) + +;;; The "reset" mechanism for clearing caches and such + +(define resetters '()) + +(define (register-reset fn #:priority [priority 0]) + (set! resetters (cons (cons priority fn) resetters))) + +(define (reset!) + (for ([fn-rec (sort resetters < #:key car)]) ((cdr fn-rec)))) + +;; OBSOLETE + +;; The step size with which arbitrary-precision precision is increased +;; DANGEROUS TO CHANGE +(define *precision-step* (make-parameter 256)) + +;; In periodicity analysis, +;; this is how small the period of a function must be to count as periodic +(define *max-period-coeff* 20) diff --git a/src/core/alt-table.rkt b/src/core/alt-table.rkt index 0e5baa2ac..d30f1700c 100644 --- a/src/core/alt-table.rkt +++ b/src/core/alt-table.rkt @@ -18,6 +18,7 @@ . -> . (values alt? alt-table?))) (atab-completed? (alt-table? . -> . boolean?)) (atab-context (alt-table? . -> . pcontext?)) + (atab-min-errors (alt-table? . -> . (listof real?))) (split-atab (alt-table? (non-empty-listof any/c) . -> . (listof alt-table?))) (atab-new-context (alt-table? pcontext? . -> . alt-table?)))) @@ -32,7 +33,7 @@ (define (make-alt-table context initial-alt) (alt-table (make-immutable-hash (for/list ([(pt ex) (in-pcontext context)] - [err (alt-errors initial-alt)]) + [err (errors (alt-program initial-alt) context)]) (cons pt (point-rec err (list initial-alt))))) (hash initial-alt (for/list ([(pt ex) (in-pcontext context)]) pt)) @@ -43,18 +44,22 @@ (let* ([old-done (alt-table-alt->done? atab)] [alts (atab-all-alts atab)] [table-init (make-alt-table ctx (car alts))]) - (alt-table-with - (atab-add-altns table-init (cdr alts)) - #:alt->done? old-done))) + (struct-copy alt-table (atab-add-altns table-init (cdr alts)) + [alt->done? old-done]))) (define (atab-add-altns atab altns) - (for/fold ([atab atab]) ([altn altns]) + (define prog-set (map alt-program (hash-keys (alt-table-alt->points atab)))) + (define altns* + (filter + (negate (compose (curry set-member? prog-set) alt-program)) + (remove-duplicates altns #:key alt-program))) + (for/fold ([atab atab]) ([altn altns*]) (atab-add-altn atab altn))) (define (atab-pick-alt atab #:picking-func [pick car] #:only-fresh [only-fresh? #t]) (let* ([picked (atab-peek-alt atab #:picking-func pick #:only-fresh only-fresh?)] - [atab* (alt-table-with atab #:alt->done? (hash-set (alt-table-alt->done? atab) picked #t))]) + [atab* (struct-copy alt-table atab [alt->done? (hash-set (alt-table-alt->done? atab) picked #t)])]) (values picked atab*))) (define (atab-peek-alt atab #:picking-func [pick car] @@ -92,16 +97,6 @@ ;; Helper Functions -(define (alt-table-with atab - #:point->alts [pnt->alts #f] - #:alt->points [alt->pnts #f] - #:alt->done? [alt->done? #f] - #:context [pcontext #f]) - (alt-table (or pnt->alts (alt-table-point->alts atab)) - (or alt->pnts (alt-table-alt->points atab)) - (or alt->done? (alt-table-alt->done? atab)) - (or pcontext (alt-table-context atab)))) - (define (alternate . lsts) (let loop ([rest-lsts lsts] [acc '()]) (if (ormap null? rest-lsts) @@ -119,19 +114,17 @@ (struct point-rec (berr altns) #:prefab) -(define (best-and-tied-at-points point->alt altn) - (let-values ([(best tied) - (for/lists (best tied) - ([(pnt ex) (in-pcontext (*pcontext*))] - [err (alt-errors altn)]) - (let* ([pnt-rec (hash-ref point->alt pnt)] - [table-err (point-rec-berr pnt-rec)]) - (cond [(< err table-err) - (values pnt #f)] - [(= err table-err) - (values #f pnt)] - [else (values #f #f)])))]) - (list (filter identity best) (filter identity tied)))) +(define (best-and-tied-at-points atab altn errs) + (define point->alt (alt-table-point->alts atab)) + (for/fold ([best '()] [tied '()]) + ([(pnt ex) (in-pcontext (alt-table-context atab))] [err errs]) + (define table-err (point-rec-berr (hash-ref point->alt pnt))) + (cond + [(< err table-err) + (values (cons pnt best) tied)] + [(= err table-err) + (values best (cons pnt tied))] + [else (values best tied)]))) (define (remove-chnged-pnts point->alts alt->points chnged-pnts) (let* ([chnged-entries (map (curry hash-ref point->alts) chnged-pnts)] @@ -142,10 +135,9 @@ (remove* chnged-pnts (hash-ref alt->points altn))) chnged-altns)))) -(define (override-at-pnts points->alts pnts altn) - (let ([pnt->alt-err (make-immutable-hash (for/list ([(pnt ex) (in-pcontext (*pcontext*))] - [err (alt-errors altn)]) - (cons pnt err)))]) +(define (override-at-pnts points->alts pnts altn errs) + (let ([pnt->alt-err (for/hash ([(pnt ex) (in-pcontext (*pcontext*))] [err errs]) + (values pnt err))]) (hash-set-lsts points->alts pnts (map (λ (pnt) (point-rec (hash-ref pnt->alt-err pnt) (list altn))) @@ -177,7 +169,9 @@ ; There must always be a not-done tied alt, ; since before adding any alts there weren't any tied alts (let ([undone-altns (filter (compose not alts->done?) altns)]) - (argmin (compose length alts->pnts) (if (null? undone-altns) altns undone-altns))))) + (argmax + alt-cost + (argmins (compose length alts->pnts) (if (null? undone-altns) altns undone-altns)))))) (let loop ([cur-atab atab]) (let* ([alts->pnts (alt-table-alt->points cur-atab)] @@ -206,24 +200,28 @@ (alt-table pnts->alts* alts->pnts* alts->done?* (alt-table-context atab)))) (define (atab-add-altn atab altn) - (match-let* ([pnts->alts (alt-table-point->alts atab)] - [alts->pnts (alt-table-alt->points atab)] - [`(,best-pnts ,tied-pnts) (best-and-tied-at-points pnts->alts altn)]) - (if (null? best-pnts) - atab - (let* ([alts->pnts*1 (remove-chnged-pnts pnts->alts alts->pnts best-pnts)] - [alts->pnts*2 (hash-set alts->pnts*1 altn (append best-pnts tied-pnts))] - [pnts->alts*1 (override-at-pnts pnts->alts best-pnts altn)] - [pnts->alts*2 (append-at-pnts pnts->alts*1 tied-pnts altn)] - [alts->done?* (hash-set (alt-table-alt->done? atab) altn #f)] - [atab*1 (alt-table pnts->alts*2 alts->pnts*2 alts->done?* (alt-table-context atab))] - [atab*2 (minimize-alts atab*1)]) - atab*2)))) + (define errs (errors (alt-program altn) (alt-table-context atab))) + (match-define (alt-table point->alts alt->points _ _) atab) + (define-values (best-pnts tied-pnts) (best-and-tied-at-points atab altn errs)) + (cond + [(and (null? best-pnts) (null? tied-pnts)) + atab] + [else + (define alts->pnts*1 (remove-chnged-pnts point->alts alt->points best-pnts)) + (define alts->pnts*2 (hash-set alts->pnts*1 altn (append best-pnts tied-pnts))) + (define pnts->alts*1 (override-at-pnts point->alts best-pnts altn errs)) + (define pnts->alts*2 (append-at-pnts pnts->alts*1 tied-pnts altn)) + (define alts->done?* (hash-set (alt-table-alt->done? atab) altn #f)) + (minimize-alts (alt-table pnts->alts*2 alts->pnts*2 alts->done?* (alt-table-context atab)))])) (define (atab-not-done-alts atab) (filter (negate (curry hash-ref (alt-table-alt->done? atab))) (hash-keys (alt-table-alt->points atab)))) +(define (atab-min-errors atab) + (for/list ([(pt ex) (in-pcontext (alt-table-context atab))]) + (point-rec-berr (hash-ref (alt-table-point->alts atab) pt)))) + ;; The completeness invariant states that at any time, for every point there exists some ;; alt that is best at it. (define (check-completeness-invariant atab #:message [message ""]) diff --git a/src/core/egraph.rkt b/src/core/egraph.rkt index 94c580cb9..f53682904 100644 --- a/src/core/egraph.rkt +++ b/src/core/egraph.rkt @@ -1,14 +1,12 @@ #lang racket -(require "enode.rkt") -(require "../common.rkt") -(require "../syntax/syntax.rkt") +(require "../common.rkt" "../syntax/syntax.rkt" "../syntax/types.rkt" "enode.rkt") -(provide mk-enode! mk-egraph +(provide mk-enode! mk-enode-rec! mk-egraph merge-egraph-nodes! - egraph? egraph-cnt egraph-top - map-enodes draw-egraph egraph-leaders - elim-enode-loops! reduce-to-single! reduce-to-new! + egraph? egraph-cnt + draw-egraph egraph-leaders + elim-enode-loops! reduce-to-single! ) (provide (all-defined-out) @@ -24,7 +22,6 @@ ;;# ;;# The following things should always be true of egraphs: ;;# 1. (egraph-cnt eg) is a positive integer. -;;# 2. (egraph-top eg) is a valid enode. ;;# 3. For each enode en which is a key of leader->iexprs, en is the leader of ;;# its own pack. ;;# 4. For every mapping (k, v) in leader->iexprs, for each expression e in v, @@ -49,7 +46,7 @@ ;;################################################################################;; ;; Only ever use leaders as keys! -(struct egraph (cnt top leader->iexprs expr->parent) #:mutable) +(struct egraph (cnt leader->iexprs expr->parent) #:mutable) ;; For debugging (define (check-egraph-valid eg #:loc [location 'check-egraph-valid]) @@ -58,36 +55,34 @@ (assert (not (hash-has-key? leader->iexprs #f))) ;; The egraphs count must be a positive integer (assert (and (integer? count) (positive? count)) #:loc location) - ;; The top is a valid enode. (enode validity is verified upon creation). - (assert (enode? (egraph-top eg)) #:loc location) + ;; Verify properties 4-6 - (hash-for-each leader->iexprs - (λ (leader iexprs) - (assert (eq? leader (pack-leader leader)) #:loc location) - (assert (set-mutable? iexprs) #:loc location) - (for ([iexpr iexprs]) - (assert (list? iexpr) #:loc location) - (assert (for/or ([sub (cdr iexpr)]) - (eq? (pack-leader sub) leader)) - #:loc location) - (assert (for/and ([sub (cdr iexpr)]) - (eq? (pack-leader sub) sub))) - (assert (hash-has-key? (egraph-expr->parent eg) (update-en-expr iexpr)) #:loc location)))) + (for ([(leader iexprs) (in-hash leader->iexprs)]) + (assert (eq? leader (pack-leader leader)) #:loc location) + (assert (set-mutable? iexprs) #:loc location) + (for ([iexpr iexprs]) + (assert (list? iexpr) #:loc location) + (assert (for/or ([sub (cdr iexpr)]) + (eq? (pack-leader sub) leader)) + #:loc location) + (assert (for/and ([sub (cdr iexpr)]) + (eq? (pack-leader sub) sub))) + (assert (hash-has-key? (egraph-expr->parent eg) (update-en-expr iexpr)) #:loc location))) + ;; Verify property 7 - (hash-for-each (egraph-expr->parent eg) - (λ (k v) - ;; This line verifies that we didn't change the definition of hashing - ;; for some part of this expression without also refreshing the binding. - (assert (hash-has-key? (egraph-expr->parent eg) k) #:loc location) - - (when (list? k) - (for ([en (cdr k)]) - (assert (eq? en (pack-leader en)) #:loc location))))) + (for ([(k v) (in-hash (egraph-expr->parent eg))]) + ;; This line verifies that we didn't change the definition of hashing + ;; for some part of this expression without also refreshing the binding. + (assert (hash-has-key? (egraph-expr->parent eg) k) #:loc location) + (when (list? k) + (for ([en (cdr k)]) + (assert (eq? en (pack-leader en)) #:loc location)))) + ;; Verify property 8 (let loop ([seen (set)] [rest-leaders (hash-keys leader->iexprs)]) (let ([cur-leader-vars (enode-vars (car rest-leaders))]) (assert (for/and ([var cur-leader-vars]) - (or (number? var) (symbol? var) (list? var)))) + (or (value? var) (symbol? var) (list? var)))) (assert (set-empty? (set-intersect (set-copy-clear seen) cur-leader-vars))) (when (not (null? (cdr rest-leaders))) (loop (set-union cur-leader-vars seen) (cdr rest-leaders))))))) @@ -97,7 +92,7 @@ ;; of the graph to indicate the addition, or if the expression already exists ;; in the egraph it returns the node associated with it. While the node exists ;; after this call, if we are creating a new node it still must be merged into -;; an existing node or otherwise attached to the (egraph-top eg) node to be +;; an existing node or otherwise attached to some node to be ;; completely added to the egraph. (define (mk-enode! eg expr) (if (hash-has-key? (egraph-expr->parent eg) expr) @@ -111,7 +106,7 @@ (set-egraph-cnt! eg (add1 (egraph-cnt eg))) (hash-set! leader->iexprs en (mutable-set)) (when (list? expr*) - (for ([suben (cdr expr*)]) + (for ([suben (in-list (cdr expr*))]) (set-add! (hash-ref leader->iexprs (pack-leader suben)) expr*))) (hash-set! (egraph-expr->parent eg) @@ -128,22 +123,17 @@ ;; Takes a plain mathematical expression, quoted, and returns the egraph ;; representing that expression with no expansion or saturation. -(define (mk-egraph expr) - (let ([eg (egraph 0 #f (make-hash) (make-hash))]) - (set-egraph-top! eg (mk-enode-rec! eg expr)) - ;; This is an expensive check, but useful for debuggging. - #;(check-egraph-valid eg #:loc 'constructing-egraph) - eg)) - -;; Maps a given function over all the equivilency classes -;; of a given egraph (node packs). -(define (map-enodes f eg) - (map f (egraph-leaders eg))) +(define (mk-egraph) + (egraph 0 (make-hash) (make-hash))) ;; Gets all the pack leaders in the egraph (define (egraph-leaders eg) (hash-keys (egraph-leader->iexprs eg))) +(define (dedup-vars! en) + (update-vars! (pack-leader en) update-en-expr) + (dedup-children! en)) + ;; Given an egraph and two enodes present in that egraph, merge the ;; packs of those two nodes, so that those nodes return the same ;; pack-leader and enode-vars. The keys of leader->iexprs and @@ -151,67 +141,70 @@ ;; the leaders of en1 and en2, but the values of those mapping are ;; not. (define (merge-egraph-nodes! eg en1 en2) - (let ([leader->iexprs (egraph-leader->iexprs eg)] - [expr->parent (egraph-expr->parent eg)] - ;; Operate on the pack leaders in case we were passed a non-leader - [l1 (pack-leader en1)] - [l2 (pack-leader en2)]) + (match-define (egraph _ leader->iexprs expr->parent) eg) + ;; Operate on the pack leaders in case we were passed a non-leader + (define l1 (pack-leader en1)) + (define l2 (pack-leader en2)) + + (cond + [(eq? l1 l2) ;; If the leaders are the same, then these nodes are already part ;; of the same pack. However, this call usually means that two ;; vars of this leader were found equivalent through another ;; merge, so we want to update the vars to remove the redundancy. - (if (eq? l1 l2) (update-vars! l1 update-en-expr) - (let*-values (;; Hold on to these vars as they won't be the - ;; same after the merge, but we don't yet know - ;; which one we need. - [(old-vars1) (enode-vars l1)] - [(old-vars2) (enode-vars l2)] - ;; Merge the node packs - [(merged-en) (enode-merge! l1 l2)] - ;; Now that we know which one became leader, we - ;; can bind these. - [(leader follower follower-old-vars) - (if (eq? l1 merged-en) - (values l1 l2 old-vars1) - (values l2 l1 old-vars2))] - ;; Get the expressions which mention the - ;; follower so we can see if their new form - ;; causes new merges. - [(iexprs) (hash-ref leader->iexprs follower)]) - ;; Once we've merged these enodes, other ones might - ;; have become equivalent. For example, if we had an - ;; enode which had the variation (+ x 1), and an - ;; enode which had the variation (+ y 1), and we - ;; merged x and y, then we know that these two - ;; enodes are equivalent, and should be merged. - (define to-merge - (for/append ([iexpr iexprs]) - (let* ([replaced-iexpr (update-en-expr iexpr)] - [other-parent (hash-ref expr->parent replaced-iexpr #f)]) - (if other-parent (list (cons other-parent (hash-ref expr->parent iexpr))) - '())))) - ;; Now that we have extracted all the information we - ;; need from the egraph maps in their current state, we - ;; are ready to update them. We need to know which one - ;; is the old leader, and which is the new to easily do - ;; this, so we branch on which one is eq? to merged-en. - (update-leader! eg follower-old-vars follower leader) - ;; Now the state is consistent for this merge, so we can - ;; tackle the other merges. - (for ([node-pair to-merge]) - (merge-egraph-nodes! eg (car node-pair) (cdr node-pair))) - ;; The other merges can have caused new things to merge - ;; with our merged-en from before (due to loops in the - ;; egraph), so we turn this into a leader before finally - ;; returning it. - (pack-leader merged-en))))) - -(define (mutable-set-remove-duplicates st) - (list->mutable-set (set->list st))) + (dedup-vars! l1)] + [else + ;; Hold on to these vars as they won't be the same after the + ;; merge, but we don't yet know which one we need. + (define old-vars1 (enode-vars l1)) + (define old-vars2 (enode-vars l2)) + + ;; Merge the node packs + (define merged-en (enode-merge! l1 l2)) + + ;; Now that we know which one became leader, we can bind these. + (define-values (leader follower follower-old-vars) + (if (eq? l1 merged-en) + (values l1 l2 old-vars2) + (values l2 l1 old-vars1))) + + ;; Get the expressions which mention the follower so we can see if + ;; their new form causes new merges. + (define iexprs (hash-ref leader->iexprs follower)) + + ;; Once we've merged these enodes, other ones might have become + ;; equivalent. For example, if we had an enode which had the + ;; variation (+ x 1), and an enode which had the variation (+ y + ;; 1), and we merged x and y, then we know that these two enodes + ;; are equivalent, and should be merged. + (define to-merge + (for/append ([iexpr (in-mutable-set iexprs)]) + (define replaced-iexpr (update-en-expr iexpr)) + (define other-parent (hash-ref expr->parent replaced-iexpr #f)) + (if other-parent + (list (cons other-parent (hash-ref expr->parent iexpr))) + '()))) + + ;; Now that we have extracted all the information we need from the + ;; egraph maps in their current state, we are ready to update + ;; them. We need to know which one is the old leader, and which is + ;; the new to easily do this, so we branch on which one is eq? to + ;; merged-en. + (update-leader! eg follower-old-vars follower leader) + + ;; Now the state is consistent for this merge, so we can tackle + ;; the other merges. + (for ([node-pair (in-list to-merge)]) + (merge-egraph-nodes! eg (car node-pair) (cdr node-pair))) + + ;; The other merges can have caused new things to merge with our + ;; merged-en from before (due to loops in the egraph), so we turn + ;; this into a leader before finally returning it. + (pack-leader merged-en)])) (define (update-en-expr expr) (if (list? expr) - (for/list ([sub expr]) + (for/list ([sub (in-list expr)]) (if (enode? sub) (pack-leader sub) sub)) expr)) @@ -220,17 +213,17 @@ (let* ([changed-exprs (hash-ref (egraph-leader->iexprs eg) old-leader)]) (set-union! (hash-ref! (egraph-leader->iexprs eg) new-leader (mutable-set)) changed-exprs) - (for ([ch-expr changed-exprs]) - (for ([suben (cdr ch-expr)]) + (for ([ch-expr (in-mutable-set changed-exprs)]) + (for ([suben (in-list (cdr ch-expr))]) (hash-update! (egraph-leader->iexprs eg) (pack-leader suben) (λ (st) - (for/mutable-set ([expr st]) + (for/mutable-set ([expr (in-mutable-set st)]) (update-en-expr expr))))) (let ([old-binding (hash-ref (egraph-expr->parent eg) ch-expr)]) (hash-remove! (egraph-expr->parent eg) ch-expr) (hash-set! (egraph-expr->parent eg) (update-en-expr ch-expr) (update-en-expr old-binding)))) (hash-remove! (egraph-leader->iexprs eg) old-leader) - (for ([variation old-vars]) + (for ([variation (in-set old-vars)]) (hash-set! (egraph-expr->parent eg) (update-en-expr variation) new-leader))))) @@ -323,10 +316,10 @@ ;; If there are any variations of this enode that are a single ;; constant or variable, prune to that. (define (reduce-to-single! eg en) - (when (for/or ([var (enode-vars en)]) + (when (for/or ([var (in-set (enode-vars en))]) (or (constant? var) (variable? var))) (let* ([leader (pack-leader en)] - [old-vars (for/mutable-set ([var (enode-vars leader)]) + [old-vars (for/mutable-set ([var (in-set (enode-vars leader))]) (update-en-expr var))] [leader* (pack-filter! (λ (inner-en) (not (list? (enode-expr inner-en)))) @@ -334,48 +327,33 @@ (when (not (eq? leader leader*)) (update-leader! eg old-vars leader leader*))))) -(define (reduce-to-new! eg en expr) - (unless true - (let* ([new-en (mk-enode-rec! eg expr)] - [vars (enode-vars en)] - [leader (merge-egraph-nodes! eg en new-en)]) - (hash-update! (egraph-leader->iexprs eg) - leader - (λ (st) - (for/mutable-set ([expr st]) - (update-en-expr expr)))) - (let ([leader* (pack-filter! (λ (inner-en) - (equal? (enode-expr inner-en) (enode-expr new-en))) - leader)]) - (update-leader! eg vars leader leader*))))) - ;; Draws a representation of the egraph to the output file specified ;; in the DOT format. (define (draw-egraph eg fp) (with-output-to-file fp #:exists 'replace (λ () - (displayln "digraph {") + (printf "digraph {\n") (for ([en (egraph-leaders eg)]) - (let ([id (enode-pid en)]) - (printf "node~a[label=\"NODE ~a\"]~n" id id) - (for ([varen (remove-duplicates (pack-members en) #:key enode-expr)] - [vid (in-naturals)]) - (let ([var (enode-expr varen)]) - (printf "node~avar~a[label=\"~a\",shape=box,color=blue]~n" - id vid (if (list? var) (car var) var)) - (printf "node~a -> node~avar~a[style=dashed]~n" - id id vid) - (cond - [(not (list? var)) (void)] - [(= (length var) 2) - (printf "node~avar~a -> node~a~n" - id vid (enode-pid (second var)))] - [(= (length var) 3) - (printf "node~avar~a -> node~a[tailport=sw]~n" - id vid (enode-pid (second var))) - (printf "node~avar~a -> node~a[tailport=se]~n" - id vid (enode-pid (third var)))]))))) - (displayln "}"))) - (system (format "dot -Tpng -o ~a.png ~a" fp fp)) - (system (format "feh ~a.png" fp))) + (define id (enode-pid en)) + + (printf "node~a[label=\"NODE ~a\"]\n" id id) + (for ([varen (pack-members en)] [vid (in-naturals)]) + (define var (enode-expr varen)) + (printf "node~avar~a[label=\"~a\",shape=box,color=blue]\n" + id vid (if (list? var) (car var) var)) + (printf "node~a -> node~avar~a[style=dashed]\n" + id id vid) + (when (list? var) + (define n (length (cdr var))) + (for ([arg (cdr var)] [i (in-naturals)]) + (printf "node~avar~a -> node~a[tailport=~a]\n" + id vid + (enode-pid arg) + (cond + [(= i 0) "sw"] + [(= i (- n 1)) "se"] + [else "s"]) + ))))) + (printf "}\n"))) + (system (format "dot -Tpng -o ~a.png ~a" fp fp))) diff --git a/src/core/ematch.rkt b/src/core/ematch.rkt index 1f6febc26..ce34366b0 100644 --- a/src/core/ematch.rkt +++ b/src/core/ematch.rkt @@ -17,13 +17,6 @@ ;;# ;;################################################################################;; -(define (list-cartesian-product . lsts) - (if (null? lsts) - '(()) - (let ([tails (apply list-cartesian-product (cdr lsts))]) - (for*/list ([elt (car lsts)] [tail tails]) - (cons elt tail))))) - (define (merge . bindings) ;; (list bindings) -> binding (foldl merge2 '() bindings)) @@ -61,7 +54,7 @@ (= (length var) (length pat))) (filter identity (map (curry apply merge) - (apply list-cartesian-product + (apply cartesian-product (for/list ([subpat (in-list (cdr pat))] [sube (in-list (cdr var))]) (match-e subpat sube))))) '())))] diff --git a/src/core/enode.rkt b/src/core/enode.rkt index 387831905..0c74eed9e 100644 --- a/src/core/enode.rkt +++ b/src/core/enode.rkt @@ -1,8 +1,6 @@ #lang racket -(require "../common.rkt") -(require "../syntax/syntax.rkt") -(require "../type-check.rkt") +(require "../common.rkt" "../syntax/syntax.rkt" "../syntax/types.rkt" "../type-check.rkt" "../float.rkt") (provide new-enode enode-merge! enode-vars refresh-vars! enode-pid @@ -13,6 +11,7 @@ enode-subexpr? pack-filter! for-pack! pack-removef! set-enode-expr! update-vars! + dedup-children! ) (provide (all-defined-out)) @@ -69,15 +68,14 @@ (match expr [(? real?) 'real] [(? complex?) 'complex] + [(? value?) (infer-representation expr)] [(? constant?) (constant-info expr 'type)] - [(? variable?) 'real] + [(? variable?) 'real] ;; TODO: assumes variable types are real + [(list 'if cond ift iff) + (enode-type ift)] [(list op ens ...) - (define sigs (get-sigs op (length ens))) - (define argtypes - (for/list ([en ens]) - (enode-type en))) - (for/or ([sig sigs]) - (argtypes->rtype argtypes sig))])) + ;; Assumes single return type for any function + (second (first (first (hash-values (operator-info op 'type)))))])) (module+ test (require rackunit) @@ -87,7 +85,7 @@ (check-equal? (type-of-enode-expr (enode-expr xplusy)) 'real) (define xc (new-enode '1+2i 1)) (define yc (new-enode '2+3i 2)) - (define xcplusyc (new-enode (list '+ xc yc) 3)) + (define xcplusyc (new-enode (list '+.c xc yc) 3)) (check-equal? (type-of-enode-expr (enode-expr xcplusyc)) 'complex)) @@ -144,7 +142,7 @@ (let ([filtered-children (filter identity - (for/list ([child (enode-children en)]) + (for/list ([child (in-list (enode-children en))]) (let ([child* (filter-loop! child)]) (or child* (begin (set-enode-parent! child en) #f)))))]) @@ -197,7 +195,10 @@ (map enode-cvars (enode-children en)))) en))) -;; Updates the expressions in the pack, using s specified updater. +(define (dedup-children! en) + (set-enode-children! en (remove-duplicates (enode-children en) #:key enode-expr))) + +;; Updates the expressions in the pack, using a specified updater. (define (update-vars! en updater) (for-pack! (λ (inner-en) (set-enode-expr! inner-en (updater (enode-expr inner-en)))) @@ -206,9 +207,9 @@ (define (check-valid-enode en #:loc [location 'check-valid-enode]) ;; Checks that the enodes expr field is well formed. (let ([expr (enode-expr en)]) - (assert (or (number? expr) (symbol? expr) + (assert (or (value? expr) (symbol? expr) (and (list? expr) (symbol? (car expr)) - (ormap enode? (cdr expr)))) #:loc location)) + (andmap enode? (cdr expr)))) #:loc location)) ;; Checks that the depth is positive. (assert (positive? (enode-depth en)) #:loc location)) diff --git a/src/core/localize.rkt b/src/core/localize.rkt index 1984a962c..0f03fb4fb 100644 --- a/src/core/localize.rkt +++ b/src/core/localize.rkt @@ -1,14 +1,10 @@ #lang racket -(require math/flonum) -(require math/bigfloat) -(require "../common.rkt") -(require "../points.rkt") -(require "../float.rkt") -(require "../programs.rkt") -(require "../alternative.rkt") +(require math/flonum math/bigfloat) +(require "../common.rkt" "../points.rkt" "../float.rkt" "../programs.rkt" "../alternative.rkt") +(require "../interface.rkt" "../type-check.rkt") -(provide localize-error *analyze-context*) +(provide localize-error) (define (repeat c) (for/list ([(p e) (in-pcontext (*pcontext*))]) @@ -18,13 +14,18 @@ (define *analyze-context* (make-parameter #f)) (define (localize-on-expression expr vars cache) + (define ctx + (for/hash ([(var vals) (in-dict vars)]) + (values var (match (representation-name (infer-representation (first vals))) + [(or 'binary32 'binary64) 'real] + [x x])))) (hash-ref! cache expr (λ () (match expr [(? constant?) (cons (repeat (->bf expr)) (repeat 1))] [(? variable?) - (cons (map ->bf (cdr (assoc expr vars))) (repeat 1))] + (cons (map ->bf (dict-ref vars expr)) (repeat 1))] [`(if ,c ,ift ,iff) (let ([exact-ift (car (localize-on-expression ift vars cache))] [exact-iff (car (localize-on-expression iff vars cache))] @@ -33,16 +34,25 @@ (cons (for/list ([c exact-cond] [t exact-ift] [f exact-iff]) (if c t f)) (repeat 1)))] [`(,f ,args ...) - (let* ([argvals - (flip-lists (map (compose car (curryr localize-on-expression vars cache)) args))] - [f-exact (operator-info f 'bf)] - [f-approx (operator-info f 'fl)] - [exact (map (curry apply f-exact) argvals)] - [approx (map (compose (curry apply f-approx) (curry map ->flonum)) argvals)] - [error - (map (λ (ex ap) (+ 1 (abs (ulp-difference (->flonum ex) - (->flonum ap))))) exact approx)]) - (cons exact error))])))) + (define <-bf (representation-bf->repr (get-representation* (type-of expr ctx)))) + (define arg<-bfs + (for/list ([arg args]) + (representation-bf->repr (get-representation* (type-of arg ctx))))) + + (define argexacts + (flip-lists (map (compose car (curryr localize-on-expression vars cache)) args))) + (define argapprox + (for/list ([pt argexacts]) + (for/list ([val pt] [arg<-bf arg<-bfs]) (arg<-bf val)))) + + (define exact (map (curry apply (operator-info f 'bf)) argexacts)) + (define approx (map (curry apply (operator-info f 'fl)) argapprox)) + (cons exact (map (λ (ex ap) (+ 1 (abs (ulp-difference (<-bf ex) ap)))) exact approx))])))) + +(register-reset + (λ () + (*analyze-context* (*pcontext*)) + (hash-clear! *analyze-cache*))) (define (localize-error prog) (define varmap (map cons (program-variables prog) @@ -64,7 +74,6 @@ (when (ormap (curry < 1) err) (for-each (compose sow (curry cons err)) locs))))) - (map cdr - (take-up-to - (sort locs > #:key (compose errors-score car)) - (*localize-expressions-limit*)))) + (take-up-to + (sort locs > #:key (compose errors-score car)) + (*localize-expressions-limit*))) diff --git a/src/core/matcher.rkt b/src/core/matcher.rkt index 28e619c4d..2b6877c12 100644 --- a/src/core/matcher.rkt +++ b/src/core/matcher.rkt @@ -1,86 +1,58 @@ #lang racket -(require "../common.rkt") -(require "../programs.rkt") -(require "../syntax/rules.rkt") -(require "../type-check.rkt") +(require "../common.rkt" "../timeline.rkt" "../programs.rkt") +(require "../syntax/rules.rkt" "../type-check.rkt") (provide (all-from-out "../syntax/rules.rkt") - pattern-substitute pattern-match + pattern-match rewrite-expression-head rewrite-expression - (struct-out change) change-apply changes-apply rule-rewrite) - -;; Our own pattern matcher. -; -; The racket (match) macro doesn't give us access to the bindings made -; by the matcher, so we wrote our own. -; -; The syntax is simple: -; numbers are literals ; symbols are variables ; lists are expressions -; -; Bindings are stored as association lists - -(define (merge-bindings . bindings) - ; (list bindings) -> binding - (foldl merge-2-bindings '() bindings)) - -(define (merge-2-bindings binding1 binding2) + (struct-out change) change-apply rule-rewrite) + +;;; Our own pattern matcher. +;; +;; The racket (match) macro doesn't give us access to the bindings made +;; by the matcher, so we wrote our own. +;; +;; The syntax is simple: +;; numbers are literals ; symbols are variables ; lists are expressions +;; +;; Bindings are stored as association lists + +(define (merge-bindings binding1 binding2) (define (fail . irr) #f) - - ; binding binding -> binding - (if (and binding1 binding2) - (let loop ([acc binding1] [rest binding2]) - (if (null? rest) - acc - (let* ([curr (car rest)] - [lookup (assoc (car curr) acc)]) - (if lookup - (if (equal? (cdr lookup) (cdr curr)) - (loop acc (cdr rest)) - (fail "pattern-match: Variable has two different bindings" - (car curr) (cdr lookup) (cdr curr))) - (loop (cons curr acc) (cdr rest)))))) - #f)) - -; The matcher itself + (and binding1 + binding2 + (let/ec quit + (for/fold ([binding binding1]) ([(k v) (in-dict binding2)]) + (dict-update binding k (λ (x) (if (equal? x v) v (quit #f))) v))))) (define (pattern-match pattern expr) - ; pattern expr -> bindings - (define (fail . irr) #f) - (cond - [(constant? pattern) - (if (and (constant? expr) (equal? pattern expr)) - '() - (fail "pattern-match: Literals do not match" - pattern expr))] - [(variable? pattern) + (match pattern + [(? constant?) + (and (equal? pattern expr) '())] + [(? variable?) (list (cons pattern expr))] - ; TODO : test for allowed operators - [(list? pattern) - (if (and (list? expr) (eq? (car expr) (car pattern)) - (= (length expr) (length pattern))) - (apply merge-bindings - (for/list ([pat (cdr pattern)] [subterm (cdr expr)]) - (pattern-match pat subterm))) - (fail "pattern-match: Not a list, or wrong length, or wrong operator." - "Don't ask me, I don't know!" - pattern expr))] - [#t (fail "pattern-match: Confused by pattern term" pattern)])) + [(list phead _ ...) + (and (list? expr) + (equal? (car expr) phead) + (= (length expr) (length pattern)) + (for/fold ([bindings '()]) + ([pat (cdr pattern)] [subterm (cdr expr)]) + (merge-bindings bindings (pattern-match pat subterm))))])) (define (pattern-substitute pattern bindings) ; pattern binding -> expr - (cond - [(constant? pattern) pattern] - [(variable? pattern) - (cdr (assoc pattern bindings))] - [(list? pattern) - (cons (car pattern) - (for/list ([pat (cdr pattern)]) - (pattern-substitute pat bindings)))] - [#t (error "pattern-substitute: Confused by pattern term" pattern)])) + (match pattern + [(? constant?) pattern] + [(? variable?) + (dict-ref bindings pattern)] + [(list phead pargs ...) + (cons phead (map (curryr pattern-substitute bindings) pargs))])) + +;; Random helper functions (define (rule-apply rule expr) (let ([bindings (pattern-match (rule-input rule) expr)]) @@ -95,115 +67,81 @@ [(cons out bindings) out] [#f (return #f)]))))) -(define (rule-apply-force-destructs rule expr) - (and (not (symbol? (rule-input rule))) (rule-apply rule expr))) - -(struct change (rule location bindings) #:transparent - #:methods gen:custom-write - [(define (write-proc cng port mode) - (display "#" port))]) +(define (change-apply cng prog) + (match-define (change rule location bindings) cng) + (location-do location prog (const (pattern-substitute (rule-output rule) bindings)))) + +(struct change (rule location bindings) #:transparent) + +;; The rewriter (define (rewrite-expression expr #:destruct [destruct? #f] #:root [root-loc '()]) (define env (for/hash ([v (free-variables expr)]) (values v 'real))) + (define type (type-of expr env)) (reap [sow] - ; TODO: don't recompute the type of every expression - (for ([rule (if (equal? 'complex (type-of expr env)) (*complex-rules*) (*rules*))]) - (let* ([applyer (if destruct? rule-apply-force-destructs rule-apply)] - [result (applyer rule expr)]) + (for ([rule (*rules*)] #:when (equal? type (rule-otype rule))) + (let* ([result (rule-apply rule expr)]) (when result - (sow (change rule root-loc (cdr result)))))))) + (sow (list (change rule root-loc (cdr result))))))))) (define (rewrite-expression-head expr #:root [root-loc '()] #:depth [depth 1]) - (define env (for/hash ([v (free-variables expr)]) (values v 'real))) - (define (rewriter expr ghead glen loc cdepth) + (define type (type-of expr env)) + (define (rewriter sow expr ghead glen loc cdepth) ; expr _ _ _ _ -> (list (list change)) - (reap (sow) - (for ([rule (if (equal? 'complex (type-of expr env)) (*complex-rules*) (*rules*))]) - (when (or - (not ghead) ; Any results work for me - (and - (list? (rule-output rule)) - (= (length (rule-output rule)) glen) - (eq? (car (rule-output rule)) ghead))) - (let ([options (matcher expr (rule-input rule) loc (- cdepth 1))]) - (for ([option options]) - ; Each option is a list of change lists - (sow (cons (change rule (reverse loc) (cdr option)) - (car option))))))))) - - (define (reduce-children options) + (for ([rule (*rules*)] #:when (equal? type (rule-otype rule))) + (when (or + (not ghead) ; Any results work for me + (and + (list? (rule-output rule)) + (= (length (rule-output rule)) glen) + (eq? (car (rule-output rule)) ghead))) + (for ([option (matcher expr (rule-input rule) loc (- cdepth 1))]) + ;; Each option is a list of change lists + (sow (cons (change rule (reverse loc) (cdr option)) (car option))))))) + + (define (reduce-children sow options) ; (list (list ((list change) * bindings))) ; -> (list ((list change) * bindings)) - (reap (sow) - (for ([children options]) - (let ([bindings* (apply merge-bindings (map cdr children))]) - (when bindings* - (sow (cons (apply append (map car children)) bindings*))))))) - - (define (fix-up-variables pattern options) - ; pattern (list (list change)) -> (list (list change) * pattern) - (reap (sow) - (for ([cngs options]) - (let* ([out-pattern (rule-output (change-rule (car cngs)))] - [result (pattern-substitute out-pattern - (change-bindings (car cngs)))] - [bindings* (pattern-match pattern result)]) - (when bindings* - (sow (cons cngs bindings*))))))) + (for ([children options]) + (let ([bindings* (foldl merge-bindings '() (map cdr children))]) + (when bindings* + (sow (cons (apply append (map car children)) bindings*)))))) + + (define (fix-up-variables sow pattern cngs) + ; pattern (list change) -> (list change) * bindings + (match-define (change rule loc bindings) (car cngs)) + (define result (pattern-substitute (rule-output rule) bindings)) + (define bindings* (pattern-match pattern result)) + (when bindings* (sow (cons cngs bindings*)))) (define (matcher expr pattern loc cdepth) ; expr pattern _ -> (list ((list change) * bindings)) - (cond - [(variable? pattern) - ; Do nothing, bind variable - (list (cons '() (list (cons pattern expr))))] - [(constant? pattern) - (if (and (constant? expr) (equal? expr pattern)) - '((()) . ()) ; Do nothing, bind nothing - '())] ; No options - [(and (list? expr) (list? pattern)) - (if (and (eq? (car pattern) (car expr)) - (= (length pattern) (length expr))) - ; Everything is terrible - (reduce-children - (apply cartesian-product ; (list (list ((list cng) * bnd))) - (for/list ([i (in-naturals)] [sube expr] [subp pattern] - #:when (> i 0)) ; (list (list ((list cng) * bnd))) - ;; Note: we reset the fuel to "depth", not "cdepth" - (matcher sube subp (cons i loc) depth)))) ; list (expr * pattern) - (if (> cdepth 0) - ; Sort of a brute force approach to getting the bindings - (fix-up-variables - pattern - (rewriter expr (car pattern) (length pattern) loc (- cdepth 1))) - '()))] - [(and (list? pattern) (not (list? expr))) - '()] - [else - (error "Unknown pattern" pattern)])) - - ; The #f #f mean that any output result works. It's a bit of a hack - (rewriter expr #f #f (reverse root-loc) depth)) - -(define (change-apply cng prog) - (let ([loc (change-location cng)] - [template (rule-output (change-rule cng))] - [bnd (change-bindings cng)]) - (location-do loc prog (λ (expr) (pattern-substitute template bnd))))) - -(define (changes-apply chngs prog) - (for/fold ([prog prog]) ([chng chngs]) - (change-apply chng prog))) + (reap [sow] + (match pattern + [(? variable?) + (sow (cons '() (list (cons pattern expr))))] + [(? constant?) + (when (equal? expr pattern) + (sow (cons '() '())))] + [(list phead _ ...) + (when (and (list? expr) (equal? phead (car expr)) + (= (length pattern) (length expr))) + (let/ec k ;; We have an option to early exit if a child pattern cannot be matched + (define child-options ; (list (list ((list cng) * bnd))) + (for/list ([i (in-naturals)] [sube expr] [subp pattern] #:when (> i 0)) + ;; Note: fuel is "depth" not "cdepth", because we're recursing to a child + (define options (matcher sube subp (cons i loc) depth)) + (when (null? options) (k)) ;; Early exit + options)) + (reduce-children sow (apply cartesian-product child-options)))) + + (when (and (> cdepth 0) + (or (flag-set? 'generate 'better-rr) + (not (and (list? expr) (equal? phead (car expr)) (= (length pattern) (length expr)))))) + ;; Sort of a brute force approach to getting the bindings + (rewriter (curry fix-up-variables sow pattern) + expr (car pattern) (length pattern) loc (- cdepth 1)))]))) + + ;; The "#f #f" means that any output result works. It's a bit of a hack + (reap [sow] (rewriter (compose sow reverse) expr #f #f (reverse root-loc) depth))) diff --git a/src/core/periodicity.rkt b/src/core/periodicity.rkt index 5e9c761fb..d2bef6979 100644 --- a/src/core/periodicity.rkt +++ b/src/core/periodicity.rkt @@ -61,7 +61,7 @@ [special special] [(andmap constant-value? (cdr expr)) (annotation expr loc 'constant - (common-eval (cons (car expr) (map coeffs (cdr expr)))))] + (eval-const-expr (cons (car expr) (map coeffs (cdr expr)))))] [(and (andmap periodic? (cdr expr)) (= 3 (length expr))) (annotation expr loc 'interesting (apply alist-merge lcm @@ -184,9 +184,10 @@ (if (or (> (apply max (map cdr (lp-periods ploc))) *max-period-coeff*)) altn (let ([context - (prepare-points-period + (prepare-points program - (map (compose (curry * 2 pi) cdr) (lp-periods ploc)))]) + `(and ,@(for/list ([(var period) (lp-periods ploc)]) + `(<= 0 ,var ,(* 2 pi var)))))]) (parameterize ([*pcontext* context]) (improve-func (make-alt program))))))) plocs)] @@ -199,19 +200,23 @@ (location-do (lp-loc ploc) prog (const oexpr)))]) (debug #:from 'periodicity "Periodicity result: " final-prog) (if (not (null? oalts)) - (alt-event final-prog 'periodicity (cons altn oalts)) + (alt final-prog 'periodicity (cons altn oalts)) altn))) (define (symbol-mod v periods) - (if (assoc v periods) - (let ([coeff (cdr (assoc v periods))]) + (if (dict-has-key? periods v) + (let ([coeff (dict-ref periods v)]) `(mod ,v ,(if (= 1/2 coeff) 'PI `(* ,(* 2 coeff) PI)))) v)) +(define (replace-vars vars expr periods) + (for/fold ([expr expr]) ([var vars]) + (replace-expression expr var (symbol-mod var periods)))) + (define (coerce-conditions prog periods) (let loop ([cur-body (program-body prog)]) (match cur-body [`(if ,cond ,a ,b) - `(if ,(replace-leaves cond #:variable (curryr symbol-mod periods)) + `(if ,(replace-vars (program-variables prog) cond periods) ,(loop a) ,(loop b))] [_ cur-body]))) diff --git a/src/core/reduce.rkt b/src/core/reduce.rkt index 8e3c27559..8d414ff1b 100755 --- a/src/core/reduce.rkt +++ b/src/core/reduce.rkt @@ -38,9 +38,7 @@ [`(lambda ,vars ,body) `(λ ,vars ,(simplify* body))] [(? (compose null? free-variables) `(,op ,args ...)) - (let ([value - (with-handlers ([(const #t) (const #f)]) - (common-eval expr))]) + (let ([value (with-handlers ([(const #t) (const #f)]) (eval-const-expr expr))]) (if (and (number? value) (real? value) (exact? value)) value (simplify-node `(,op ,@(map simplify* args)))))] @@ -53,7 +51,7 @@ [(? variable?) expr] [(or `(+ ,_ ...) `(- ,_ ...)) (make-addition-node (combine-aterms (gather-additive-terms expr)))] - [(or `(* ,_ ...) `(/ ,_ ...) `(sqr ,_) `(sqrt ,_)) + [(or `(* ,_ ...) `(/ ,_ ...) `(sqrt ,_) `(cbrt ,_)) (make-multiplication-node (combine-mterms (gather-multiplicative-terms expr)))] [`(exp (* ,c (log ,x))) `(pow ,x ,c)] @@ -100,8 +98,6 @@ (list* (car term) (simplify-node (list* '/ (cadr term) args)) (cons label (cddr term))))) `((1 ,expr)))] - [`(sqr ,arg) - (recurse `(* ,arg ,arg) #:label expr)] [`(pow ,arg ,(? integer? n)) (cond [(positive? n) @@ -132,11 +128,6 @@ (cons (if (ormap (compose (curry = 0) car) dens) +nan.0 (apply / (car num) (map car dens))) (append (cdr num) (map negate-term (append-map cdr dens)))))] - [`(sqr ,arg) - (let ([terms (gather-multiplicative-terms arg)]) - (cons (sqr (car terms)) - (for/list ([term (cdr terms)]) - (cons (* 2 (car term)) (cdr term)))))] [`(sqrt ,arg) (let ([terms (gather-multiplicative-terms arg)]) (cond @@ -151,6 +142,19 @@ (cons 1 `(sqrt ,(car terms))) (for/list ([term (cdr terms)]) (cons (/ (car term) 2) (cdr term))))]))] + [`(cbrt ,arg) + (let ([terms (gather-multiplicative-terms arg)]) + (define head-cbrt (expt (car terms) 1/3)) + (cond + [(equal? (expt (inexact->exact head-cbrt) 3) (car terms)) + (cons head-cbrt + (for/list ([term (cdr terms)]) + (cons (/ (car term) 3) (cdr term))))] + [else + (list* 1 + (cons 1 `(cbrt ,(car terms))) + (for/list ([term (cdr terms)]) + (cons (/ (car term) 3) (cdr term))))]))] [`(pow ,arg ,(? real? a)) (let ([terms (gather-multiplicative-terms arg)]) (cond diff --git a/src/core/regimes.rkt b/src/core/regimes.rkt index 72ec96bae..da45cea1b 100644 --- a/src/core/regimes.rkt +++ b/src/core/regimes.rkt @@ -1,53 +1,70 @@ #lang racket -(require "../common.rkt") -(require "../config.rkt") -(require "../alternative.rkt") -(require "../programs.rkt") -(require "../points.rkt") -(require "../float.rkt") -(require "../syntax/syntax.rkt") -(require "matcher.rkt") -(require "localize.rkt") -(require "../type-check.rkt") +(require "../common.rkt" "../alternative.rkt" "../programs.rkt" "../timeline.rkt") +(require "../type-check.rkt" "../syntax/types.rkt") +(require "../points.rkt" "../float.rkt") ; For binary search +(require (submod "../timeline.rkt" debug)) (module+ test (require rackunit)) -(provide infer-splitpoints (struct-out sp) splitpoints->point-preds) +(provide infer-splitpoints (struct-out sp) splitpoints->point-preds combine-alts) -(define (infer-splitpoints alts [axis #f]) - (match alts - [(list alt) - (list (list (sp 0 0 +nan.0)) (list alt))] - [_ - (debug "Finding splitpoints for:" alts #:from 'regime-changes #:depth 2) - (define options - (map (curry option-on-expr alts) - (if axis (list axis) (exprs-to-branch-on alts)))) - (define best-option (argmin (compose errors-score option-errors) options)) - (define splitpoints (option-splitpoints best-option)) - (define altns (used-alts splitpoints alts)) - (define splitpoints* (coerce-indices splitpoints)) - (debug #:from 'regimes "Found splitpoints:" splitpoints* ", with alts" altns) - (list splitpoints* altns)])) - -(struct option (splitpoints errors) #:transparent +(struct option (split-indices alts pts expr errors) #:transparent #:methods gen:custom-write [(define (write-proc opt port mode) (display "#