From 7ddd4bc2831a7fe81cb3503a21547b4c596f8fc5 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 31 Jul 2024 16:02:46 -0700 Subject: [PATCH 01/64] add `spec` and `fpcore` fields to operator impls --- src/syntax/syntax.rkt | 118 +++++++++++++++++++++--------------------- src/utils/common.rkt | 14 +++-- 2 files changed, 71 insertions(+), 61 deletions(-) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 7479c8db2..23c5a2311 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -59,8 +59,6 @@ ;; - input and output types ;; - optionally a specification [#f by default] ;; - optionally a deprecated? flag [#f by default] -;; Operator implementations _implement_ a real operator -;; for a particular set of input and output representations. (struct operator (name itype otype spec deprecated)) ;; All real operators @@ -350,11 +348,15 @@ ;; Operator implementations ;; Floating-point operations that approximate mathematical operations -;; Operator implementations -;; An "operator implementation" implements a mathematical operator for -;; a particular set of representations satisfying the types described -;; by the `itype` and `otype` properties of the operator. -(struct operator-impl (name op itype otype fl)) +;; An operator implementation requires +;; - a (unique) name +;; - input and output representations +;; - a specification it approximates +;; - its FPCore representation +;; - an implementation +;; Operator implementations _approximate_ a program of +;; mathematical operators with fixed input and output representations. +(struct operator-impl (name op itype otype spec fpcore fl)) ;; Operator implementation table ;; Tracks implementations that are loaded into Racket's runtime @@ -368,13 +370,15 @@ ;; Looks up a property `field` of an real operator `op`. ;; Panics if the operator is not found. (define/contract (impl-info impl field) - (-> symbol? (or/c 'itype 'otype 'fl) any/c) + (-> symbol? (or/c 'itype 'otype 'spec 'fl) any/c) (unless (hash-has-key? operator-impls impl) (error 'impl-info "Unknown operator implementation ~a" impl)) (define info (hash-ref operator-impls impl)) (case field [(itype) (operator-impl-itype info)] [(otype) (operator-impl-otype info)] + [(spec) (operator-impl-spec info)] + [(fpcore) (operator-impl-fpcore info)] [(fl) (operator-impl-fl info)])) ;; Like `operator-all-impls`, but filters for only active implementations. @@ -403,59 +407,57 @@ ;; Registers an operator implementation `name` or real operator `op`. ;; The input and output representations must satisfy the types ;; specified by the `itype` and `otype` fields for `op`. -(define (register-operator-impl! op name ireprs orepr attrib-dict) - (define op-info - (hash-ref - operators - op - (lambda () - (raise-herbie-missing-error "Cannot register `~a`, operator `~a` does not exist" name op)))) - - ; check arity and types - (define itypes (operator-itype op-info)) - (define otype (operator-otype op-info)) - (define expect-arity (length itypes)) - (define actual-arity (length ireprs)) - (unless (= expect-arity actual-arity) - (raise-herbie-missing-error - "Cannot register `~a` as an implementation of `~a`: expected ~a arguments, got ~a" - name - op - expect-arity - actual-arity)) - (for ([repr (in-list (cons orepr ireprs))] [type (in-list (cons otype itypes))]) - (unless (equal? (representation-type repr) type) - "Cannot register `~a` as implementation of `~a`: ~a is not a representation of ~a" - name - op - repr - type)) - - ;; Synthesizes a correctly-rounded floating-point implemenation - (define (synth-fl-impl name vars spec) - (define ctx (context vars orepr ireprs)) - (define compiler (make-real-compiler (list spec) (list ctx))) - (define fail ((representation-bf->repr orepr) +nan.bf)) - (procedure-rename (lambda pt - (define-values (_ exs) (real-apply compiler pt)) - (if exs (first exs) fail)) - (sym-append 'synth: name))) - - ;; Get floating-point implementation +(define/contract (register-operator-impl! op name ireprs orepr attrib-dict) + (-> symbol? symbol? (listof representation?) representation? (listof pair?) void?) + ; extract or generate the spec + (define spec + (match (dict-ref attrib-dict 'spec #f) + ; not provided => need to generate it + [#f + (define vars (gen-vars (length ireprs))) + `(lambda ,vars (,op ,@vars))] + ; provided => check for syntax and types + [spec + (check-accelerator-spec! name + (map representation-type ireprs) + (representation-type orepr) + spec) + spec])) + ; extract or generate the fpcore translation + (match-define `(,(or 'lambda 'λ) ,vars ,_) spec) + (define fpcore + (match (dict-ref attrib-dict 'fpcore #f) + ; not provided => need to generate it + [#f `(! :precision ,(representation-name orepr) `(,op ,@vars))] + ; provided -> TODO: check free variables + [fpcore fpcore])) + + ; extract or generate floating-point implementation (define fl-proc - (cond - [(assoc 'fl attrib-dict) - => - cdr] ; user-provided implementation - [(operator-accelerator? op) ; Rival-synthesized accelerator implementation - (match-define `(,(or 'lambda 'λ) (,vars ...) ,body) (operator-spec op-info)) - (synth-fl-impl name vars body)] - [else ; Rival-synthesized operator implementation - (define vars (build-list (length ireprs) (lambda (i) (string->symbol (format "x~a" i))))) - (synth-fl-impl name vars `(,op ,@vars))])) + (match (dict-ref attrib-dict 'fl #f) + ; not provided => need to generate it + [#f + (define ctx (context vars orepr ireprs)) + (define compiler (make-real-compiler (list spec) (list ctx))) + (define fail ((representation-bf->repr orepr) +nan.bf)) + (procedure-rename (lambda pt + (define-values (_ exs) (real-apply compiler pt)) + (if exs (first exs) fail)) + (sym-append 'synth: name))] + ; provided + [(? procedure? proc) + (define expect-arity (length ireprs)) + (unless (procedure-arity-includes? proc expect-arity #t) + (error 'register-operator-impl! + "~a: procedure does not accept ~a arguments" + name + expect-arity))] + ; not a procedure + [bad + (error 'register-operator-impl! "~a: expected a procedure with attribute 'fl ~a" name bad)])) ; update tables - (define impl (operator-impl name op-info ireprs orepr fl-proc)) + (define impl (operator-impl name op ireprs orepr spec fpcore fl-proc)) (hash-set! operator-impls name impl) (hash-update! operators-to-impls op (curry cons name))) diff --git a/src/utils/common.rkt b/src/utils/common.rkt index 6eaa24eb9..047090c4b 100644 --- a/src/utils/common.rkt +++ b/src/utils/common.rkt @@ -22,6 +22,7 @@ quasisyntax dict sym-append + gen-vars string-replace* format-time format-bits @@ -261,11 +262,18 @@ (define (web-resource [name #f]) (if name (build-path web-resource-path name) web-resource-path)) -(define (sym-append . args) - (string->symbol (apply string-append (map ~a args)))) - (define/contract (string-replace* str changes) (-> string? (listof (cons/c string? string?)) string?) (for/fold ([str str]) ([change changes]) (match-define (cons from to) change) (string-replace str from to))) + +;; Symbol generation + +(define (sym-append . args) + (string->symbol (apply string-append (map ~a args)))) + +;; Generates a list of variables names. +(define/contract (gen-vars n) + (-> natural? (listof symbol?)) + (build-list n (lambda (i) (string->symbol (format "x~a" i))))) From 9cb09a03f597fabd756f4cc21a27b72fa921b613 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 31 Jul 2024 16:44:51 -0700 Subject: [PATCH 02/64] switch accelerators to new syntax --- src/platforms/binary32.rkt | 61 +++++++++++++++++++++++++++++++++----- src/platforms/binary64.rkt | 47 +++++++++++++++++++++++++---- src/platforms/default.rkt | 2 -- src/syntax/syntax.rkt | 48 ++++++++++++++++++++---------- 4 files changed, 128 insertions(+), 30 deletions(-) diff --git a/src/platforms/binary32.rkt b/src/platforms/binary32.rkt index d7d20be2c..6f7aff8a0 100644 --- a/src/platforms/binary32.rkt +++ b/src/platforms/binary32.rkt @@ -63,16 +63,13 @@ cos cosh erf - erfc exp exp2 - expm1 fabs floor lgamma log log10 - log1p log2 logb rint @@ -85,8 +82,48 @@ tgamma trunc)] [(binary32 binary32 binary32) - (atan2 copysign fdim fmax fmin fmod hypot pow remainder)] - [(binary32 binary32 binary32 binary32) (fma)]) + (atan2 copysign fdim fmax fmin fmod pow remainder)]) + +(define-libm c_expm1f (expm1 float float)) +(define-libm c_erfcf (erfc float float)) +(define-libm c_log1pf (log1p float float)) +(define-libm c_hypotf (hypot float float float)) +(define-libm c_fmaf (fma float float float float)) + +(when c_expm1f + (define-operator-impl (expm1 expm1.f32 binary32) + binary32 + [spec (lambda (x) (- (exp x) 1))] + [fpcore (! :precision binary32 (expm1 x))] + [fl c_expm1f])) + +(when c_erfcf + (define-operator-impl (erfc erfc.f32 binary32) + binary32 + [spec (lambda (x) (- 1 (erf x)))] + [fpcore (! :precision binary32 (erfc x))] + [fl c_erfcf])) + +(when c_log1pf + (define-operator-impl (log1p log1p.f32 binary32) + binary32 + [spec (lambda (x) (log (+ 1 x)))] + [fpcore (! :precision binary32 (log1p x))] + [fl c_log1pf])) + +(when c_hypotf + (define-operator-impl (hypot hypot.f32 binary32 binary32) + binary32 + [spec (lambda (x y) (sqrt (+ (* x x) (* y y))))] + [fpcore (! :precision binary32 (hypot x))] + [fl c_hypotf])) + +(when c_fmaf + (define-operator-impl (fma fma.f32 binary32 binary32 binary32) + binary32 + [spec (lambda (x y z) (+ (* x y) z))] + [fpcore (! :precision binary32 (fma x y z))] + [fl c_fmaf])) (define-comparator-impls binary32 [== ==.f32 =] @@ -96,6 +133,14 @@ [<= <=.f32 <=] [>= >=.f32 >=]) -(define-operator-impl (cast binary64->binary32 binary64) binary32 [fl (curryr ->float32)]) - -(define-operator-impl (cast binary32->binary64 binary32) binary64 [fl identity]) +(define-operator-impl (cast binary64->binary32 binary64) + binary32 + [spec (lambda (x) x)] + [fpcore (! :precision binary32 (cast x))] + [fl ->float32]) + +(define-operator-impl (cast binary32->binary64 binary32) + binary64 + [spec (lambda (x) x)] + [fpcore (! :precision binary64 (cast x))] + [fl identity]) diff --git a/src/platforms/binary64.rkt b/src/platforms/binary64.rkt index a3ef3cccd..9f05861a1 100644 --- a/src/platforms/binary64.rkt +++ b/src/platforms/binary64.rkt @@ -63,16 +63,13 @@ cos cosh erf - erfc exp exp2 - expm1 fabs floor lgamma log log10 - log1p log2 logb rint @@ -85,8 +82,48 @@ tgamma trunc)] [(binary64 binary64 binary64) - (atan2 copysign fdim fmax fmin fmod hypot pow remainder)] - [(binary64 binary64 binary64 binary64) (fma)]) + (atan2 copysign fdim fmax fmin fmod pow remainder)]) + +(define-libm c_expm1 (expm1 double double)) +(define-libm c_erfc (erfc double double)) +(define-libm c_log1p (log1p double double)) +(define-libm c_hypot (hypot double double double)) +(define-libm c_fma (fma double double double double)) + +(when c_expm1 + (define-operator-impl (expm1 expm1.f64 binary64) + binary64 + [spec (lambda (x) (- (exp x) 1))] + [fpcore (! :precision binary64 (expm1 x))] + [fl c_expm1])) + +(when c_erfc + (define-operator-impl (erfc erfc.f64 binary64) + binary64 + [spec (lambda (x) (- 1 (erf x)))] + [fpcore (! :precision binary64 (erfc x))] + [fl c_erfc])) + +(when c_log1p + (define-operator-impl (log1p log1p.f64 binary64) + binary64 + [spec (lambda (x) (log (+ 1 x)))] + [fpcore (! :precision binary64 (log1p x))] + [fl c_log1p])) + +(when c_hypot + (define-operator-impl (hypot hypot.f64 binary64 binary64) + binary64 + [spec (lambda (x y) (sqrt (+ (* x x) (* y y))))] + [fpcore (! :precision binary64 (hypot x))] + [fl c_hypot])) + +(when c_fma + (define-operator-impl (fma fma.f64 binary64 binary64 binary64) + binary64 + [spec (lambda (x y z) (+ (* x y) z))] + [fpcore (! :precision binary64 (fma x y z))] + [fl c_fma])) (define-comparator-impls binary64 [== ==.f64 =] diff --git a/src/platforms/default.rkt b/src/platforms/default.rkt index 7e69dd125..4d088478d 100644 --- a/src/platforms/default.rkt +++ b/src/platforms/default.rkt @@ -80,7 +80,6 @@ lgamma.f64 log.f64 log10.f64 - log1p.f64 log2.f64 logb.f64 pow.f64 @@ -122,7 +121,6 @@ lgamma.f32 log.f32 log10.f32 - log1p.f32 log2.f32 logb.f32 pow.f32 diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 23c5a2311..3884f86ce 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -213,18 +213,16 @@ (hash-set! operators name info) (hash-set! operators-to-impls name '())) -;; Syntactic form for `register-operator!`. -;; Special translations for +;; Syntactic form for `register-operator!` (define-syntax (define-operator stx) (define (bad! why [what #f]) (raise-syntax-error 'define-operator why stx what)) (define (attribute-val key val) - (syntax-case key (spec) - [spec - (with-syntax ([val val]) - (syntax 'val))] - [_ val])) + (with-syntax ([val val]) + (syntax-case key (spec) + [spec #''val] + [_ #'val]))) (syntax-case stx () [(_ (id itype ...) otype [key val] ...) @@ -428,7 +426,7 @@ (define fpcore (match (dict-ref attrib-dict 'fpcore #f) ; not provided => need to generate it - [#f `(! :precision ,(representation-name orepr) `(,op ,@vars))] + [#f `(! :precision ,(representation-name orepr) (,op ,@vars))] ; provided -> TODO: check free variables [fpcore fpcore])) @@ -451,22 +449,42 @@ (error 'register-operator-impl! "~a: procedure does not accept ~a arguments" name - expect-arity))] + expect-arity)) + proc] ; not a procedure [bad (error 'register-operator-impl! "~a: expected a procedure with attribute 'fl ~a" name bad)])) + (eprintf "~a ~a: ~a ~a ~a\n" name op spec fpcore fl-proc) + ; update tables (define impl (operator-impl name op ireprs orepr spec fpcore fl-proc)) (hash-set! operator-impls name impl) (hash-update! operators-to-impls op (curry cons name))) -(define-syntax-rule (define-operator-impl (operator name atypes ...) rtype [key value] ...) - (register-operator-impl! 'operator - 'name - (list (get-representation 'atypes) ...) - (get-representation 'rtype) - (list (cons 'key value) ...))) +;; Syntactic form for `register-operator-impl!` +(define-syntax (define-operator-impl stx) + (define (bad! why [what #f]) + (raise-syntax-error 'define-operator-impl why stx what)) + + (define (attribute-val key val) + (with-syntax ([val val]) + (syntax-case key (spec fpcore) + [spec #''val] + [fpcore #''val] + [_ #'val]))) + + (syntax-case stx () + [(_ (op id itype ...) otype [key val] ...) + (let ([id #'id] [keys (syntax->list #'(key ...))] [vals (syntax->list #'(val ...))]) + (unless (identifier? id) + (bad! "expected identifier" id)) + (with-syntax ([id id] [(val ...) (map attribute-val keys vals)]) + #'(register-operator-impl! 'op + 'id + (list (get-representation 'itype) ...) + (get-representation 'otype) + (list (cons 'key val) ...))))])) ;; Among active implementations, looks up an implementation with ;; the operator name `name` and argument representations `ireprs`. From 9903a2f578904d12a798610b171750e9eef268f2 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 31 Jul 2024 17:17:54 -0700 Subject: [PATCH 03/64] remove instances of `impl->operator` --- src/core/egg-herbie.rkt | 18 ++++++++++-------- src/reports/history.rkt | 2 +- src/syntax/platform.rkt | 27 +++++++++------------------ src/syntax/sugar.rkt | 18 ++++++++++-------- src/syntax/syntax.rkt | 11 ++++++++--- 5 files changed, 38 insertions(+), 38 deletions(-) diff --git a/src/core/egg-herbie.rkt b/src/core/egg-herbie.rkt index 0787eac2e..dc19b6a8d 100644 --- a/src/core/egg-herbie.rkt +++ b/src/core/egg-herbie.rkt @@ -1003,14 +1003,16 @@ (+ 1 (rec cond (get-representation 'bool) +inf.0) (rec ift type +inf.0) (rec iff type +inf.0))] [(list (? impl-exists? impl) args ...) (define itypes (impl-info impl 'itype)) - (if (equal? (impl->operator impl) 'pow) - (match args - [(list b e) - (define n (vector-ref (regraph-constants regraph) e)) - (if (fraction-with-odd-denominator? n) - +inf.0 - (apply + 1 (map (lambda (arg itype) (rec arg itype +inf.0)) args itypes)))]) - (apply + 1 (map (lambda (arg itype) (rec arg itype +inf.0)) args itypes)))] + (match-define (list _ _ spec) (impl-info impl 'spec)) + (match spec + [(list 'pow _ _) ; power + (match-define (list b e) args) + (define n (vector-ref (regraph-constants regraph) e)) + (if (fraction-with-odd-denominator? n) + +inf.0 + (apply + 1 (map (lambda (arg itype) (rec arg itype +inf.0)) args itypes)))] + ; anything else + [_ (apply + 1 (map (lambda (arg itype) (rec arg itype +inf.0)) args itypes))])] [(list _ ...) +inf.0])) ;; Extracts the best expression according to the extractor. diff --git a/src/reports/history.rkt b/src/reports/history.rkt index 5fe3e526b..bd0ce68e6 100644 --- a/src/reports/history.rkt +++ b/src/reports/history.rkt @@ -82,7 +82,7 @@ [(? symbol?) expr] [(? number?) expr] [(? literal?) (literal-value expr)] - [`(if ,cond ,ift ,iff) `(if ,(loop cond) ,(loop ift) ,(loop ift))] + [`(if ,cond ,ift ,iff) `(if ,(loop cond) ,(loop ift) ,(loop iff))] [`(,(? impl-exists? impl) ,args ...) `(,(impl->operator impl) ,@(map loop args))] [`(,op ,args ...) `(,op ,@(map loop args))]))) `(FPCore ,(context-vars ctx) ,expr*)) diff --git a/src/syntax/platform.rkt b/src/syntax/platform.rkt index 63d05a5fe..facc2613b 100644 --- a/src/syntax/platform.rkt +++ b/src/syntax/platform.rkt @@ -1,7 +1,5 @@ #lang racket -(require (for-syntax racket/match)) - (require "../utils/common.rkt" "../utils/errors.rkt" "../core/programs.rkt" @@ -238,8 +236,9 @@ (define (platform-casts pform) (reap [sow] (for ([impl (in-list (platform-impls pform))]) - (when (eq? (impl->operator impl) 'cast) - (sow impl))))) + (match (impl-info impl 'spec) + [(list _ _ (list 'cast _)) (sow impl)] + [_ (void)])))) ;; Merger for costs. (define (merge-cost pform-costs key #:optional? [optional? #f]) @@ -305,7 +304,8 @@ (define reprs* (filter repr-supported? (platform-reprs pform))) (define impls* (filter (λ (impl) - (and (op-supported? (impl->operator impl)) + (match-define (list _ _ spec) (impl-info impl 'spec)) + (and (andmap op-supported? (ops-in-expr spec)) (repr-supported? (impl-info impl 'otype)) (andmap repr-supported? (impl-info impl 'itype)))) (platform-impls pform))) @@ -418,16 +418,8 @@ ;; Synthesizes the LHS and RHS of lifting/lowering rules. (define (impl->rule-parts impl) - (define op (impl->operator impl)) - (cond - [(operator-accelerator? op) - (define spec (operator-info op 'spec)) - (match-define `(,(or 'lambda 'λ) (,vars ...) ,body) spec) - (values vars body (cons impl vars))] - [else - (define itypes (operator-info op 'itype)) - (define vars (map (lambda (_) (gensym)) itypes)) - (values vars (cons op vars) (cons impl vars))])) + (match-define (list _ vars spec) (impl-info impl 'spec)) + (values vars spec (cons impl vars))) ;; Synthesizes lifting rules for a given platform. (define (platform-lifting-rules [pform (*active-platform*)]) @@ -449,11 +441,10 @@ (hash-ref! (*lowering-rules*) (cons impl pform) (lambda () - (define op (impl->operator impl)) (define name (sym-append 'lower- impl)) - (define itypes (operator-info op 'itype)) - (define otype (operator-info op 'otype)) (define-values (vars spec-expr impl-expr) (impl->rule-parts impl)) + (define itypes (map representation-type (impl-info impl 'itype))) + (define otype (representation-type (impl-info impl 'otype))) (rule name spec-expr impl-expr (map cons vars itypes) otype))))) ;; All possible assignments of implementations. diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 39136da85..952464abe 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -1,7 +1,8 @@ #lang racket (require "types.rkt" - "syntax.rkt") + "syntax.rkt" + "../core/programs.rkt") (provide fpcore->prog prog->fpcore @@ -208,10 +209,11 @@ ;; Translates an LImpl to a LSpec. (define (prog->spec expr) - (expand-accelerators - (match expr - [`(if ,cond ,ift ,iff) `(if ,(prog->spec cond) ,(prog->spec ift) ,(prog->spec iff))] - [`(,(? cast-impl? impl) ,body) `(,impl ,(prog->spec body))] - [`(,impl ,args ...) `(,(impl->operator impl) ,@(map prog->spec args))] - [(? variable?) expr] - [(? literal?) (literal-value expr)]))) + (match expr + [(? literal?) (literal-value expr)] + [(? variable?) expr] + [`(if ,cond ,ift ,iff) `(if ,(prog->spec cond) ,(prog->spec ift) ,(prog->spec iff))] + [`(,impl ,args ...) + (match-define `(,_ (,vars ...) ,spec) (impl-info impl 'spec)) + (define env (map cons vars (map prog->spec args))) + (replace-vars env spec)])) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 3884f86ce..432ff458a 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -407,6 +407,13 @@ ;; specified by the `itype` and `otype` fields for `op`. (define/contract (register-operator-impl! op name ireprs orepr attrib-dict) (-> symbol? symbol? (listof representation?) representation? (listof pair?) void?) + (define op-info + (hash-ref + operators + op + (lambda () + (raise-herbie-missing-error "Cannot register `~a`, operator `~a` does not exist" name op)))) + ; extract or generate the spec (define spec (match (dict-ref attrib-dict 'spec #f) @@ -455,10 +462,8 @@ [bad (error 'register-operator-impl! "~a: expected a procedure with attribute 'fl ~a" name bad)])) - (eprintf "~a ~a: ~a ~a ~a\n" name op spec fpcore fl-proc) - ; update tables - (define impl (operator-impl name op ireprs orepr spec fpcore fl-proc)) + (define impl (operator-impl name op-info ireprs orepr spec fpcore fl-proc)) (hash-set! operator-impls name impl) (hash-update! operators-to-impls op (curry cons name))) From fcfb6db061f6d6cee5428f64712d0bfb8bf5e402 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 31 Jul 2024 17:26:47 -0700 Subject: [PATCH 04/64] eliminate `spec` from operators --- src/core/bsearch.rkt | 3 +- src/core/rules.rkt | 65 ++++++-------- src/syntax/syntax.rkt | 191 +++++++++++++++--------------------------- 3 files changed, 95 insertions(+), 164 deletions(-) diff --git a/src/core/bsearch.rkt b/src/core/bsearch.rkt index d21d33e18..94d3898a0 100644 --- a/src/core/bsearch.rkt +++ b/src/core/bsearch.rkt @@ -128,8 +128,7 @@ ; Not totally clear if this should actually use the precondition (define start-real-compiler - (and start-prog - (make-real-compiler (list (expand-accelerators (prog->spec start-prog))) (list ctx*)))) + (and start-prog (make-real-compiler (list (prog->spec start-prog)) (list ctx*)))) (define (prepend-macro v) (prepend-argument start-real-compiler v (*pcontext*))) diff --git a/src/core/rules.rkt b/src/core/rules.rkt index 79e31fc47..442bc584a 100644 --- a/src/core/rules.rkt +++ b/src/core/rules.rkt @@ -103,19 +103,8 @@ (for ([rule (in-list rules)]) (sow rule)))))) -;; Spec contains no accelerators -(define (spec-has-accelerator? spec) - (match spec - [(list (? operator-accelerator?) _ ...) #t] - [(list _ args ...) (ormap spec-has-accelerator? args)] - [_ #f])) - (define (real-rules rules) - (filter-not (lambda (rule) - (or (representation? (rule-otype rule)) - (spec-has-accelerator? (rule-input rule)) - (spec-has-accelerator? (rule-output rule)))) - rules)) + (filter-not (lambda (rule) (representation? (rule-otype rule))) rules)) ;; ;; Rule loading @@ -741,32 +730,32 @@ [asinh-2 (acosh (+ (* 2 (* x x)) 1)) (* 2 (asinh x))] [acosh-2 (acosh (- (* 2 (* x x)) 1)) (* 2 (acosh x))]) -; Specialized numerical functions -(define-ruleset* special-numerical-reduce - (numerics simplify) - #:type ([x real] [y real] [z real]) - [log1p-expm1 (log1p (expm1 x)) x] - [hypot-1-def (sqrt (+ 1 (* y y))) (hypot 1 y)] - [fmm-def (- (* x y) z) (fma x y (neg z))] - [fmm-undef (fma x y (neg z)) (- (* x y) z)]) - -(define-ruleset* special-numerical-expand - (numerics) - #:type ([x real] [y real]) - [log1p-expm1-u x (log1p (expm1 x))] - [expm1-log1p-u x (expm1 (log1p x))]) - -(define-ruleset* erf-rules (special simplify) #:type ([x real]) [erf-odd (erf (neg x)) (neg (erf x))]) - -(define-ruleset* numerics-papers - (numerics) - #:type ([a real] [b real] [c real] [d real]) - ; "Further Analysis of Kahan's Algorithm for - ; the Accurate Computation of 2x2 Determinants" - ; Jeannerod et al., Mathematics of Computation, 2013 - ; - ; a * b - c * d ===> fma(a, b, -(d * c)) + fma(-d, c, d * c) - [prod-diff (- (* a b) (* c d)) (+ (fma a b (neg (* d c))) (fma (neg d) c (* d c)))]) +; ; Specialized numerical functions +; (define-ruleset* special-numerical-reduce +; (numerics simplify) +; #:type ([x real] [y real] [z real]) +; [log1p-expm1 (log1p (expm1 x)) x] +; [hypot-1-def (sqrt (+ 1 (* y y))) (hypot 1 y)] +; [fmm-def (- (* x y) z) (fma x y (neg z))] +; [fmm-undef (fma x y (neg z)) (- (* x y) z)]) + +; (define-ruleset* special-numerical-expand +; (numerics) +; #:type ([x real] [y real]) +; [log1p-expm1-u x (log1p (expm1 x))] +; [expm1-log1p-u x (expm1 (log1p x))]) + +; (define-ruleset* erf-rules (special simplify) #:type ([x real]) [erf-odd (erf (neg x)) (neg (erf x))]) + +; (define-ruleset* numerics-papers +; (numerics) +; #:type ([a real] [b real] [c real] [d real]) +; ; "Further Analysis of Kahan's Algorithm for +; ; the Accurate Computation of 2x2 Determinants" +; ; Jeannerod et al., Mathematics of Computation, 2013 +; ; +; ; a * b - c * d ===> fma(a, b, -(d * c)) + fma(-d, c, d * c) +; [prod-diff (- (* a b) (* c d)) (+ (fma a b (neg (* d c))) (fma (neg d) c (* d c)))]) ;; Sound because it's about soundness over real numbers (define-ruleset* compare-reduce diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 432ff458a..707f0b08a 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -13,12 +13,9 @@ constant-operator? operator-exists? operator-deprecated? - operator-accelerator? operator-info all-operators all-constants - all-accelerators - expand-accelerators impl-exists? impl-info impl->operator @@ -57,9 +54,8 @@ ;; A real operator requires ;; - a (unique) name ;; - input and output types -;; - optionally a specification [#f by default] ;; - optionally a deprecated? flag [#f by default] -(struct operator (name itype otype spec deprecated)) +(struct operator (name itype otype deprecated)) ;; All real operators (define operators (make-hasheq)) @@ -72,10 +68,6 @@ (define (operator-deprecated? op) (operator-deprecated (hash-ref operators op))) -;; Checks if an operator is an "accelerator". -(define (operator-accelerator? op) - (and (hash-has-key? operators op) (operator-spec (hash-ref operators op)))) - ;; Returns all operators. (define (all-operators) (sort (hash-keys operators) symbollist #'(key ...))] [vals (syntax->list #'(val ...))]) + (let ([id #'id]) (unless (identifier? id) (bad! "expected identifier" id)) - (with-syntax ([id id] [(val ...) (map attribute-val keys vals)]) + (with-syntax ([id id]) #'(register-operator! 'id '(itype ...) 'otype (list (cons 'key val) ...))))])) (define-syntax define-operators @@ -316,31 +266,27 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Accelerator operators -(define-operator (cast real) real [spec (lambda (x) x)]) - -(define-operator (erfc real) real [spec (lambda (x) (- 1 (erf x)))]) - -(define-operator (expm1 real) real [spec (lambda (x) (- (exp x) 1))]) - -(define-operator (log1p real) real [spec (lambda (x) (log (+ 1 x)))]) - -(define-operator (hypot real real) real [spec (lambda (x y) (sqrt (+ (* x x) (* y y))))]) - -(define-operator (fma real real real) real [spec (lambda (x y z) (+ (* x y) z))]) - -(module+ test - ; check expected number of operators - (check-equal? (length (all-operators)) 63) - - ; check that Rival supports all non-accelerator operators - (for ([op (in-list (all-operators))] #:unless (operator-accelerator? op)) - (define vars (map (lambda (_) (gensym)) (operator-info op 'itype))) - (define disc (discretization 64 #f #f)) ; fake arguments - (rival-compile (list `(,op ,@vars)) vars (list disc))) - - ; test accelerator operator - ; log1pmd(x) = log1p(x) - log1p(-x) - (define-operator (log1pmd real) real [spec (lambda (x) (- (log1p x) (log1p (neg x))))])) +(define-operators + [cast : real -> real] + [erfc : real -> real] + [expm1 : real -> real] + [log1p : real -> real] + [hypot : real real -> real] + [fma : real real real -> real]) + +; (module+ test +; ; check expected number of operators +; (check-equal? (length (all-operators)) 63) + +; ; check that Rival supports all non-accelerator operators +; (for ([op (in-list (all-operators))] #:unless (operator-accelerator? op)) +; (define vars (map (lambda (_) (gensym)) (operator-info op 'itype))) +; (define disc (discretization 64 #f #f)) ; fake arguments +; (rival-compile (list `(,op ,@vars)) vars (list disc))) + +; ; test accelerator operator +; ; log1pmd(x) = log1p(x) - log1p(-x) +; (define-operator (log1pmd real) real [spec (lambda (x) (- (log1p x) (log1p (neg x))))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Operator implementations @@ -423,10 +369,7 @@ `(lambda ,vars (,op ,@vars))] ; provided => check for syntax and types [spec - (check-accelerator-spec! name - (map representation-type ireprs) - (representation-type orepr) - spec) + (check-spec! name (map representation-type ireprs) (representation-type orepr) spec) spec])) ; extract or generate the fpcore translation (match-define `(,(or 'lambda 'λ) ,vars ,_) spec) @@ -517,44 +460,44 @@ name (format "<~a>" (representation-name repr))))) -(module+ test - (require math/flonum - math/bigfloat - (submod "types.rkt" internals)) - - (define (shift bits fn) - (define shift-val (expt 2 bits)) - (λ (x) (fn (- x shift-val)))) - - (define (unshift bits fn) - (define shift-val (expt 2 bits)) - (λ (x) (+ (fn x) shift-val))) - - ; for testing: also in /reprs/binary64.rkt - (define-representation (binary64 real flonum?) - bigfloat->flonum - bf - (shift 63 ordinal->flonum) - (unshift 63 flonum->ordinal) - 64 - (conjoin number? nan?)) - - ; correctly-rounded log1pmd(x) for binary64 - (define-operator-impl (log1pmd log1pmd.f64 binary64) binary64) - ; correctly-rounded sin(x) for binary64 - (define-operator-impl (sin sin.acc.f64 binary64) binary64) - - (define log1pmd-proc (impl-info 'log1pmd.f64 'fl)) - (define log1pmd-vals '((0.0 . 0.0) (0.5 . 1.0986122886681098) (-0.5 . -1.0986122886681098))) - (for ([(pt out) (in-dict log1pmd-vals)]) - (check-equal? (log1pmd-proc pt) out (format "log1pmd(~a) = ~a" pt out))) - - (define sin-proc (impl-info 'sin.acc.f64 'fl)) - (define sin-vals '((0.0 . 0.0) (1.0 . 0.8414709848078965) (-1.0 . -0.8414709848078965))) - (for ([(pt out) (in-dict sin-vals)]) - (check-equal? (sin-proc pt) out (format "sin(~a) = ~a" pt out))) - - (void)) +; (module+ test +; (require math/flonum +; math/bigfloat +; (submod "types.rkt" internals)) + +; (define (shift bits fn) +; (define shift-val (expt 2 bits)) +; (λ (x) (fn (- x shift-val)))) + +; (define (unshift bits fn) +; (define shift-val (expt 2 bits)) +; (λ (x) (+ (fn x) shift-val))) + +; ; for testing: also in /reprs/binary64.rkt +; (define-representation (binary64 real flonum?) +; bigfloat->flonum +; bf +; (shift 63 ordinal->flonum) +; (unshift 63 flonum->ordinal) +; 64 +; (conjoin number? nan?)) + +; ; correctly-rounded log1pmd(x) for binary64 +; (define-operator-impl (log1pmd log1pmd.f64 binary64) binary64) +; ; correctly-rounded sin(x) for binary64 +; (define-operator-impl (sin sin.acc.f64 binary64) binary64) + +; (define log1pmd-proc (impl-info 'log1pmd.f64 'fl)) +; (define log1pmd-vals '((0.0 . 0.0) (0.5 . 1.0986122886681098) (-0.5 . -1.0986122886681098))) +; (for ([(pt out) (in-dict log1pmd-vals)]) +; (check-equal? (log1pmd-proc pt) out (format "log1pmd(~a) = ~a" pt out))) + +; (define sin-proc (impl-info 'sin.acc.f64 'fl)) +; (define sin-vals '((0.0 . 0.0) (1.0 . 0.8414709848078965) (-1.0 . -0.8414709848078965))) +; (for ([(pt out) (in-dict sin-vals)]) +; (check-equal? (sin-proc pt) out (format "sin(~a) = ~a" pt out))) + +; (void)) ;; Casts and precision changes From 11afb0f63ae3b8c89a5f54568f52e71220454b90 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Thu, 1 Aug 2024 14:09:54 -0700 Subject: [PATCH 05/64] add `get-impls` and `get-impl` --- src/core/rules.rkt | 4 +- src/syntax/syntax.rkt | 88 ++++++++++++++++++++++++++++++++++++++++++- src/syntax/types.rkt | 5 +++ src/utils/common.rkt | 16 ++++++++ 4 files changed, 109 insertions(+), 4 deletions(-) diff --git a/src/core/rules.rkt b/src/core/rules.rkt index 442bc584a..7fb47d422 100644 --- a/src/core/rules.rkt +++ b/src/core/rules.rkt @@ -730,6 +730,8 @@ [asinh-2 (acosh (+ (* 2 (* x x)) 1)) (* 2 (asinh x))] [acosh-2 (acosh (- (* 2 (* x x)) 1)) (* 2 (acosh x))]) +(define-ruleset* erf-rules (special simplify) #:type ([x real]) [erf-odd (erf (neg x)) (neg (erf x))]) + ; ; Specialized numerical functions ; (define-ruleset* special-numerical-reduce ; (numerics simplify) @@ -745,8 +747,6 @@ ; [log1p-expm1-u x (log1p (expm1 x))] ; [expm1-log1p-u x (expm1 (log1p x))]) -; (define-ruleset* erf-rules (special simplify) #:type ([x real]) [erf-odd (erf (neg x)) (neg (erf x))]) - ; (define-ruleset* numerics-papers ; (numerics) ; #:type ([a real] [b real] [c real] [d real]) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 707f0b08a..40bb0779e 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -19,12 +19,16 @@ impl-exists? impl-info impl->operator + all-operator-impls + (rename-out [all-active-operator-impls active-operator-impls]) operator-all-impls operator-active-impls activate-operator-impl! clear-active-operator-impls! *functions* register-function! + get-impl + get-impls get-parametric-operator get-parametric-constant get-cast-impl @@ -325,6 +329,14 @@ [(fpcore) (operator-impl-fpcore info)] [(fl) (operator-impl-fl info)])) +;; Returns all operator implementations. +(define (all-operator-impls) + (sort (hash-keys operator-impls) symbollist active-operator-impls) symbol need to generate it @@ -386,7 +398,7 @@ ; not provided => need to generate it [#f (define ctx (context vars orepr ireprs)) - (define compiler (make-real-compiler (list spec) (list ctx))) + (define compiler (make-real-compiler (list body) (list ctx))) (define fail ((representation-bf->repr orepr) +nan.bf)) (procedure-rename (lambda pt (define-values (_ exs) (real-apply compiler pt)) @@ -434,6 +446,78 @@ (get-representation 'otype) (list (cons 'key val) ...))))])) +;; Unions two bindings. Returns #f if they disagree. +(define (merge-bindings binding1 binding2) + (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))))) + +;; Pattern matcher that returns a substitution or #f. +;; A substitution is an association list of symbols and expressions. +(define (pattern-match pattern expr) + (match* (pattern expr) + [((? number?) _) (and (equal? pattern expr) '())] + [((? variable?) _) (list (cons pattern expr))] + [((list phead prest ...) (list head rest ...)) + (and (equal? phead head) + (= (length prest) (length rest)) + (for/fold ([bindings '()]) ([pat (in-list prest)] [term (in-list rest)]) + (merge-bindings bindings (pattern-match pat term))))] + [(_ _) #f])) + +;; Checks if two specs are syntactically equivalent modulo renaming. +;; This is just pattern matching. +(define (spec-equal? spec1 spec2) + ; force result of `pattern-match` to be a boolean + (and (pattern-match spec1 spec2) #t)) + +;; Returns the list of implementations that implement a given spec +;; and have the given input and output representations. +(define (get-impls spec ireprs orepr #:impls [impls (all-active-operator-impls)]) + (reap [sow] + (for ([impl (in-list impls)]) + (when (and (equal? orepr (impl-info impl 'otype)) + (equal? ireprs (impl-info impl 'itype)) + (let () + (match-define (list _ _ spec*) (impl-info impl 'spec)) + (eprintf "~a: ~a ~a\n" impl spec spec*) + (spec-equal? spec spec*))) + (sow impl))))) + +;; Given a spec, rounding properties, and input representations, +;; looks up the best corresponding operator implementation. +;; Note: maximize number of matching properties, then minimize +;; the number of extraneous properties. +(define (get-impl spec ireprs props #:impls [impls (all-active-operator-impls)]) + ; ensure `':precision` is in the prop list + (unless (dict-has-key? props ':precision) + (error 'get-impl "expected key ':precision in properties `~a`" props)) + (define orepr (get-representation (dict-ref props ':precision))) + ; lookup all matching implementations + (define impls* (get-impls spec ireprs orepr #:impls impls)) + (when (null? impls*) + (raise-herbie-missing-error + "No implementation for spec ~a with type ~a -> ~a" + spec + (string-join (map (λ (r) (format "<~a>" (representation-name r))) ireprs) " ") + (format "<~a>" (representation-type orepr)))) + + (define scored + (for/list ([impl (in-list impls*)]) + (match-define (list '! props* ... _) (impl-info impl 'fpcore)) + (define num-props (length props*)) + + + impl)) + + + impls*) + +; (define (get-impl spec ireprs orepr #:impls [impls (operator-active-impls)]) +; ( + ;; Among active implementations, looks up an implementation with ;; the operator name `name` and argument representations `ireprs`. (define (get-parametric-operator #:all? [all? #f] name . ireprs) diff --git a/src/syntax/types.rkt b/src/syntax/types.rkt index 52618fb86..6cb649ac9 100644 --- a/src/syntax/types.rkt +++ b/src/syntax/types.rkt @@ -8,6 +8,7 @@ get-representation repr-exists? repr->symbol + repr->prop (struct-out context) *context* context-extend @@ -48,6 +49,10 @@ (define repr-name (representation-name repr)) (string->symbol (string-replace* (~a repr-name) replace-table))) +;; Converts a representation into a rounding property +(define (repr->prop repr) + (list (cons ':precision (representation-name repr)))) + ;; Repr / operator generation ;; Some plugins might define 'parameterized' reprs (e.g. fixed point with ;; m integer and n fractional bits). Since defining an infinite number of reprs diff --git a/src/utils/common.rkt b/src/utils/common.rkt index 047090c4b..91a3b4aae 100644 --- a/src/utils/common.rkt +++ b/src/utils/common.rkt @@ -277,3 +277,19 @@ (define/contract (gen-vars n) (-> natural? (listof symbol?)) (build-list n (lambda (i) (string->symbol (format "x~a" i))))) + +;; Property list <=> Property dictionary + +;; Prop list to dict +(define/contract (props->dict props) + (-> list? (listof (cons/c symbol? any/c))) + (let loop ([props props] [dict '()]) + (match props + [(list key val rest ...) (loop rest (dict-set dict key val))] + [(list key) (error 'props->dict "unmatched key" key)] + [(list) dict]))) + +(define (dict->prop prop-dict) + (apply append + (for/list ([(k v) (in-dict prop-dict)]) + (list k v)))) From 844abce5e13b4442a0c47d6dc5fae0ec40151629 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Thu, 1 Aug 2024 15:39:36 -0700 Subject: [PATCH 06/64] fix fpcore to impl translation --- src/syntax/read.rkt | 7 +- src/syntax/sugar.rkt | 13 +-- src/syntax/syntax.rkt | 158 +++++++++++++++---------------------- src/syntax/test-syntax.rkt | 61 ++++++++++++++ src/utils/common.rkt | 5 +- 5 files changed, 134 insertions(+), 110 deletions(-) create mode 100644 src/syntax/test-syntax.rkt diff --git a/src/syntax/read.rkt b/src/syntax/read.rkt index 6e6247401..032969f35 100644 --- a/src/syntax/read.rkt +++ b/src/syntax/read.rkt @@ -146,12 +146,7 @@ (for/list ([arg args]) (if (list? arg) (last arg) arg))) - (define prop-dict - (let loop ([props props]) - (match props - ['() '()] - [(list prop val rest ...) (cons (cons prop val) (loop rest))]))) - + (define prop-dict (props->dict props)) (define default-prec (dict-ref prop-dict ':precision (*default-precision*))) (define default-repr (get-representation default-prec)) (define var-reprs diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 952464abe..5988365ca 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -1,8 +1,9 @@ #lang racket -(require "types.rkt" +(require "../core/programs.rkt" + "../utils/common.rkt" "syntax.rkt" - "../core/programs.rkt") + "types.rkt") (provide fpcore->prog prog->fpcore @@ -126,14 +127,6 @@ ; other [_ expr]))) -;; Prop list to dict -(define (props->dict props) - (let loop ([props props] [dict '()]) - (match props - [(list key val rest ...) (loop rest (dict-set dict key val))] - [(list key) (error 'props->dict "unmatched key" key)] - [(list) dict]))) - ;; Translates from FPCore to an LImpl (define (fpcore->prog prog ctx) (define-values (expr* _) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 40bb0779e..01d305418 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -27,8 +27,7 @@ clear-active-operator-impls! *functions* register-function! - get-impl - get-impls + get-fpcore-impl get-parametric-operator get-parametric-constant get-cast-impl @@ -278,19 +277,15 @@ [hypot : real real -> real] [fma : real real real -> real]) -; (module+ test -; ; check expected number of operators -; (check-equal? (length (all-operators)) 63) - -; ; check that Rival supports all non-accelerator operators -; (for ([op (in-list (all-operators))] #:unless (operator-accelerator? op)) -; (define vars (map (lambda (_) (gensym)) (operator-info op 'itype))) -; (define disc (discretization 64 #f #f)) ; fake arguments -; (rival-compile (list `(,op ,@vars)) vars (list disc))) +(module+ test + ; check expected number of operators + (check-equal? (length (all-operators)) 63) -; ; test accelerator operator -; ; log1pmd(x) = log1p(x) - log1p(-x) -; (define-operator (log1pmd real) real [spec (lambda (x) (- (log1p x) (log1p (neg x))))])) + ; check that Rival supports all non-accelerator operators + (for ([op (in-list (all-operators))]) + (define vars (map (lambda (_) (gensym)) (operator-info op 'itype))) + (define disc (discretization 64 #f #f)) ; fake arguments + (rival-compile (list `(,op ,@vars)) vars (list disc)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Operator implementations @@ -318,7 +313,7 @@ ;; Looks up a property `field` of an real operator `op`. ;; Panics if the operator is not found. (define/contract (impl-info impl field) - (-> symbol? (or/c 'itype 'otype 'spec 'fl) any/c) + (-> symbol? (or/c 'itype 'otype 'spec 'fpcore 'fl) any/c) (unless (hash-has-key? operator-impls impl) (error 'impl-info "Unknown operator implementation ~a" impl)) (define info (hash-ref operator-impls impl)) @@ -475,48 +470,64 @@ ;; Returns the list of implementations that implement a given spec ;; and have the given input and output representations. -(define (get-impls spec ireprs orepr #:impls [impls (all-active-operator-impls)]) - (reap [sow] - (for ([impl (in-list impls)]) - (when (and (equal? orepr (impl-info impl 'otype)) - (equal? ireprs (impl-info impl 'itype)) - (let () - (match-define (list _ _ spec*) (impl-info impl 'spec)) - (eprintf "~a: ~a ~a\n" impl spec spec*) - (spec-equal? spec spec*))) - (sow impl))))) - -;; Given a spec, rounding properties, and input representations, -;; looks up the best corresponding operator implementation. -;; Note: maximize number of matching properties, then minimize -;; the number of extraneous properties. -(define (get-impl spec ireprs props #:impls [impls (all-active-operator-impls)]) +; (define (get-impls spec ireprs orepr #:impls [impls (all-active-operator-impls)]) +; (reap [sow] +; (for ([impl (in-list impls)]) +; (when (and (equal? orepr (impl-info impl 'otype)) +; (equal? ireprs (impl-info impl 'itype)) +; (let () +; (match-define (list _ _ spec*) (impl-info impl 'spec)) +; (spec-equal? spec spec*))) +; (sow impl))))) + +;; Finds the best operator implemenation for a given +;; FPCore expression, input representations, and rounding properties. +;; Panics if none can be found. +(define (get-fpcore-impl expr ireprs prop-dict #:impls [all-impls (all-active-operator-impls)]) ; ensure `':precision` is in the prop list - (unless (dict-has-key? props ':precision) - (error 'get-impl "expected key ':precision in properties `~a`" props)) - (define orepr (get-representation (dict-ref props ':precision))) - ; lookup all matching implementations - (define impls* (get-impls spec ireprs orepr #:impls impls)) - (when (null? impls*) + (unless (dict-has-key? prop-dict ':precision) + (error 'get-impl "expected key ':precision in properties `~a`" prop-dict)) + (define orepr (get-representation (dict-ref prop-dict ':precision))) + ; gather all implementations that have the same spec, + ; input and output representations, and its FPCore translation + ; has properties that are found in `prop-dict` + (define impls + (reap [sow] + (for ([impl (in-list all-impls)]) + (when (and (equal? orepr (impl-info impl 'otype)) + (equal? ireprs (impl-info impl 'itype)) + (let () + (match-define (list '! props ... body) (impl-info impl 'fpcore)) + (define prop-dict* (props->dict props)) + (and (andmap (lambda (prop) (member prop prop-dict)) prop-dict*) + (spec-equal? expr body)))) + (sow impl))))) + ; check that we have any matching impls + (when (null? impls) (raise-herbie-missing-error - "No implementation for spec ~a with type ~a -> ~a" - spec + "No implementation for `~a` with type `~a -> ~a`" + expr (string-join (map (λ (r) (format "<~a>" (representation-name r))) ireprs) " ") - (format "<~a>" (representation-type orepr)))) - - (define scored - (for/list ([impl (in-list impls*)]) - (match-define (list '! props* ... _) (impl-info impl 'fpcore)) - (define num-props (length props*)) - - - impl)) - - - impls*) - -; (define (get-impl spec ireprs orepr #:impls [impls (operator-active-impls)]) -; ( + (format "<~a>" (representation-name orepr)))) + ; ; we rank implementations and select the highest scoring one + (define scores + (for/list ([impl (in-list impls)]) + (match-define (list '! props ... _) (impl-info impl 'fpcore)) + (define prop-dict* (props->dict props)) + (define matching (filter (lambda (prop) (member prop prop-dict*)) prop-dict)) + (cons (length matching) (- (length prop-dict) (length matching))))) + ; select the best implementation + ; sort first by the number of matched properties, + ; then tie break on the number of extraneous properties + (match-define (list (cons _ best) _ ...) + (sort (map cons scores impls) + (lambda (x y) + (cond + [(> (car x) (car y)) #t] + [(< (car x) (car y)) #f] + [else (> (cdr x) (cdr y))])) + #:key car)) + best) ;; Among active implementations, looks up an implementation with ;; the operator name `name` and argument representations `ireprs`. @@ -544,45 +555,6 @@ name (format "<~a>" (representation-name repr))))) -; (module+ test -; (require math/flonum -; math/bigfloat -; (submod "types.rkt" internals)) - -; (define (shift bits fn) -; (define shift-val (expt 2 bits)) -; (λ (x) (fn (- x shift-val)))) - -; (define (unshift bits fn) -; (define shift-val (expt 2 bits)) -; (λ (x) (+ (fn x) shift-val))) - -; ; for testing: also in /reprs/binary64.rkt -; (define-representation (binary64 real flonum?) -; bigfloat->flonum -; bf -; (shift 63 ordinal->flonum) -; (unshift 63 flonum->ordinal) -; 64 -; (conjoin number? nan?)) - -; ; correctly-rounded log1pmd(x) for binary64 -; (define-operator-impl (log1pmd log1pmd.f64 binary64) binary64) -; ; correctly-rounded sin(x) for binary64 -; (define-operator-impl (sin sin.acc.f64 binary64) binary64) - -; (define log1pmd-proc (impl-info 'log1pmd.f64 'fl)) -; (define log1pmd-vals '((0.0 . 0.0) (0.5 . 1.0986122886681098) (-0.5 . -1.0986122886681098))) -; (for ([(pt out) (in-dict log1pmd-vals)]) -; (check-equal? (log1pmd-proc pt) out (format "log1pmd(~a) = ~a" pt out))) - -; (define sin-proc (impl-info 'sin.acc.f64 'fl)) -; (define sin-vals '((0.0 . 0.0) (1.0 . 0.8414709848078965) (-1.0 . -0.8414709848078965))) -; (for ([(pt out) (in-dict sin-vals)]) -; (check-equal? (sin-proc pt) out (format "sin(~a) = ~a" pt out))) - -; (void)) - ;; Casts and precision changes (define (cast-impl? x) diff --git a/src/syntax/test-syntax.rkt b/src/syntax/test-syntax.rkt new file mode 100644 index 000000000..125599d42 --- /dev/null +++ b/src/syntax/test-syntax.rkt @@ -0,0 +1,61 @@ +#lang racket + +(require "load-plugin.rkt" + "syntax.rkt" + "types.rkt" + (submod "syntax.rkt" internals)) + +(module+ test + (require rackunit + math/bigfloat) + + (load-herbie-builtins) + + ; log1pmd(x) = log1p(x) - log1p(-x) + + (define-operator (log1pmd real) real) + + (define-operator-impl (log1pmd log1pmd.f64 binary64) + binary64 + [spec (lambda (x) (- (log (+ 1 x)) (log (+ 1 (neg x)))))] + [fpcore (! :precision binary64 (log1pmd x))]) + + (define log1pmd-proc (impl-info 'log1pmd.f64 'fl)) + (define log1pmd-vals '((0.0 . 0.0) (0.5 . 1.0986122886681098) (-0.5 . -1.0986122886681098))) + (for ([(pt out) (in-dict log1pmd-vals)]) + (check-equal? (log1pmd-proc pt) out (format "log1pmd(~a) = ~a" pt out))) + + ; fast sine + + (define-operator-impl (sin fast-sin.f64 binary64) + binary64 + [spec (lambda (x) (sin x))] + [fpcore (! :precision binary64 :math-library fast (sin x))] + [fl + (lambda (x) + (parameterize ([bf-precision 12]) + (bigfloat->flonum (bfsin (bf x)))))]) + + (define sin-proc (impl-info 'fast-sin.f64 'fl)) + (define sin-vals '((0.0 . 0.0) (1.0 . 0.841552734375) (-1.0 . -0.841552734375))) + (for ([(pt out) (in-dict sin-vals)]) + (check-equal? (sin-proc pt) out (format "sin(~a) = ~a" pt out))) + + ; get-fpcore-impl + + (define f64 (get-representation 'binary64)) + (define (get-impl expr itypes props) + (get-fpcore-impl expr itypes props #:impls (all-operator-impls))) + + + (check-equal? (get-impl '(+ x y) (list f64 f64) '((:precision . binary64))) '+.f64) + (check-equal? (get-impl '(+ a b) (list f64 f64) '((:precision . binary64))) '+.f64) + (check-equal? + (get-impl '(+ a b) (list f64 f64) '((:precision . binary64) (:description . "test"))) + '+.f64) + + (check-equal? (get-impl '(log1pmd x) (list f64) '((:precision . binary64))) 'log1pmd.f64) + (check-equal? (get-impl '(sin x) (list f64) '((:precision . binary64))) 'sin.f64) + (check-equal? (get-impl '(sin x) (list f64) '((:precision . binary64) (:math-library . fast))) 'fast-sin.f64) + + (void)) diff --git a/src/utils/common.rkt b/src/utils/common.rkt index 91a3b4aae..a32f14c3b 100644 --- a/src/utils/common.rkt +++ b/src/utils/common.rkt @@ -29,6 +29,8 @@ format-accuracy format-cost web-resource + props->dict + dict->props (all-from-out "../config.rkt")) (module+ test @@ -289,7 +291,8 @@ [(list key) (error 'props->dict "unmatched key" key)] [(list) dict]))) -(define (dict->prop prop-dict) +(define/contract (dict->props prop-dict) + (-> (listof (cons/c symbol? any/c)) list?) (apply append (for/list ([(k v) (in-dict prop-dict)]) (list k v)))) From b66dd285c0b19b902cd635e18fa6c20382251124 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Fri, 2 Aug 2024 13:31:38 -0700 Subject: [PATCH 07/64] new `prog->fpcore` (wip) --- src/api/demo.rkt | 2 +- src/api/sandbox.rkt | 15 +++-- src/core/programs.rkt | 10 ++-- src/platforms/bool.rkt | 26 +++++++-- src/reports/common.rkt | 43 +++++++------- src/syntax/sugar.rkt | 116 ++++++++++++++++++++++++++++++------- src/syntax/test-syntax.rkt | 9 ++- 7 files changed, 159 insertions(+), 62 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index 6b9b06c70..88a2d5e5e 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -487,7 +487,7 @@ (define sample (hash-ref post-data 'sample)) (define seed (hash-ref post-data 'seed #f)) (define test (parse-test formula)) - (define expr (prog->fpcore (test-input test))) + (define expr (prog->fpcore (test-input test) (test-context test))) (define pcontext (json->pcontext sample (test-context test))) (define command (create-job 'local-error diff --git a/src/api/sandbox.rkt b/src/api/sandbox.rkt index 78c9bd6bf..873561678 100644 --- a/src/api/sandbox.rkt +++ b/src/api/sandbox.rkt @@ -292,15 +292,15 @@ (table-row (test-name test) (test-identifier test) status - (prog->fpcore (test-pre test)) + (prog->fpcore (test-pre test) (test-context test)) preprocess (representation-name repr) '() ; TODO: eliminate field (test-vars test) (map car (job-result-warnings result)) - (prog->fpcore (test-input test)) + (prog->fpcore (test-input test) (test-context test)) #f - (prog->fpcore (test-spec test)) + (prog->fpcore (test-spec test) (test-context test)) (test-output test) #f #f @@ -390,12 +390,11 @@ [_ (error 'get-table-data "unknown result type ~a" status)])) (define (unparse-result row #:expr [expr #f] #:description [descr #f]) + (define vars (table-row-vars row)) (define repr (get-representation (table-row-precision row))) + (define ctx (context vars repr (map (const repr) vars))) ; TODO: this seems wrong (define expr* (or expr (table-row-output row) (table-row-input row))) - (define top - (if (table-row-identifier row) - (list (table-row-identifier row) (table-row-vars row)) - (list (table-row-vars row)))) + (define top (if (table-row-identifier row) (list (table-row-identifier row) vars) (list vars))) `(FPCore ,@top :herbie-status ,(string->symbol (table-row-status row)) @@ -421,4 +420,4 @@ ,@(append (for/list ([(target enabled?) (in-dict (table-row-target-prog row))] #:when enabled?) `(:alt ,target))) - ,(prog->fpcore expr*))) + ,(prog->fpcore expr* ctx))) diff --git a/src/core/programs.rkt b/src/core/programs.rkt index d5a9754e5..fc1a9756a 100644 --- a/src/core/programs.rkt +++ b/src/core/programs.rkt @@ -119,10 +119,12 @@ [`(,op ,args ...) (remove-duplicates (append-map free-variables args))])) (define (replace-vars dict expr) - (cond - [(dict-has-key? dict expr) (dict-ref dict expr)] - [(list? expr) (cons (replace-vars dict (car expr)) (map (curry replace-vars dict) (cdr expr)))] - [#t expr])) + (let loop ([expr expr]) + (match expr + [(? literal?) expr] + [(? number?) expr] + [(? symbol?) (dict-ref dict expr expr)] + [(list op args ...) (cons op (map loop args))]))) (define location? (listof natural-number/c)) diff --git a/src/platforms/bool.rkt b/src/platforms/bool.rkt index 527a61498..ca01f5d2c 100644 --- a/src/platforms/bool.rkt +++ b/src/platforms/bool.rkt @@ -20,20 +20,38 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-constants bool [TRUE TRUE true] [FALSE FALSE false]) +(define-operator-impl (TRUE TRUE) bool + [spec (lambda () (TRUE))] + [fpcore TRUE] + [fl (lambda () true)]) + +(define-operator-impl (FALSE FALSE) bool + [spec (lambda () (FALSE))] + [fpcore FALSE] + [fl (lambda () false)]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; operators ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (and-fn . as) (andmap identity as)) + (define (or-fn . as) (ormap identity as)) -(define-operator-impl (not not bool) bool [fl not]) +(define-operator-impl (not not bool) bool + [spec (lambda (x) (not x))] + [fpcore (not x)] + [fl not]) -(define-operator-impl (and and bool bool) bool [fl and-fn]) +(define-operator-impl (and and bool bool) bool + [spec (lambda (x y) (and x y))] + [fpcore (and x y)] + [fl and-fn]) -(define-operator-impl (or or bool bool) bool [fl or-fn]) +(define-operator-impl (or or bool bool) bool + [spec (lambda (x y) (or x y))] + [fpcore (or x y)] + [fl or-fn]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; rules ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/reports/common.rkt b/src/reports/common.rkt index e97472099..4019126f4 100644 --- a/src/reports/common.rkt +++ b/src/reports/common.rkt @@ -56,7 +56,7 @@ (write-xexpr xexpr out)) (define (program->fpcore expr ctx #:ident [ident #f]) - (define body (prog->fpcore expr)) + (define body (prog->fpcore expr ctx)) (if ident (list 'FPCore ident (context-vars ctx) body) (list 'FPCore (context-vars ctx) body))) (define (fpcore-add-props core props) @@ -293,8 +293,9 @@ `(div ,(if (equal? precondition '(TRUE)) "" - `(div ([id "precondition"]) - (div ((class "program math")) "\\[" ,(expr->tex (prog->fpcore precondition)) "\\]"))) + `(div + ([id "precondition"]) + (div ((class "program math")) "\\[" ,(expr->tex (prog->fpcore precondition ctx)) "\\]"))) (div ((class "implementation") [data-language "Math"]) (div ((class "program math")) "\\[" ,math-out "\\]")) ,@(for/list ([(lang out) (in-dict versions)]) @@ -316,23 +317,25 @@ (-> test? string?) (define output-repr (test-output-repr test)) (string-join - (filter - identity - (list - (if (test-identifier test) - (format "(FPCore ~a ~a" (test-identifier test) (test-vars test)) - (format "(FPCore ~a" (test-vars test))) - (format " :name ~s" (test-name test)) - (format " :precision ~s" (representation-name (test-output-repr test))) - (if (equal? (test-pre test) '(TRUE)) #f (format " :pre ~a" (prog->fpcore (test-pre test)))) - (if (equal? (test-expected test) #t) #f (format " :herbie-expected ~a" (test-expected test))) - (and (test-output test) - (not (null? (test-output test))) - (format "\n~a" - (string-join (map (lambda (exp) (format " :alt\n ~a\n" (car exp))) - (test-output test)) - "\n"))) - (format " ~a)" (prog->fpcore (test-input test))))) + (filter identity + (list (if (test-identifier test) + (format "(FPCore ~a ~a" (test-identifier test) (test-vars test)) + (format "(FPCore ~a" (test-vars test))) + (format " :name ~s" (test-name test)) + (format " :precision ~s" (representation-name (test-output-repr test))) + (if (equal? (test-pre test) '(TRUE)) + #f + (format " :pre ~a" (prog->fpcore (test-pre test) (test-context test)))) + (if (equal? (test-expected test) #t) + #f + (format " :herbie-expected ~a" (test-expected test))) + (and (test-output test) + (not (null? (test-output test))) + (format "\n~a" + (string-join (map (lambda (exp) (format " :alt\n ~a\n" (car exp))) + (test-output test)) + "\n"))) + (format " ~a)" (prog->fpcore (test-input test) (test-context test))))) "\n")) (define (format-percent num den) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 5988365ca..229846cef 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -127,6 +127,9 @@ ; other [_ expr]))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FPCore -> LImpl + ;; Translates from FPCore to an LImpl (define (fpcore->prog prog ctx) (define-values (expr* _) @@ -178,27 +181,100 @@ (values (literal num prec) (context-repr ctx))]))) expr*) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; LImpl -> FPCore + +;; Returns the dictionary FPCore properties required to +;; round trip when converted to and from FPCore. +; (define (prog->req-props expr) +; (match expr +; [(? literal?) '()] +; [(? variable?) '()] +; [(list 'if cond ift iff) (prog->req-props ift)] +; [(list (? impl-exists? impl) _ ...) +; (match-define (list '! props ... _) (impl-info impl 'fpcore)) +; (props->dict props)])) + +;; Instruction vector index +(struct index (v) #:prefab) + +;; Translates a literal (LImpl) to an FPCore expr +(define (literal->fpcore x) + (match x + [(literal -inf.0 _) '(- INFINITY)] + [(literal +inf.0 _) 'INFINITY] + [(literal v (or 'binary64 'binary32)) (exact->inexact v)] + [(literal v _) v])) + +;; Translates from LImpl to an instruction vector where each +;; expression is evaluated under an explicit rounding context. +;; The output resembles A-normal form, so we will call the output "normal". +;; NOTE: This translation results in a verbose output but at least it's right +(define (prog->normal expr) + (define exprs '()) + (define (push! impl node) + (define id (length exprs)) + (set! exprs (cons (cons impl node) exprs)) + (index id)) + + (define (munge expr) + (match expr + [(? literal?) (literal->fpcore expr)] + [(? symbol?) expr] + [(list 'if cond ift iff) + (list 'if (munge cond) (munge ift) (munge iff))] + [(list (? impl-exists? impl) args ...) + (define args* (map munge args)) + (match-define (list _ vars _) (impl-info impl 'spec)) + (push! impl (replace-vars (map cons vars args*) (impl-info impl 'fpcore)))])) + + (define node (munge expr)) + (unless (index? node) + (set! exprs (cons node exprs))) + (list->vector (reverse exprs))) + + +; (define (prog->normal expr ctx) +; (define vars (list->mutable-seteq (context-vars ctx))) +; (define counter 0) +; (define (gensym) +; (set! counter (add1 counter)) +; (match (string->symbol (format "t~a" counter)) +; [(? (curry set-member? vars)) (gensym)] +; [x +; (set-add! vars x) +; x])) + ;; Translates from LImpl to an FPCore. -(define (prog->fpcore expr) - (match expr - [`(if ,cond ,ift ,iff) `(if ,(prog->fpcore cond) ,(prog->fpcore ift) ,(prog->fpcore iff))] - [`(,(? cast-impl? impl) ,body) - (define prec (representation-name (impl-info impl 'otype))) - `(! :precision ,prec (cast ,(prog->fpcore body)))] - [`(,impl) (impl->operator impl)] - [`(,impl ,args ...) - (define op (impl->operator impl)) - (define args* (map prog->fpcore args)) - (match (cons op args*) - [`(neg ,arg) `(- ,arg)] - [expr expr])] - [(? variable?) expr] - [(? literal?) - (match (literal-value expr) - [-inf.0 '(- INFINITY)] - [+inf.0 'INFINITY] - [+nan.0 'NAN] - [v (if (set-member? '(binary64 binary32) (literal-precision expr)) (exact->inexact v) v)])])) +;; The implementation of this procedure is complicated since +;; (1) every operator implementation requires certain (FPCore) rounding properties +;; (2) rounding contexts have lexical scoping +;; FPCore can be precise, but that precision comes at the cost of complexity. +(define (prog->fpcore expr ctx) + (eprintf "~a\n" expr) + ; step 1: convert to an instruction vector where + ; each expression is evaluated under explicit rounding contexts + (define ivec (prog->normal expr)) + (define ivec-len (vector-length ivec)) + (define root (vector-ref ivec (sub1 ivec-len))) + (eprintf "~a\n" ivec) + + ; step 2: condense nodes + ; the value of a let binding may be inlined if converting back to LImpl + ; results in the same + (define condensed (mutable-set)) + (define body + (let loop ([node root]) + (match node + [(? number?) node] + [(? symbol?) node] + [_ (error 'condense "unimplemented: ~a"node)]))) + + (error 'prog->fpcore "unimplemented")) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; LImpl -> LSpec ;; Translates an LImpl to a LSpec. (define (prog->spec expr) diff --git a/src/syntax/test-syntax.rkt b/src/syntax/test-syntax.rkt index 125599d42..c9f7319ab 100644 --- a/src/syntax/test-syntax.rkt +++ b/src/syntax/test-syntax.rkt @@ -47,15 +47,14 @@ (define (get-impl expr itypes props) (get-fpcore-impl expr itypes props #:impls (all-operator-impls))) - (check-equal? (get-impl '(+ x y) (list f64 f64) '((:precision . binary64))) '+.f64) (check-equal? (get-impl '(+ a b) (list f64 f64) '((:precision . binary64))) '+.f64) - (check-equal? - (get-impl '(+ a b) (list f64 f64) '((:precision . binary64) (:description . "test"))) - '+.f64) + (check-equal? (get-impl '(+ a b) (list f64 f64) '((:precision . binary64) (:description . "test"))) + '+.f64) (check-equal? (get-impl '(log1pmd x) (list f64) '((:precision . binary64))) 'log1pmd.f64) (check-equal? (get-impl '(sin x) (list f64) '((:precision . binary64))) 'sin.f64) - (check-equal? (get-impl '(sin x) (list f64) '((:precision . binary64) (:math-library . fast))) 'fast-sin.f64) + (check-equal? (get-impl '(sin x) (list f64) '((:precision . binary64) (:math-library . fast))) + 'fast-sin.f64) (void)) From feac8c597acbc9feef778cf94e6fd2cd6a8fd6fb Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Fri, 2 Aug 2024 14:52:56 -0700 Subject: [PATCH 08/64] working without inlining --- src/platforms/binary32.rkt | 6 +- src/platforms/binary64.rkt | 6 +- src/platforms/bool.rkt | 25 +----- src/syntax/sugar.rkt | 153 +++++++++++++++++++++++-------------- src/syntax/syntax.rkt | 8 +- src/syntax/types.rkt | 4 +- 6 files changed, 119 insertions(+), 83 deletions(-) diff --git a/src/platforms/binary32.rkt b/src/platforms/binary32.rkt index 6f7aff8a0..760150fa2 100644 --- a/src/platforms/binary32.rkt +++ b/src/platforms/binary32.rkt @@ -46,7 +46,11 @@ (begin (define-libm-impls/binary32* (itype ... otype) name ...) ...)) -(define-operator-impl (neg neg.f32 binary32) binary32 [fl fl32-]) +(define-operator-impl (neg neg.f32 binary32) binary32 + [spec (lambda (x) (neg x))] + [fpcore (! :precision binary32 (- x))] + [fl fl32-]) + (define-operator-impl (+ +.f32 binary32 binary32) binary32 [fl fl32+]) (define-operator-impl (- -.f32 binary32 binary32) binary32 [fl fl32-]) (define-operator-impl (* *.f32 binary32 binary32) binary32 [fl fl32*]) diff --git a/src/platforms/binary64.rkt b/src/platforms/binary64.rkt index 9f05861a1..7a5a3d41b 100644 --- a/src/platforms/binary64.rkt +++ b/src/platforms/binary64.rkt @@ -46,7 +46,11 @@ (begin (define-libm-impls/binary64* (itype ... otype) name ...) ...)) -(define-operator-impl (neg neg.f64 binary64) binary64 [fl -]) +(define-operator-impl (neg neg.f64 binary64) binary64 + [spec (lambda (x) (neg x))] + [fpcore (! :precision binary64 (- x))] + [fl -]) + (define-operator-impl (+ +.f64 binary64 binary64) binary64 [fl +]) (define-operator-impl (- -.f64 binary64 binary64) binary64 [fl -]) (define-operator-impl (* *.f64 binary64 binary64) binary64 [fl *]) diff --git a/src/platforms/bool.rkt b/src/platforms/bool.rkt index ca01f5d2c..878fd9839 100644 --- a/src/platforms/bool.rkt +++ b/src/platforms/bool.rkt @@ -20,15 +20,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-operator-impl (TRUE TRUE) bool - [spec (lambda () (TRUE))] - [fpcore TRUE] - [fl (lambda () true)]) - -(define-operator-impl (FALSE FALSE) bool - [spec (lambda () (FALSE))] - [fpcore FALSE] - [fl (lambda () false)]) +(define-constants bool [TRUE TRUE true] [FALSE FALSE false]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; operators ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -38,20 +30,11 @@ (define (or-fn . as) (ormap identity as)) -(define-operator-impl (not not bool) bool - [spec (lambda (x) (not x))] - [fpcore (not x)] - [fl not]) +(define-operator-impl (not not bool) bool [fl not]) -(define-operator-impl (and and bool bool) bool - [spec (lambda (x y) (and x y))] - [fpcore (and x y)] - [fl and-fn]) +(define-operator-impl (and and bool bool) bool [fl and-fn]) -(define-operator-impl (or or bool bool) bool - [spec (lambda (x y) (or x y))] - [fpcore (or x y)] - [fl or-fn]) +(define-operator-impl (or or bool bool) bool [fl or-fn]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; rules ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 229846cef..f202d1321 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -1,14 +1,5 @@ -#lang racket - -(require "../core/programs.rkt" - "../utils/common.rkt" - "syntax.rkt" - "types.rkt") - -(provide fpcore->prog - prog->fpcore - prog->spec) - +;; Expression conversions +;; ;; Herbie uses three expression languages. ;; All formats are S-expressions with variables, numbers, and applications. ;; @@ -66,6 +57,20 @@ ;; ::= ;; +#lang racket + +(require "../core/programs.rkt" + "../utils/common.rkt" + "syntax.rkt" + "types.rkt") + +(provide fpcore->prog + prog->fpcore + prog->spec) + +(module+ test + (require rackunit)) + ;; Expression pre-processing for normalizing expressions. ;; Used for conversion from FPCore to other IRs. (define (expand-expr expr) @@ -184,17 +189,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; LImpl -> FPCore -;; Returns the dictionary FPCore properties required to -;; round trip when converted to and from FPCore. -; (define (prog->req-props expr) -; (match expr -; [(? literal?) '()] -; [(? variable?) '()] -; [(list 'if cond ift iff) (prog->req-props ift)] -; [(list (? impl-exists? impl) _ ...) -; (match-define (list '! props ... _) (impl-info impl 'fpcore)) -; (props->dict props)])) - ;; Instruction vector index (struct index (v) #:prefab) @@ -212,38 +206,40 @@ ;; NOTE: This translation results in a verbose output but at least it's right (define (prog->normal expr) (define exprs '()) + (define impls '()) (define (push! impl node) (define id (length exprs)) - (set! exprs (cons (cons impl node) exprs)) + (set! exprs (cons node exprs)) + (set! impls (cons impl impls)) (index id)) - (define (munge expr) + (define (munge expr #:root? [root? #f]) (match expr [(? literal?) (literal->fpcore expr)] [(? symbol?) expr] - [(list 'if cond ift iff) - (list 'if (munge cond) (munge ift) (munge iff))] + [(list 'if cond ift iff) (list 'if (munge cond) (munge ift) (munge iff))] [(list (? impl-exists? impl) args ...) (define args* (map munge args)) (match-define (list _ vars _) (impl-info impl 'spec)) - (push! impl (replace-vars (map cons vars args*) (impl-info impl 'fpcore)))])) - - (define node (munge expr)) - (unless (index? node) - (set! exprs (cons node exprs))) - (list->vector (reverse exprs))) + (define node (replace-vars (map cons vars args*) (impl-info impl 'fpcore))) + (if root? node (push! impl node))])) + (define root (munge expr #:root? #t)) + (values root (list->vector (reverse exprs)) (list->vector (reverse impls)))) -; (define (prog->normal expr ctx) -; (define vars (list->mutable-seteq (context-vars ctx))) -; (define counter 0) -; (define (gensym) -; (set! counter (add1 counter)) -; (match (string->symbol (format "t~a" counter)) -; [(? (curry set-member? vars)) (gensym)] -; [x -; (set-add! vars x) -; x])) +;; Returns the dictionary FPCore properties required to +;; round trip when converted to and from FPCore. +; (define (prog->req-props expr) +; (match expr +; [(? literal?) '()] +; [(? variable?) '()] +; [(list 'if cond ift iff) (prog->req-props ift)] +; [(list (? impl-exists? impl) _ ...) +; (match-define (list '! props ... _) (impl-info impl 'fpcore)) +; (props->dict props)])) +(define (impl->req-props impl) + (match-define (list '! props ... _) (impl-info impl 'fpcore)) + (props->dict props)) ;; Translates from LImpl to an FPCore. ;; The implementation of this procedure is complicated since @@ -251,27 +247,68 @@ ;; (2) rounding contexts have lexical scoping ;; FPCore can be precise, but that precision comes at the cost of complexity. (define (prog->fpcore expr ctx) - (eprintf "~a\n" expr) ; step 1: convert to an instruction vector where ; each expression is evaluated under explicit rounding contexts - (define ivec (prog->normal expr)) - (define ivec-len (vector-length ivec)) - (define root (vector-ref ivec (sub1 ivec-len))) - (eprintf "~a\n" ivec) + (define-values (root ivec impls) (prog->normal expr)) - ; step 2: condense nodes - ; the value of a let binding may be inlined if converting back to LImpl - ; results in the same - (define condensed (mutable-set)) - (define body - (let loop ([node root]) - (match node - [(? number?) node] - [(? symbol?) node] - [_ (error 'condense "unimplemented: ~a"node)]))) + ; step 2: inline nodes + ; inlining let bindings is generally unsound with rounding properties + ; we only inline those that result in the same operator implementation + ; when converting back from FPCore to LImpl + (define inlined (mutable-set)) + (define global-prop-dict (repr->prop (context-repr ctx))) - (error 'prog->fpcore "unimplemented")) + (define (build node prop-dict) + (match node + [(? number?) node] ; number + [(? symbol?) node] ; variable + [(index idx) ; let-bound variable + (define expr (build (vector-ref ivec idx) global-prop-dict)) + (vector-set! ivec idx expr) + node] + [(list '! props ... body) ; explicit rounding context + (define prop-dict* (props->dict props)) + (define new-prop-dict + (for/list ([(k v) (in-dict prop-dict*)] + #:unless (and (dict-has-key? prop-dict k) (equal? (dict-ref prop-dict k) v))) + (cons k v))) + (if (null? new-prop-dict) + (build body prop-dict*) + `(! ,@(dict->props new-prop-dict) ,(build body prop-dict*)))] + [(list op args ...) + (define args* (map (lambda (e) (build e prop-dict)) args)) + `(,op ,@args*)])) + + (define body (build root global-prop-dict)) + + ; step 3: construct the actual FPCore expression from + ; the remaining let-bindings and body + (define vars (list->mutable-seteq (context-vars ctx))) + (define counter 0) + (define (gensym) + (set! counter (add1 counter)) + (match (string->symbol (format "t~a" counter)) + [(? (curry set-member? vars)) (gensym)] + [x + (set-add! vars x) + x])) + + (define id->name (make-vector (vector-length ivec) #f)) + (for ([_ (in-vector ivec)] [idx (in-naturals)]) + (unless (set-member? inlined idx) + (vector-set! id->name idx (gensym)))) + + (define (remove-indices expr) + (match expr + [(? number?) expr] + [(? symbol?) expr] + [(index idx) (vector-ref id->name idx)] + [(list '! props ... body) `(! ,@props ,(remove-indices body))] + [(list op args ...) `(,op ,@(map remove-indices args))])) + (for/fold ([body (remove-indices body)]) + ([i (in-range (sub1 (vector-length ivec)) -1 -1)] #:when (vector-ref id->name i)) + `(let ([,(vector-ref id->name i) ,(remove-indices (vector-ref ivec i))]) ,body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; LImpl -> LSpec diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 01d305418..93a25f7f5 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -378,12 +378,18 @@ [spec (check-spec! name (map representation-type ireprs) (representation-type orepr) spec) spec])) + ; extract or generate the fpcore translation (match-define `(,(or 'lambda 'λ) ,vars ,body) spec) (define fpcore (match (dict-ref attrib-dict 'fpcore #f) ; not provided => need to generate it - [#f `(! :precision ,(representation-name orepr) (,op ,@vars))] + [#f + ; special case: boolean-valued operations do not + ; need a precision annotation + (if (equal? orepr (get-representation 'bool)) + `(,op ,@vars) + `(! :precision ,(representation-name orepr) (,op ,@vars)))] ; provided -> TODO: check free variables [fpcore fpcore])) diff --git a/src/syntax/types.rkt b/src/syntax/types.rkt index 6cb649ac9..abc3456ee 100644 --- a/src/syntax/types.rkt +++ b/src/syntax/types.rkt @@ -51,7 +51,9 @@ ;; Converts a representation into a rounding property (define (repr->prop repr) - (list (cons ':precision (representation-name repr)))) + (match (representation-type repr) + ['bool '()] + ['real (list (cons ':precision (representation-name repr)))])) ;; Repr / operator generation ;; Some plugins might define 'parameterized' reprs (e.g. fixed point with From f50d6355175d14b90a18a31790385aa1442611af Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Fri, 2 Aug 2024 16:59:49 -0700 Subject: [PATCH 09/64] working --- src/platforms/binary32.rkt | 11 +-- src/platforms/binary64.rkt | 11 +-- src/syntax/sugar.rkt | 149 +++++++++++++++++++++++-------------- src/syntax/syntax.rkt | 39 ++++------ 4 files changed, 118 insertions(+), 92 deletions(-) diff --git a/src/platforms/binary32.rkt b/src/platforms/binary32.rkt index 760150fa2..c6ba3de12 100644 --- a/src/platforms/binary32.rkt +++ b/src/platforms/binary32.rkt @@ -46,10 +46,11 @@ (begin (define-libm-impls/binary32* (itype ... otype) name ...) ...)) -(define-operator-impl (neg neg.f32 binary32) binary32 - [spec (lambda (x) (neg x))] - [fpcore (! :precision binary32 (- x))] - [fl fl32-]) +(define-operator-impl (neg neg.f32 binary32) + binary32 + [spec (lambda (x) (neg x))] + [fpcore (! :precision binary32 (- x))] + [fl fl32-]) (define-operator-impl (+ +.f32 binary32 binary32) binary32 [fl fl32+]) (define-operator-impl (- -.f32 binary32 binary32) binary32 [fl fl32-]) @@ -119,7 +120,7 @@ (define-operator-impl (hypot hypot.f32 binary32 binary32) binary32 [spec (lambda (x y) (sqrt (+ (* x x) (* y y))))] - [fpcore (! :precision binary32 (hypot x))] + [fpcore (! :precision binary32 (hypot x y))] [fl c_hypotf])) (when c_fmaf diff --git a/src/platforms/binary64.rkt b/src/platforms/binary64.rkt index 7a5a3d41b..46848486a 100644 --- a/src/platforms/binary64.rkt +++ b/src/platforms/binary64.rkt @@ -46,10 +46,11 @@ (begin (define-libm-impls/binary64* (itype ... otype) name ...) ...)) -(define-operator-impl (neg neg.f64 binary64) binary64 - [spec (lambda (x) (neg x))] - [fpcore (! :precision binary64 (- x))] - [fl -]) +(define-operator-impl (neg neg.f64 binary64) + binary64 + [spec (lambda (x) (neg x))] + [fpcore (! :precision binary64 (- x))] + [fl -]) (define-operator-impl (+ +.f64 binary64 binary64) binary64 [fl +]) (define-operator-impl (- -.f64 binary64 binary64) binary64 [fl -]) @@ -119,7 +120,7 @@ (define-operator-impl (hypot hypot.f64 binary64 binary64) binary64 [spec (lambda (x y) (sqrt (+ (* x x) (* y y))))] - [fpcore (! :precision binary64 (hypot x))] + [fpcore (! :precision binary64 (hypot x y))] [fl c_hypot])) (when c_fma diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index f202d1321..f1bcfa746 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -200,10 +200,13 @@ [(literal v (or 'binary64 'binary32)) (exact->inexact v)] [(literal v _) v])) +;; Step 1. ;; Translates from LImpl to an instruction vector where each ;; expression is evaluated under an explicit rounding context. ;; The output resembles A-normal form, so we will call the output "normal". -;; NOTE: This translation results in a verbose output but at least it's right +;; NOTE: This translation results in a verbose output but at least it's right. +;; Ignoring let-bound variables, the expressions are in FPCore + (define (prog->normal expr) (define exprs '()) (define impls '()) @@ -225,64 +228,84 @@ (if root? node (push! impl node))])) (define root (munge expr #:root? #t)) - (values root (list->vector (reverse exprs)) (list->vector (reverse impls)))) -;; Returns the dictionary FPCore properties required to -;; round trip when converted to and from FPCore. -; (define (prog->req-props expr) -; (match expr -; [(? literal?) '()] -; [(? variable?) '()] -; [(list 'if cond ift iff) (prog->req-props ift)] -; [(list (? impl-exists? impl) _ ...) -; (match-define (list '! props ... _) (impl-info impl 'fpcore)) -; (props->dict props)])) -(define (impl->req-props impl) - (match-define (list '! props ... _) (impl-info impl 'fpcore)) - (props->dict props)) + (values root (list->vector (reverse exprs)) (list->vector (reverse impls)))) -;; Translates from LImpl to an FPCore. -;; The implementation of this procedure is complicated since -;; (1) every operator implementation requires certain (FPCore) rounding properties -;; (2) rounding contexts have lexical scoping -;; FPCore can be precise, but that precision comes at the cost of complexity. -(define (prog->fpcore expr ctx) - ; step 1: convert to an instruction vector where - ; each expression is evaluated under explicit rounding contexts - (define-values (root ivec impls) (prog->normal expr)) +;; Step 2. +;; Inlines let bindings; let-inlining is generally unsound with +;; rounding properties (the parent context may change), +;; so we only inline those that result in the same operator +;; implementation when converting back from FPCore to LImpl. - ; step 2: inline nodes - ; inlining let bindings is generally unsound with rounding properties - ; we only inline those that result in the same operator implementation - ; when converting back from FPCore to LImpl - (define inlined (mutable-set)) +(define (inline! root ivec impls ctx) (define global-prop-dict (repr->prop (context-repr ctx))) - - (define (build node prop-dict) + (let loop ([node root] [prop-dict global-prop-dict]) (match node [(? number?) node] ; number [(? symbol?) node] ; variable [(index idx) ; let-bound variable - (define expr (build (vector-ref ivec idx) global-prop-dict)) - (vector-set! ivec idx expr) - node] + (define expr (vector-ref ivec idx)) ; subexpression + (define impl (vector-ref impls idx)) ; desired impl we want to preserve + ; we check what happens if we inline + (define impl* + (match expr + [(list '! props ... (list op args ...)) + ; rounding context updated parent context + (define prop-dict* (apply dict-set prop-dict props)) + (define pattern (cons op (map (lambda (_) (gensym)) args))) + (get-fpcore-impl pattern (impl-info impl 'itype) prop-dict*)] + [(list op args ...) + ; rounding context inherited from parent context + (define pattern (cons op (map (lambda (_) (gensym)) args))) + (get-fpcore-impl pattern (impl-info impl 'itype) prop-dict)])) + (cond + [(equal? impl impl*) ; inlining is safe + (define expr* (loop expr prop-dict)) + (vector-set! ivec idx #f) + expr*] + [else ; inlining is not safe + (define expr* (loop expr global-prop-dict)) + (vector-set! ivec idx expr*) + node])] [(list '! props ... body) ; explicit rounding context (define prop-dict* (props->dict props)) + (define body* (loop body prop-dict*)) (define new-prop-dict (for/list ([(k v) (in-dict prop-dict*)] #:unless (and (dict-has-key? prop-dict k) (equal? (dict-ref prop-dict k) v))) (cons k v))) - (if (null? new-prop-dict) - (build body prop-dict*) - `(! ,@(dict->props new-prop-dict) ,(build body prop-dict*)))] - [(list op args ...) - (define args* (map (lambda (e) (build e prop-dict)) args)) - `(,op ,@args*)])) + (if (null? new-prop-dict) body* `(! ,@(dict->props new-prop-dict) ,body*))] + [(list op args ...) ; operator application + (define args* (map (lambda (e) (loop e prop-dict)) args)) + `(,op ,@args*)]))) - (define body (build root global-prop-dict)) +;; Step 3. +;; Construct the final FPCore expression using remaining let-bindings +;; and the let-free body from the previous step. - ; step 3: construct the actual FPCore expression from - ; the remaining let-bindings and body +(define (reachable-indices ivec expr) + (define reachable (mutable-set)) + (let loop ([expr expr]) + (match expr + [(? number?) (void)] + [(? symbol?) (void)] + [(index idx) + (set-add! reachable idx) + (loop (vector-ref ivec idx))] + [(list _ args ...) (for-each loop args)])) + reachable) + +(define (remove-indices id->name expr) + (let loop ([expr expr]) + (match expr + [(? number?) expr] + [(? symbol?) expr] + [(index idx) (hash-ref id->name idx)] + [(list '! props ... body) `(! ,@props ,(loop body))] + [(list op args ...) `(,op ,@(map loop args))]))) + +(define (build-expr expr ivec ctx) + ; variable generation (define vars (list->mutable-seteq (context-vars ctx))) (define counter 0) (define (gensym) @@ -293,22 +316,34 @@ (set-add! vars x) x])) - (define id->name (make-vector (vector-length ivec) #f)) - (for ([_ (in-vector ivec)] [idx (in-naturals)]) - (unless (set-member? inlined idx) - (vector-set! id->name idx (gensym)))) + ; need fresh variables for reachable, non-inlined subexpressions + (define reachable (reachable-indices ivec expr)) + (define id->name (make-hash)) + (for ([expr (in-vector ivec)] [idx (in-naturals)]) + (when (and expr (set-member? reachable idx)) + (hash-set! id->name idx (gensym)))) - (define (remove-indices expr) - (match expr - [(? number?) expr] - [(? symbol?) expr] - [(index idx) (vector-ref id->name idx)] - [(list '! props ... body) `(! ,@props ,(remove-indices body))] - [(list op args ...) `(,op ,@(map remove-indices args))])) + (for/fold ([body (remove-indices id->name expr)]) + ([idx (in-list (sort (hash-keys id->name) >))]) + (define var (hash-ref id->name idx)) + (define val (remove-indices id->name (vector-ref ivec idx))) + `(let ([,var ,val]) ,body))) + +;; Translates from LImpl to an FPCore. +;; The implementation of this procedure is complicated since +;; (1) every operator implementation requires certain (FPCore) rounding properties +;; (2) rounding contexts have lexical scoping +(define (prog->fpcore prog ctx) + ; step 1: convert to an instruction vector where + ; each expression is evaluated under explicit rounding contexts + (define-values (root ivec impls) (prog->normal prog)) - (for/fold ([body (remove-indices body)]) - ([i (in-range (sub1 (vector-length ivec)) -1 -1)] #:when (vector-ref id->name i)) - `(let ([,(vector-ref id->name i) ,(remove-indices (vector-ref ivec i))]) ,body))) + ; step 2: inline nodes + (define body (inline! root ivec impls ctx)) + + ; step 3: construct the actual FPCore expression from + ; the remaining let-bindings and body + (build-expr body ivec ctx)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; LImpl -> LSpec diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 93a25f7f5..5b9389d40 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -474,18 +474,6 @@ ; force result of `pattern-match` to be a boolean (and (pattern-match spec1 spec2) #t)) -;; Returns the list of implementations that implement a given spec -;; and have the given input and output representations. -; (define (get-impls spec ireprs orepr #:impls [impls (all-active-operator-impls)]) -; (reap [sow] -; (for ([impl (in-list impls)]) -; (when (and (equal? orepr (impl-info impl 'otype)) -; (equal? ireprs (impl-info impl 'itype)) -; (let () -; (match-define (list _ _ spec*) (impl-info impl 'spec)) -; (spec-equal? spec spec*))) -; (sow impl))))) - ;; Finds the best operator implemenation for a given ;; FPCore expression, input representations, and rounding properties. ;; Panics if none can be found. @@ -493,33 +481,34 @@ ; ensure `':precision` is in the prop list (unless (dict-has-key? prop-dict ':precision) (error 'get-impl "expected key ':precision in properties `~a`" prop-dict)) - (define orepr (get-representation (dict-ref prop-dict ':precision))) - ; gather all implementations that have the same spec, - ; input and output representations, and its FPCore translation - ; has properties that are found in `prop-dict` + ; gather all implementations that have the same spec, input representations, + ; and its FPCore translation has properties that are found in `prop-dict` (define impls (reap [sow] (for ([impl (in-list all-impls)]) - (when (and (equal? orepr (impl-info impl 'otype)) - (equal? ireprs (impl-info impl 'itype)) + (when (and (equal? ireprs (impl-info impl 'itype)) (let () - (match-define (list '! props ... body) (impl-info impl 'fpcore)) - (define prop-dict* (props->dict props)) + (define-values (prop-dict* body) + (match (impl-info impl 'fpcore) + [(list '! props ... body) (values (props->dict props) body)] + [body (values '() body)])) (and (andmap (lambda (prop) (member prop prop-dict)) prop-dict*) (spec-equal? expr body)))) (sow impl))))) ; check that we have any matching impls (when (null? impls) (raise-herbie-missing-error - "No implementation for `~a` with type `~a -> ~a`" + "No implementation for `~a` under rounding context `~a` with types `~a`" expr - (string-join (map (λ (r) (format "<~a>" (representation-name r))) ireprs) " ") - (format "<~a>" (representation-name orepr)))) + prop-dict + (string-join (map (λ (r) (format "<~a>" (representation-name r))) ireprs) " "))) ; ; we rank implementations and select the highest scoring one (define scores (for/list ([impl (in-list impls)]) - (match-define (list '! props ... _) (impl-info impl 'fpcore)) - (define prop-dict* (props->dict props)) + (define prop-dict* + (match (impl-info impl 'fpcore) + [(list '! props ... _) (props->dict props)] + [_ '()])) (define matching (filter (lambda (prop) (member prop prop-dict*)) prop-dict)) (cons (length matching) (- (length prop-dict) (length matching))))) ; select the best implementation From 956cc67e4a303a136c58607b9b8f2b9aed5ee274 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 5 Aug 2024 10:50:43 -0700 Subject: [PATCH 10/64] cleanup --- src/syntax/sugar.rkt | 35 +++++++++++++++-------------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index f1bcfa746..72aa855d6 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -201,19 +201,17 @@ [(literal v _) v])) ;; Step 1. -;; Translates from LImpl to an instruction vector where each -;; expression is evaluated under an explicit rounding context. -;; The output resembles A-normal form, so we will call the output "normal". -;; NOTE: This translation results in a verbose output but at least it's right. -;; Ignoring let-bound variables, the expressions are in FPCore +;; Translates from LImpl to a series of let bindings such that each +;; local variable is bound once and used at most once. The result is an +;; instruction vector, representing the let bindings; the operator +;; implementation for each instruction, and the final "root" operation/literal. +;; Except for let-bound variables, the subexpressions are in FPCore. -(define (prog->normal expr) - (define exprs '()) - (define impls '()) +(define (prog->let-exprs expr) + (define instrs '()) (define (push! impl node) - (define id (length exprs)) - (set! exprs (cons node exprs)) - (set! impls (cons impl impls)) + (define id (length instrs)) + (set! instrs (cons (cons node impl) instrs)) (index id)) (define (munge expr #:root? [root? #f]) @@ -228,8 +226,7 @@ (if root? node (push! impl node))])) (define root (munge expr #:root? #t)) - - (values root (list->vector (reverse exprs)) (list->vector (reverse impls)))) + (cons (list->vector (reverse instrs)) root)) ;; Step 2. ;; Inlines let bindings; let-inlining is generally unsound with @@ -237,16 +234,15 @@ ;; so we only inline those that result in the same operator ;; implementation when converting back from FPCore to LImpl. -(define (inline! root ivec impls ctx) +(define (inline! root ivec ctx) (define global-prop-dict (repr->prop (context-repr ctx))) (let loop ([node root] [prop-dict global-prop-dict]) (match node [(? number?) node] ; number [(? symbol?) node] ; variable [(index idx) ; let-bound variable - (define expr (vector-ref ivec idx)) ; subexpression - (define impl (vector-ref impls idx)) ; desired impl we want to preserve ; we check what happens if we inline + (match-define (cons expr impl) (vector-ref ivec idx)) (define impl* (match expr [(list '! props ... (list op args ...)) @@ -323,8 +319,7 @@ (when (and expr (set-member? reachable idx)) (hash-set! id->name idx (gensym)))) - (for/fold ([body (remove-indices id->name expr)]) - ([idx (in-list (sort (hash-keys id->name) >))]) + (for/fold ([body (remove-indices id->name expr)]) ([idx (in-list (sort (hash-keys id->name) >))]) (define var (hash-ref id->name idx)) (define val (remove-indices id->name (vector-ref ivec idx))) `(let ([,var ,val]) ,body))) @@ -336,10 +331,10 @@ (define (prog->fpcore prog ctx) ; step 1: convert to an instruction vector where ; each expression is evaluated under explicit rounding contexts - (define-values (root ivec impls) (prog->normal prog)) + (match-define (cons ivec root) (prog->let-exprs prog)) ; step 2: inline nodes - (define body (inline! root ivec impls ctx)) + (define body (inline! root ivec ctx)) ; step 3: construct the actual FPCore expression from ; the remaining let-bindings and body From 2207289c8618ae15e6a01580860c5fdbdf9e3ae2 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 5 Aug 2024 13:17:28 -0700 Subject: [PATCH 11/64] change `get-fpcore-impl` interface --- src/syntax/sugar.rkt | 10 ++++----- src/syntax/syntax.rkt | 44 ++++++++++++++++++-------------------- src/syntax/test-syntax.rkt | 16 +++++++------- src/utils/common.rkt | 5 ++++- 4 files changed, 37 insertions(+), 38 deletions(-) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 72aa855d6..a1257cf7d 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -245,15 +245,13 @@ (match-define (cons expr impl) (vector-ref ivec idx)) (define impl* (match expr - [(list '! props ... (list op args ...)) + [(list '! props ... (list op _ ...)) ; rounding context updated parent context (define prop-dict* (apply dict-set prop-dict props)) - (define pattern (cons op (map (lambda (_) (gensym)) args))) - (get-fpcore-impl pattern (impl-info impl 'itype) prop-dict*)] - [(list op args ...) + (get-fpcore-impl op prop-dict* (impl-info impl 'itype))] + [(list op _ ...) ; rounding context inherited from parent context - (define pattern (cons op (map (lambda (_) (gensym)) args))) - (get-fpcore-impl pattern (impl-info impl 'itype) prop-dict)])) + (get-fpcore-impl op prop-dict (impl-info impl 'itype))])) (cond [(equal? impl impl*) ; inlining is safe (define expr* (loop expr prop-dict)) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 5b9389d40..f7c09ea42 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -474,43 +474,41 @@ ; force result of `pattern-match` to be a boolean (and (pattern-match spec1 spec2) #t)) -;; Finds the best operator implemenation for a given -;; FPCore expression, input representations, and rounding properties. -;; Panics if none can be found. -(define (get-fpcore-impl expr ireprs prop-dict #:impls [all-impls (all-active-operator-impls)]) - ; ensure `':precision` is in the prop list - (unless (dict-has-key? prop-dict ':precision) - (error 'get-impl "expected key ':precision in properties `~a`" prop-dict)) +;; Extracts the `fpcore` field of an operator implementation +;; as a property dictionary and expression. +(define (impl->fpcore impl) + (match (impl-info impl 'fpcore) + [(list '! props ... body) (values (props->dict props) body)] + [body (values '() body)])) + +;; For a given FPCore operator, rounding context, and input representations, +;; finds the best operator implementation. Panics if none can be found. +(define/contract (get-fpcore-impl op prop-dict ireprs #:impls [all-impls (all-active-operator-impls)]) + (->* (symbol? prop-dict/c (listof representation?)) (#:impls (listof symbol?)) symbol?) ; gather all implementations that have the same spec, input representations, ; and its FPCore translation has properties that are found in `prop-dict` (define impls (reap [sow] (for ([impl (in-list all-impls)]) - (when (and (equal? ireprs (impl-info impl 'itype)) - (let () - (define-values (prop-dict* body) - (match (impl-info impl 'fpcore) - [(list '! props ... body) (values (props->dict props) body)] - [body (values '() body)])) - (and (andmap (lambda (prop) (member prop prop-dict)) prop-dict*) - (spec-equal? expr body)))) - (sow impl))))) + (when (equal? ireprs (impl-info impl 'itype)) + (define-values (prop-dict* expr) (impl->fpcore impl)) + (define pattern (cons op (map (lambda (_) (gensym)) ireprs))) + (when (and (andmap (lambda (prop) (member prop prop-dict)) prop-dict*) + (spec-equal? pattern expr)) + (sow impl)))))) ; check that we have any matching impls (when (null? impls) (raise-herbie-missing-error "No implementation for `~a` under rounding context `~a` with types `~a`" - expr + op prop-dict (string-join (map (λ (r) (format "<~a>" (representation-name r))) ireprs) " "))) ; ; we rank implementations and select the highest scoring one (define scores (for/list ([impl (in-list impls)]) - (define prop-dict* - (match (impl-info impl 'fpcore) - [(list '! props ... _) (props->dict props)] - [_ '()])) - (define matching (filter (lambda (prop) (member prop prop-dict*)) prop-dict)) - (cons (length matching) (- (length prop-dict) (length matching))))) + (define-values (prop-dict* _) (impl->fpcore impl)) + (define num-matching (count (lambda (prop) (member prop prop-dict*)) prop-dict)) + (cons num-matching (- (length prop-dict) num-matching)))) ; select the best implementation ; sort first by the number of matched properties, ; then tie break on the number of extraneous properties diff --git a/src/syntax/test-syntax.rkt b/src/syntax/test-syntax.rkt index c9f7319ab..d14c12f32 100644 --- a/src/syntax/test-syntax.rkt +++ b/src/syntax/test-syntax.rkt @@ -44,17 +44,17 @@ ; get-fpcore-impl (define f64 (get-representation 'binary64)) - (define (get-impl expr itypes props) - (get-fpcore-impl expr itypes props #:impls (all-operator-impls))) + (define (get-impl op props itypes) + (get-fpcore-impl op props itypes #:impls (all-operator-impls))) - (check-equal? (get-impl '(+ x y) (list f64 f64) '((:precision . binary64))) '+.f64) - (check-equal? (get-impl '(+ a b) (list f64 f64) '((:precision . binary64))) '+.f64) - (check-equal? (get-impl '(+ a b) (list f64 f64) '((:precision . binary64) (:description . "test"))) + (check-equal? (get-impl '+ '((:precision . binary64)) (list f64 f64)) '+.f64) + (check-equal? (get-impl '+ '((:precision . binary64)) (list f64 f64)) '+.f64) + (check-equal? (get-impl '+ '((:precision . binary64) (:description . "test")) (list f64 f64)) '+.f64) - (check-equal? (get-impl '(log1pmd x) (list f64) '((:precision . binary64))) 'log1pmd.f64) - (check-equal? (get-impl '(sin x) (list f64) '((:precision . binary64))) 'sin.f64) - (check-equal? (get-impl '(sin x) (list f64) '((:precision . binary64) (:math-library . fast))) + (check-equal? (get-impl 'log1pmd '((:precision . binary64)) (list f64)) 'log1pmd.f64) + (check-equal? (get-impl 'sin '((:precision . binary64)) (list f64)) 'sin.f64) + (check-equal? (get-impl 'sin '((:precision . binary64) (:math-library . fast)) (list f64)) 'fast-sin.f64) (void)) diff --git a/src/utils/common.rkt b/src/utils/common.rkt index a32f14c3b..e031b0815 100644 --- a/src/utils/common.rkt +++ b/src/utils/common.rkt @@ -29,6 +29,7 @@ format-accuracy format-cost web-resource + prop-dict/c props->dict dict->props (all-from-out "../config.rkt")) @@ -280,7 +281,9 @@ (-> natural? (listof symbol?)) (build-list n (lambda (i) (string->symbol (format "x~a" i))))) -;; Property list <=> Property dictionary +;; FPCore properties + +(define prop-dict/c (listof (cons/c symbol? any/c))) ;; Prop list to dict (define/contract (props->dict props) From 1a3508936723d0f3129497c619153ff4151ca2b6 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 5 Aug 2024 13:45:45 -0700 Subject: [PATCH 12/64] cleaner `fpcore->prog` --- src/syntax/sugar.rkt | 72 +++++++++++++++----------------------------- 1 file changed, 24 insertions(+), 48 deletions(-) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index a1257cf7d..a49d5379c 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -68,9 +68,6 @@ prog->fpcore prog->spec) -(module+ test - (require rackunit)) - ;; Expression pre-processing for normalizing expressions. ;; Used for conversion from FPCore to other IRs. (define (expand-expr expr) @@ -138,56 +135,36 @@ ;; Translates from FPCore to an LImpl (define (fpcore->prog prog ctx) (define-values (expr* _) - (let loop ([expr (expand-expr prog)] [ctx ctx]) + (let loop ([expr (expand-expr prog)] [prop-dict (repr->prop (context-repr ctx))]) (match expr - [`(FPCore ,name (,vars ...) ,props ... ,body) - (define-values (body* repr*) (loop body ctx)) - (values `(FPCore ,name ,vars ,@props ,body*) repr*)] - [`(FPCore (,vars ...) ,props ... ,body) - (define-values (body* repr*) (loop body ctx)) - (values `(FPCore ,vars ,@props ,body*) repr*)] - [`(if ,cond ,ift ,iff) - (define-values (cond* cond-repr) (loop cond ctx)) - (define-values (ift* ift-repr) (loop ift ctx)) - (define-values (iff* iff-repr) (loop iff ctx)) - (values `(if ,cond* ,ift* ,iff*) ift-repr)] - [`(! ,props ... ,body) - (define props* (props->dict props)) - (loop body - (match (dict-ref props* ':precision #f) - [#f ctx] - [prec (struct-copy context ctx [repr (get-representation prec)])]))] - [`(cast ,body) - (define repr (context-repr ctx)) - (define-values (body* repr*) (loop body ctx)) - (if (equal? repr* repr) ; check if cast is redundant - (values body* repr) - (values (list (get-cast-impl repr* repr) body*) repr))] - [`(,(? constant-operator? x)) - (define cnst (get-parametric-constant x (context-repr ctx))) - (values (list cnst) (impl-info cnst 'otype))] - [(list 'neg arg) ; non-standard but useful - (define-values (arg* atype) (loop arg ctx)) - (define op* (get-parametric-operator 'neg atype)) - (values (list op* arg*) (impl-info op* 'otype))] - [`(,op ,args ...) - (define-values (args* atypes) (for/lists (args* atypes) ([arg args]) (loop arg ctx))) - ;; Match guaranteed to succeed because we ran type-check first - (define op* (apply get-parametric-operator op atypes)) - (values (cons op* args*) (impl-info op* 'otype))] - [(? variable?) (values expr (context-lookup ctx expr))] - [(? number?) - (define prec (representation-name (context-repr ctx))) - (define num - (match expr + [(? number? n) ; number + (define v + (match n [(or +inf.0 -inf.0 +nan.0) expr] [(? exact?) expr] [_ (inexact->exact expr)])) - (values (literal num prec) (context-repr ctx))]))) + (define prec (dict-ref prop-dict ':precision)) + (values (literal v prec) (get-representation prec))] + [(? variable?) (values expr (context-lookup ctx expr))] + [(list 'if cond ift iff) + (define-values (cond* cond-repr) (loop cond prop-dict)) + (define-values (ift* ift-repr) (loop ift prop-dict)) + (define-values (iff* iff-repr) (loop iff prop-dict)) + (values (list 'if cond* ift* iff*) ift-repr)] + [(list 'neg arg) ; non-standard but useful + (define-values (arg* irepr) (loop arg prop-dict)) + (define impl (get-fpcore-impl '- prop-dict (list irepr))) + (values (list impl arg*) (impl-info impl 'otype))] + [(list '! props ... body) (loop body (apply dict-set prop-dict props))] + [(list op args ...) + (define-values (args* ireprs) (for/lists (args* ireprs) ([arg args]) (loop arg prop-dict))) + (define impl (get-fpcore-impl op prop-dict ireprs)) + (values (cons impl args*) (impl-info impl 'otype))]))) expr*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; LImpl -> FPCore +;; Translates from LImpl to an FPCore ;; Instruction vector index (struct index (v) #:prefab) @@ -249,9 +226,8 @@ ; rounding context updated parent context (define prop-dict* (apply dict-set prop-dict props)) (get-fpcore-impl op prop-dict* (impl-info impl 'itype))] - [(list op _ ...) - ; rounding context inherited from parent context - (get-fpcore-impl op prop-dict (impl-info impl 'itype))])) + ; rounding context inherited from parent context + [(list op _ ...) (get-fpcore-impl op prop-dict (impl-info impl 'itype))])) (cond [(equal? impl impl*) ; inlining is safe (define expr* (loop expr prop-dict)) From 86a49ab460aed71600ee75e2f2db5da0109ff394 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 5 Aug 2024 14:19:13 -0700 Subject: [PATCH 13/64] more refactoring --- src/syntax/matcher.rkt | 34 ++++++++++++++++++++++ src/syntax/sugar.rkt | 64 ++++++++++++++++++++++++------------------ src/syntax/syntax.rkt | 22 +-------------- 3 files changed, 71 insertions(+), 49 deletions(-) create mode 100644 src/syntax/matcher.rkt diff --git a/src/syntax/matcher.rkt b/src/syntax/matcher.rkt new file mode 100644 index 000000000..c32367e24 --- /dev/null +++ b/src/syntax/matcher.rkt @@ -0,0 +1,34 @@ +;; Minimal pattern matcher/substituter for S-expressions + +#lang racket + +(provide pattern-match + pattern-substitute) + +;; Unions two bindings. Returns #f if they disagree. +(define (merge-bindings binding1 binding2) + (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))))) + +;; Pattern matcher that returns a substitution or #f. +;; A substitution is an association list of symbols and expressions. +(define (pattern-match pattern expr) + (match* (pattern expr) + [((? number?) _) (and (equal? pattern expr) '())] + [((? symbol?) _) (list (cons pattern expr))] + [((list phead prest ...) (list head rest ...)) + (and (equal? phead head) + (= (length prest) (length rest)) + (for/fold ([bindings '()]) ([pat (in-list prest)] [term (in-list rest)]) + (merge-bindings bindings (pattern-match pat term))))] + [(_ _) #f])) + +(define (pattern-substitute pattern bindings) + ; pattern binding -> expr + (match pattern + [(? number?) pattern] + [(? symbol?) (dict-ref bindings pattern)] + [(list phead pargs ...) (cons phead (map (curryr pattern-substitute bindings) pargs))])) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index a49d5379c..66993f931 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -61,6 +61,7 @@ (require "../core/programs.rkt" "../utils/common.rkt" + "matcher.rkt" "syntax.rkt" "types.rkt") @@ -132,35 +133,42 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; FPCore -> LImpl -;; Translates from FPCore to an LImpl +;; Translates an FPCore operator application into +;; an LImpl operator application. +(define (fpcore->impl-app op prop-dict args ctx) + (define ireprs (map (lambda (arg) (repr-of arg ctx)) args)) + (define impl (get-fpcore-impl op prop-dict ireprs)) + (match-define (list _ vars _) (impl-info impl 'spec)) + (define pattern + (match (impl-info impl 'fpcore) + [(list '! _ ... body) body] + [body body])) + (define subst (pattern-match pattern (cons op args))) + (pattern-substitute (cons impl vars) subst)) + +;; Translates from FPCore to an LImpl. (define (fpcore->prog prog ctx) - (define-values (expr* _) - (let loop ([expr (expand-expr prog)] [prop-dict (repr->prop (context-repr ctx))]) - (match expr - [(? number? n) ; number - (define v - (match n - [(or +inf.0 -inf.0 +nan.0) expr] - [(? exact?) expr] - [_ (inexact->exact expr)])) - (define prec (dict-ref prop-dict ':precision)) - (values (literal v prec) (get-representation prec))] - [(? variable?) (values expr (context-lookup ctx expr))] - [(list 'if cond ift iff) - (define-values (cond* cond-repr) (loop cond prop-dict)) - (define-values (ift* ift-repr) (loop ift prop-dict)) - (define-values (iff* iff-repr) (loop iff prop-dict)) - (values (list 'if cond* ift* iff*) ift-repr)] - [(list 'neg arg) ; non-standard but useful - (define-values (arg* irepr) (loop arg prop-dict)) - (define impl (get-fpcore-impl '- prop-dict (list irepr))) - (values (list impl arg*) (impl-info impl 'otype))] - [(list '! props ... body) (loop body (apply dict-set prop-dict props))] - [(list op args ...) - (define-values (args* ireprs) (for/lists (args* ireprs) ([arg args]) (loop arg prop-dict))) - (define impl (get-fpcore-impl op prop-dict ireprs)) - (values (cons impl args*) (impl-info impl 'otype))]))) - expr*) + (let loop ([expr (expand-expr prog)] [prop-dict (repr->prop (context-repr ctx))]) + (match expr + [(? number? n) + (literal (match n + [(or +inf.0 -inf.0 +nan.0) expr] + [(? exact?) expr] + [_ (inexact->exact expr)]) + (dict-ref prop-dict ':precision))] + [(? variable?) expr] + [(list 'if cond ift iff) + (define cond* (loop cond prop-dict)) + (define ift* (loop ift prop-dict)) + (define iff* (loop iff prop-dict)) + (list 'if cond* ift* iff*)] + [(list '! props ... body) (loop body (apply dict-set prop-dict props))] + [(list 'neg arg) ; non-standard but useful [TODO: remove] + (define arg* (loop arg prop-dict)) + (fpcore->impl-app '- prop-dict (list arg*) ctx)] + [(list op args ...) + (define args* (map (lambda (arg) (loop arg prop-dict)) args)) + (fpcore->impl-app op prop-dict args* ctx)]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; LImpl -> FPCore diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index f7c09ea42..d6a063e41 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -5,6 +5,7 @@ (require "../utils/common.rkt" "../utils/errors.rkt" "../core/rival.rkt" + "matcher.rkt" "types.rkt") (provide (rename-out [operator-or-impl? operator?]) @@ -447,27 +448,6 @@ (get-representation 'otype) (list (cons 'key val) ...))))])) -;; Unions two bindings. Returns #f if they disagree. -(define (merge-bindings binding1 binding2) - (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))))) - -;; Pattern matcher that returns a substitution or #f. -;; A substitution is an association list of symbols and expressions. -(define (pattern-match pattern expr) - (match* (pattern expr) - [((? number?) _) (and (equal? pattern expr) '())] - [((? variable?) _) (list (cons pattern expr))] - [((list phead prest ...) (list head rest ...)) - (and (equal? phead head) - (= (length prest) (length rest)) - (for/fold ([bindings '()]) ([pat (in-list prest)] [term (in-list rest)]) - (merge-bindings bindings (pattern-match pat term))))] - [(_ _) #f])) - ;; Checks if two specs are syntactically equivalent modulo renaming. ;; This is just pattern matching. (define (spec-equal? spec1 spec2) From a49a8dab2261b76011ff6809a9ad09c29590428e Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Tue, 6 Aug 2024 13:10:02 -0700 Subject: [PATCH 14/64] fix bad merge --- src/syntax/sugar.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index ce725fa43..3b230f79a 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -203,6 +203,7 @@ (match expr [(? literal?) (literal->fpcore expr)] [(? symbol?) expr] + [(approx _ impl) (munge impl)] [(list 'if cond ift iff) (list 'if (munge cond) (munge ift) (munge iff))] [(list (? impl-exists? impl) args ...) (define args* (map munge args)) From 4419278c46aff7987352c522b82cbcc368350f14 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 11:58:48 -0700 Subject: [PATCH 15/64] remove `get-parametric-*` calls --- src/core/bsearch.rkt | 7 +++---- src/core/preprocess.rkt | 23 +++++++++++++---------- src/reports/common.rkt | 15 +++++++++------ src/syntax/read.rkt | 34 +++++++++++++++++----------------- 4 files changed, 42 insertions(+), 37 deletions(-) diff --git a/src/core/bsearch.rkt b/src/core/bsearch.rkt index 94d3898a0..087cbe998 100644 --- a/src/core/bsearch.rkt +++ b/src/core/bsearch.rkt @@ -44,10 +44,9 @@ (for/fold ([expr (alt-expr (list-ref alts (sp-cidx (last splitpoints))))]) ([splitpoint (cdr (reverse splitpoints))]) (define repr (repr-of (sp-bexpr splitpoint) ctx)) - (define <=-operator (get-parametric-operator '<= repr repr)) - `(if (,<=-operator ,(sp-bexpr splitpoint) - ,(literal (repr->real (sp-point splitpoint) repr) - (representation-name repr))) + (define <=-impl (get-fpcore-impl '<= '() (list repr repr))) + `(if (,<=-impl ,(sp-bexpr splitpoint) + ,(literal (repr->real (sp-point splitpoint) repr) (representation-name repr))) ,(alt-expr (list-ref alts (sp-cidx splitpoint))) ,expr))) diff --git a/src/core/preprocess.rkt b/src/core/preprocess.rkt index 7688cabcb..eee84949f 100644 --- a/src/core/preprocess.rkt +++ b/src/core/preprocess.rkt @@ -21,13 +21,13 @@ (define (has-fabs-neg-impls? repr) (with-handlers ([exn:fail:user:herbie? (const #f)]) - (get-parametric-operator 'neg repr) - (get-parametric-operator 'fabs repr) + (get-fpcore-impl '- (repr->prop repr) (list repr)) + (get-fpcore-impl 'fabs (repr->prop repr) (list repr)) #t)) (define (has-copysign-impl? repr) (with-handlers ([exn:fail:user:herbie? (const #f)]) - (get-parametric-operator 'copysign repr repr) + (get-fpcore-impl 'copysign (repr->prop repr) (list repr repr)) #t)) ;; The even identities: f(x) = f(-x) @@ -164,18 +164,21 @@ (values (list-set* x indices sorted) y)))] [(list 'abs variable) (define index (index-of variables variable)) - (define abs - (impl-info (get-parametric-operator 'fabs (list-ref (context-var-reprs context) index)) 'fl)) - (lambda (x y) (values (list-update x index abs) y))] + (define var-repr (context-lookup context variable)) + (define abs-proc (impl-info (get-fpcore-impl 'fabs (repr->prop var-repr) (list var-repr)) 'fl)) + (lambda (x y) (values (list-update x index abs-proc) y))] [(list 'negabs variable) (define index (index-of variables variable)) - (define negate-variable - (impl-info (get-parametric-operator 'neg (list-ref (context-var-reprs context) index)) 'fl)) - (define negate-expression (impl-info (get-parametric-operator 'neg (context-repr context)) 'fl)) + (define var-repr (context-lookup context variable)) + (define neg-var (impl-info (get-fpcore-impl '- (repr->prop var-repr) (list var-repr)) 'fl)) + + (define repr (context-repr context)) + (define neg-expr (impl-info (get-fpcore-impl '- (repr->prop repr) (list repr)) 'fl)) + (lambda (x y) ;; Negation is involutive, i.e. it is its own inverse, so t^1(y') = -y' (if (negative? (repr->real (list-ref x index) (context-repr context))) - (values (list-update x index negate-variable) (negate-expression y)) + (values (list-update x index neg-var) (neg-expr y)) (values x y)))])) ; until fixed point, iterate through preprocessing attempting to drop preprocessing with no effect on error diff --git a/src/reports/common.rkt b/src/reports/common.rkt index 4019126f4..5c45e400d 100644 --- a/src/reports/common.rkt +++ b/src/reports/common.rkt @@ -164,8 +164,8 @@ (define r (list-ref (context-var-reprs c) p)) (define c* (struct-copy context c [vars (list-set (context-vars c) p x*)])) (define c** (context-extend c* x-sign r)) - (define e* - (list (get-parametric-operator '* r (context-repr c)) x-sign (replace-expression e x x*))) + (define *-impl (get-fpcore-impl '* (repr->prop (context-repr c)) (list r (context-repr c)))) + (define e* (list *-impl x-sign (replace-expression e x x*))) (cons e* c**)] [_ (cons e c)])) @@ -185,16 +185,19 @@ [(list 'abs x) (define x* (string->symbol (string-append (symbol->string x) "_m"))) (define r (list-ref (context-var-reprs ctx) (index-of (context-vars ctx) x))) - (define e (list (get-parametric-operator 'fabs r) x)) + (define fabs-impl (get-fpcore-impl 'fabs (repr->prop r) (list r))) + (define e (list fabs-impl x)) (define c (context (list x) r r)) (format "~a = ~a" x* (converter* e c))] [(list 'negabs x) + ; TODO: why are x* and x-sign unused? (define x* (string->symbol (format "~a_m" x))) (define r (context-lookup ctx x)) - (define p (representation-name r)) - (define e* (list (get-parametric-operator 'fabs r) x)) + (define fabs-impl (get-fpcore-impl 'fabs (repr->prop r) (list r))) + (define copysign-impl (get-fpcore-impl 'copysign (repr->prop r) (list r r))) + (define e* (list fabs-impl x)) (define x-sign (string->symbol (format "~a_s" x))) - (define e-sign (list (get-parametric-operator 'copysign r r) (literal 1 p) x)) + (define e-sign (list copysign-impl (literal 1 (representation-name r)) x)) (define c (context (list x) r r)) (list (format "~a = ~a" (format "~a\\_m" x) (converter* e* c)) (format "~a = ~a" (format "~a\\_s" x) (converter* e-sign c)))] diff --git a/src/syntax/read.rkt b/src/syntax/read.rkt index 032969f35..8691715c3 100644 --- a/src/syntax/read.rkt +++ b/src/syntax/read.rkt @@ -139,22 +139,22 @@ [(list 'FPCore name (list args ...) props ... body) (values name args props body)] [(list 'FPCore (list args ...) props ... body) (values #f args props body)])) - ;; TODO(interface): Currently, this code doesn't fire because annotations aren't - ;; allowed for variables because of the syntax checker yet. This should run correctly - ;; once the syntax checker is updated to the FPBench 1.1 standard. - (define arg-names - (for/list ([arg args]) - (if (list? arg) (last arg) arg))) - (define prop-dict (props->dict props)) (define default-prec (dict-ref prop-dict ':precision (*default-precision*))) + + (define-values (var-names var-precs) + (for/lists (var-names var-precs) + ([var (in-list args)]) + (match var + [(list '! props ... name) + (define prop-dict (props->dict props)) + (define arg-prec (dict-ref prop-dict ':precision default-prec)) + (values name arg-prec)] + [(? symbol? name) (values name default-prec)]))) + (define default-repr (get-representation default-prec)) - (define var-reprs - (for/list ([arg args] [arg-name arg-names]) - (if (and (list? arg) (set-member? args ':precision)) - (get-representation (cadr (member ':precision args))) - default-repr))) - (define ctx (context arg-names default-repr var-reprs)) + (define var-reprs (map get-representation var-precs)) + (define ctx (context var-names default-repr var-reprs)) ;; Named fpcores need to be added to function table (when func-name @@ -180,12 +180,12 @@ (cons val #t))]))) (define spec (fpcore->prog (dict-ref prop-dict ':spec body) ctx)) - (check-unused-variables arg-names body* pre*) - (check-weird-variables arg-names) + (check-unused-variables var-names body* pre*) + (check-weird-variables var-names) (test (~a name) func-name - arg-names + var-names body* targets (dict-ref prop-dict ':herbie-expected #t) @@ -193,7 +193,7 @@ pre* (dict-ref prop-dict ':herbie-preprocess empty) (representation-name default-repr) - (for/list ([var arg-names] [repr var-reprs]) + (for/list ([var (in-list var-names)] [repr (in-list var-reprs)]) (cons var (representation-name repr))))) (define (check-unused-variables vars precondition expr) From 0028a5c19819bc2ced79269c5747ff454fa2b971 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 12:26:52 -0700 Subject: [PATCH 16/64] better type checker --- src/syntax/type-check.rkt | 284 ++++++++++++++------------------------ 1 file changed, 105 insertions(+), 179 deletions(-) diff --git a/src/syntax/type-check.rkt b/src/syntax/type-check.rkt index aac7b9a4e..bc47c3357 100644 --- a/src/syntax/type-check.rkt +++ b/src/syntax/type-check.rkt @@ -9,40 +9,45 @@ (define (assert-program-typed! stx) (define-values (vars props body) (match (syntax-e stx) - [(list (app syntax-e 'FPCore) (app syntax-e name) (app syntax-e (list vars ...)) props ... body) + [(list (app syntax-e 'FPCore) _ (app syntax-e (list vars ...)) props ... body) (values vars props body)] [(list (app syntax-e 'FPCore) (app syntax-e (list vars ...)) props ... body) (values vars props body)])) - (define props* - (let loop ([props props]) - (match props - [(list) (list)] - [(list (app syntax-e prop) value rest ...) - (cons (cons prop (syntax->datum value)) (loop rest))]))) - (define type (get-representation (dict-ref props* ':precision 'binary64))) - (assert-expression-type! body - type - #:env (for/hash ([var vars]) - (values (syntax-e var) type)))) - -(define (assert-expression-type! stx expected-rtype #:env [env #hash()]) - (define errs - (reap [sow] - (define (error! stx fmt . args) - (sow (cons stx - (apply format - fmt - (for/list ([arg args]) - (if (representation? arg) (representation-name arg) arg)))))) - (define actual-rtype (expression->type stx env expected-rtype error!)) - (unless (equal? expected-rtype actual-rtype) - (error! stx "Expected program of type ~a, got type ~a" expected-rtype actual-rtype)))) + + (define default-dict `((:precision . ,(*default-precision*)))) + (define prop-dict (apply dict-set* default-dict (map syntax->datum props))) + (define prec (dict-ref prop-dict ':precision)) + + (define-values (var-names var-precs) + (for/lists (var-names var-precs) + ([var (in-list vars)]) + (match (syntax->datum var) + [(list '! props ... name) + (define prop-dict (props->dict props)) + (define arg-prec (dict-ref prop-dict ':precision prec)) + (values name arg-prec)] + [(? symbol? name) (values name prec)]))) + + (define ctx (context var-names (get-representation prec) (map get-representation var-precs))) + (assert-expression-type! body prop-dict ctx)) + +(define (assert-expression-type! stx props ctx) + (define errs '()) + (define (error! stx fmt . args) + (define args* + (for/list ([arg (in-list args)]) + (match arg + [(? representation?) (representation-name arg)] + [_ arg]))) + (set! errs (cons (cons stx (apply format fmt args*)) errs))) + + (define repr (expression->type stx props ctx error!)) + (unless (equal? repr (context-repr ctx)) + (error! stx "Expected program of type ~a, got type ~a" (context-repr ctx) repr)) + (unless (null? errs) (raise-herbie-syntax-error "Program has type errors" #:locations errs))) -(define (repr-has-type? repr type) - (and repr (equal? (representation-type repr) type))) - (define (application->string op types) (format "(~a ~a)" op @@ -50,166 +55,87 @@ (if t (format "<~a>" (representation-name t)) "")) " "))) -(define (resolve-missing-op! stx op actual-types error!) - (define active-impls (operator-active-impls op)) - (cond - [(null? active-impls) - ; no active implementations - (define all-impls (operator-all-impls op)) - (cond - ; no implementations at all - [(null? all-impls) (error! stx "No implementations of ~a found; check plugins" op)] - [else - ; found in-active implementations - (error! stx - "No implementations of `~a` in platform, but found inactive implementations ~a" - op - (string-join (for/list ([impl all-impls]) - (application->string op (impl-info impl 'itype))) - " or "))])] - [else - ; active implementations were found - (error! stx - "Invalid arguments to ~a; found ~a, but got ~a" - op - (string-join (for/list ([impl active-impls]) - (application->string op (impl-info impl 'itype))) - " or ") - (application->string op actual-types))])) - -(define (expression->type stx env type error!) - (match stx - [#`,(? number?) type] - [#`,(? constant-operator? x) - (define cnst* - (with-handlers ([exn:fail:user:herbie:missing? (const #f)]) - (get-parametric-constant x type))) - (cond - [cnst* (impl-info cnst* 'otype)] - [else - ; implementation not supported so try to report a useful error - (define active-impls (operator-active-impls x)) - (cond - [(null? active-impls) - ; no active implementations - (define all-impls (operator-all-impls x)) - (cond - ; no implementations at all - [(null? all-impls) (error! stx "No implementations of ~a found; check plugins" x)] - [else - ; found in-active implementations - (error! stx - (string-append "No implementations of `~a` in platform, " - "but found inactive implementations for ~a") - x - (string-join (for/list ([impl all-impls]) - (format "<~a>" (representation-name (impl-info impl 'otype)))) - " or "))])] - [else - ; active implementations were found - (error! stx - "No implementation for ~a with ~a; found implementations for ~a" - x - (format "<~a>" (representation-name type)) - (string-join (for/list ([impl active-impls]) - (format "<~a>" (representation-name (impl-info impl 'otype)))) - " or "))]) - type])] - [#`,(? variable? x) - (define vtype (dict-ref env x)) - (unless (or (equal? type vtype) (repr-has-type? vtype 'bool)) - (error! stx "Expected a variable of type ~a, but got ~a" type vtype)) - vtype] - [#`(let ([,id #,expr] ...) #,body) - (define env2 - (for/fold ([env2 env]) ([var id] [val expr]) - (dict-set env2 var (expression->type val env type error!)))) - (expression->type body env2 type error!)] - [#`(let* ([,id #,expr] ...) #,body) - (define env2 - (for/fold ([env2 env]) ([var id] [val expr]) - (dict-set env2 var (expression->type val env2 type error!)))) - (expression->type body env2 type error!)] - [#`(if #,branch #,ifstmt #,elsestmt) - (define branch-type (expression->type branch env type error!)) - (unless (repr-has-type? branch-type 'bool) - (error! stx "If statement has non-boolean type ~a for branch" branch-type)) - (define ifstmt-type (expression->type ifstmt env type error!)) - (define elsestmt-type (expression->type elsestmt env type error!)) - (unless (equal? ifstmt-type elsestmt-type) - (error! stx - "If statement has different types for if (~a) and else (~a)" - ifstmt-type - elsestmt-type)) - ifstmt-type] - [#`(! #,props ... #,body) - (define props* (apply hash-set* (hash) (map syntax-e props))) - (cond - [(hash-has-key? props* ':precision) - (define itype (get-representation (hash-ref props* ':precision))) - (define rtype (expression->type body env itype error!)) - (unless (equal? rtype itype) - (error! stx "Annotation promised precision ~a, but got ~a" itype rtype)) - type] - [else (expression->type body env type error!)])] - [#`(- #,arg) - ; special case: unary negation - (define actual-type (expression->type arg env type error!)) - (define op* - (with-handlers ([exn:fail:user:herbie:missing? (const #f)]) - (get-parametric-operator 'neg actual-type))) - (cond - [op* (impl-info op* 'otype)] - [else - (resolve-missing-op! stx '- (list actual-type) error!) - actual-type])] - [#`(,(? operator-exists? op) #,exprs ...) - (define actual-types - (for/list ([arg exprs]) - (expression->type arg env type error!))) - (define op* - (with-handlers ([exn:fail:user:herbie:missing? (const #f)]) - (apply get-parametric-operator op actual-types))) - (cond - [op* (impl-info op* 'otype)] - [else - ; implementation not supported so try to report a useful error - (resolve-missing-op! stx op actual-types error!) - type])] - [#`(,(? (curry hash-has-key? (*functions*)) fname) #,exprs ...) - (match-define (list vars prec _) (hash-ref (*functions*) fname)) - (define repr (get-representation prec)) - (define actual-types - (for/list ([arg exprs]) - (expression->type arg env type error!))) - (define expected (map (const repr) vars)) - (if (andmap equal? actual-types expected) - repr - (begin - (error! stx - "Invalid arguments to ~a; expects ~a but got ~a" - fname - fname - (application->string fname expected) - (application->string fname actual-types)) - type))])) +(define (expression->type stx prop-dict ctx error!) + (let loop ([stx stx] [prop-dict prop-dict] [ctx ctx]) + (match stx + [#`,(? number?) (get-representation (dict-ref prop-dict ':precision))] + [#`,(? variable? x) (context-lookup ctx x)] + [#`,(? constant-operator? op) + (define impl + (with-handlers ([exn:fail:user:herbie:missing? (const #f)]) + (get-fpcore-impl op prop-dict '()))) + (match impl + [#f ; no implementation found + (error! stx "No implementation of `~a` in platform for context `~a`" op prop-dict) + (get-representation (dict-ref prop-dict ':precision))] + [_ (impl-info impl 'otype)])] + [#`(let ([,ids #,exprs] ...) #,body) + (define ctx* + (for/fold ([ctx* ctx]) ([id (in-list ids)] [expr (in-list exprs)]) + (context-extend ctx* id (loop expr prop-dict ctx)))) + (loop body prop-dict ctx*)] + [#`(let* ([,ids #,exprs] ...) #,body) + (define ctx* + (for/fold ([ctx* ctx]) ([id (in-list ids)] [expr (in-list exprs)]) + (context-extend ctx* id (loop expr prop-dict ctx*)))) + (loop body prop-dict ctx*)] + [#`(if #,branch #,ifstmt #,elsestmt) + (define cond-ctx (struct-copy context ctx [repr (get-representation 'bool)])) + (define cond-repr (loop branch prop-dict cond-ctx)) + (unless (equal? (representation-type cond-repr) 'bool) + (error! stx "If statement has non-boolean type ~a for branch" cond-repr)) + (define ift-repr (loop ifstmt prop-dict ctx)) + (define iff-repr (loop elsestmt prop-dict ctx)) + (unless (equal? ift-repr iff-repr) + (error! stx "If statement has different types for if (~a) and else (~a)" ift-repr iff-repr)) + ift-repr] + [#`(! #,props ... #,body) (loop body (apply dict-set prop-dict props) ctx)] + [#`(,(? (curry hash-has-key? (*functions*)) fname) #,args ...) + ; TODO: inline functions expect uniform types, this is clearly wrong + (match-define (list vars prec _) (hash-ref (*functions*) fname)) + (define repr (get-representation prec)) + (define ireprs (map (lambda (arg) (loop arg prop-dict ctx)) args)) + (define expected (map (const repr) vars)) + (unless (andmap equal? ireprs expected) + (error! stx + "Invalid arguments to ~a; expects ~a but got ~a" + fname + fname + (application->string fname expected) + (application->string fname ireprs))) + repr] + [#`(,(? symbol? op) #,args ...) + (define ireprs (map (lambda (arg) (loop arg prop-dict ctx)) args)) + (define impl + (with-handlers ([exn:fail:user:herbie:missing? (const #f)]) + (get-fpcore-impl op prop-dict ireprs))) + (match impl + [#f ; no implementation found + (error! stx + "No implementation of `~a` in platform for context `~a`" + (application->string op ireprs) + prop-dict) + (get-representation (dict-ref prop-dict ':precision))] + [_ (impl-info impl 'otype)])]))) (module+ test (require rackunit) (require "load-plugin.rkt") (load-herbie-builtins) - (define (fail stx msg . args) + (define (fail! stx msg . args) (error (apply format msg args) stx)) - (define (check-types env-type rtype expr #:env [env #hash()]) - (check-equal? (expression->type expr env env-type fail) rtype)) + (define (check-types env-type rtype expr #:env [env '()]) + (define ctx (context (map car env) env-type (map cdr env))) + (define repr (expression->type expr (repr->prop env-type) ctx fail!)) + (check-equal? repr rtype)) - (define (check-fails type expr #:env [env #hash()]) - (check-equal? (let ([v #f]) - (expression->type expr env type (lambda _ (set! v #t))) - v) - #t)) + (define (check-fails type expr #:env [env '()]) + (define fail? #f) + (define ctx (context (map car env) type (map cdr env))) + (expression->type expr (repr->prop type) ctx (lambda _ (set! fail? #t))) + (check-true fail?)) (define (get-representation 'bool)) (define (get-representation 'binary64)) From 5866d09e913c6e4e57d6339011f3cf38c3a300ab Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 12:49:15 -0700 Subject: [PATCH 17/64] remove `get-parametric-*` and `impl->operator` --- src/reports/history.rkt | 12 ++++++++++-- src/syntax/syntax.rkt | 37 ------------------------------------- 2 files changed, 10 insertions(+), 39 deletions(-) diff --git a/src/reports/history.rkt b/src/reports/history.rkt index ac014b269..d33f4346c 100644 --- a/src/reports/history.rkt +++ b/src/reports/history.rkt @@ -84,8 +84,16 @@ [(? number?) expr] [(? literal?) (literal-value expr)] [(approx _ impl) (loop impl)] - [`(if ,cond ,ift ,iff) `(if ,(loop cond) ,(loop ift) ,(loop ift))] - [`(,(? impl-exists? impl) ,args ...) `(,(impl->operator impl) ,@(map loop args))] + [`(if ,cond ,ift ,iff) `(if ,(loop cond) ,(loop ift) ,(loop iff))] + [`(,(? impl-exists? impl) ,args ...) + ; use the FPCore operator without rounding properties + (define args* (map loop args)) + (match-define (list _ vars _) (impl-info impl 'spec)) + (define pattern + (match (impl-info impl 'fpcore) + [(list '! _ ... body) body] + [body body])) + (replace-vars (map cons vars args*) pattern)] [`(,op ,args ...) `(,op ,@(map loop args))]))) `(FPCore ,(context-vars ctx) ,expr*)) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 10a7944d0..38d809a27 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -20,7 +20,6 @@ all-constants impl-exists? impl-info - impl->operator all-operator-impls (rename-out [all-active-operator-impls active-operator-impls]) operator-all-impls @@ -30,8 +29,6 @@ *functions* register-function! get-fpcore-impl - get-parametric-operator - get-parametric-constant get-cast-impl generate-cast-impl cast-impl?) @@ -338,14 +335,6 @@ (define (operator-active-impls name) (filter (curry set-member? active-operator-impls) (operator-all-impls name))) -;; Looks up the name of an operator corresponding to an implementation `name`. -;; Panics if the operator is not found. -(define (impl->operator name) - (unless (hash-has-key? operator-impls name) - (raise-herbie-missing-error "Unknown operator implementation ~a" name)) - (define impl (hash-ref operator-impls name)) - (operator-name (operator-impl-op impl))) - ;; Activates an implementation. ;; Panics if the operator is not found. (define (activate-operator-impl! name) @@ -503,32 +492,6 @@ #:key car)) best) -;; Among active implementations, looks up an implementation with -;; the operator name `name` and argument representations `ireprs`. -(define (get-parametric-operator #:all? [all? #f] name . ireprs) - (define get-impls (if all? operator-all-impls operator-active-impls)) - (let/ec k - (for/first ([impl (get-impls name)] #:when (equal? (impl-info impl 'itype) ireprs)) - (k impl)) - (raise-herbie-missing-error - "Could not find operator implementation for ~a with ~a" - name - (string-join (map (λ (r) (format "<~a>" (representation-name r))) ireprs) " ")))) - -;; Among active implementations, looks up an implementation of -;; a constant (nullary operator) with the operator name `name` -;; and representation `repr`. -(define (get-parametric-constant name repr #:all? [all? #f]) - (define get-impls (if all? operator-all-impls operator-active-impls)) - (let/ec k - (for ([impl (get-impls name)]) - (define rtype (impl-info impl 'otype)) - (when (or (equal? rtype repr) (equal? (representation-type rtype) 'bool)) - (k impl))) - (raise-herbie-missing-error "Could not find constant implementation for ~a with ~a" - name - (format "<~a>" (representation-name repr))))) - ;; Casts and precision changes (define (cast-impl? x) From 41afb857f7539f91b958513f3a4ca1a8226eadf4 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 13:01:16 -0700 Subject: [PATCH 18/64] fix failed unit test --- src/syntax/sugar.rkt | 4 ++++ src/syntax/type-check.rkt | 17 +++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 3b230f79a..711e4948b 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -166,6 +166,10 @@ [(list 'neg arg) ; non-standard but useful [TODO: remove] (define arg* (loop arg prop-dict)) (fpcore->impl-app '- prop-dict (list arg*) ctx)] + [(list 'cast arg) ; special case: unnecessary casts + (define arg* (loop arg prop-dict)) + (define repr (get-representation (dict-ref prop-dict ':precision))) + (if (equal? (repr-of arg* ctx) repr) arg* (fpcore->impl-app 'cast prop-dict (list arg*) ctx))] [(list op args ...) (define args* (map (lambda (arg) (loop arg prop-dict)) args)) (fpcore->impl-app op prop-dict args* ctx)]))) diff --git a/src/syntax/type-check.rkt b/src/syntax/type-check.rkt index bc47c3357..1114f9d64 100644 --- a/src/syntax/type-check.rkt +++ b/src/syntax/type-check.rkt @@ -104,6 +104,23 @@ (application->string fname expected) (application->string fname ireprs))) repr] + [#`(cast #,arg) + (define irepr (loop arg prop-dict ctx)) + (define repr (get-representation (dict-ref prop-dict ':precision))) + (cond + [(equal? irepr repr) repr] + [else + (define impl + (with-handlers ([exn:fail:user:herbie:missing? (const #f)]) + (get-fpcore-impl 'cast prop-dict (list irepr)))) + (match impl + [#f ; no implementation found + (error! stx + "No implementation of `~a` in platform for context `~a`" + (application->string 'cast (list irepr)) + prop-dict) + (get-representation (dict-ref prop-dict ':precision))] + [_ (impl-info impl 'otype)])])] [#`(,(? symbol? op) #,args ...) (define ireprs (map (lambda (arg) (loop arg prop-dict ctx)) args)) (define impl From 47145497bcda87d7157ac7c7a48d39e1c70510f1 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 13:31:20 -0700 Subject: [PATCH 19/64] operator impl: remove `op` field, add `ctx` field --- src/core/egg-herbie.rkt | 3 +- src/reports/history.rkt | 2 +- src/syntax/platform.rkt | 7 +-- src/syntax/sugar.rkt | 7 +-- src/syntax/syntax.rkt | 105 +++++++++++++++++++--------------------- 5 files changed, 60 insertions(+), 64 deletions(-) diff --git a/src/core/egg-herbie.rkt b/src/core/egg-herbie.rkt index 1c65e436f..850e3dc9a 100644 --- a/src/core/egg-herbie.rkt +++ b/src/core/egg-herbie.rkt @@ -1063,8 +1063,7 @@ (+ 1 (rec cond (get-representation 'bool) +inf.0) (rec ift type +inf.0) (rec iff type +inf.0))] [(list (? impl-exists? impl) args ...) (define itypes (impl-info impl 'itype)) - (match-define (list _ _ spec) (impl-info impl 'spec)) - (match spec + (match (impl-info impl 'spec) [(list 'pow _ _) ; power (match-define (list b e) args) (define n (vector-ref (regraph-constants regraph) e)) diff --git a/src/reports/history.rkt b/src/reports/history.rkt index d33f4346c..5e3e17911 100644 --- a/src/reports/history.rkt +++ b/src/reports/history.rkt @@ -88,7 +88,7 @@ [`(,(? impl-exists? impl) ,args ...) ; use the FPCore operator without rounding properties (define args* (map loop args)) - (match-define (list _ vars _) (impl-info impl 'spec)) + (define vars (impl-info impl 'vars)) (define pattern (match (impl-info impl 'fpcore) [(list '! _ ... body) body] diff --git a/src/syntax/platform.rkt b/src/syntax/platform.rkt index f4a1a468b..92e76984d 100644 --- a/src/syntax/platform.rkt +++ b/src/syntax/platform.rkt @@ -237,7 +237,7 @@ (reap [sow] (for ([impl (in-list (platform-impls pform))]) (match (impl-info impl 'spec) - [(list _ _ (list 'cast _)) (sow impl)] + [(list 'cast _) (sow impl)] [_ (void)])))) ;; Merger for costs. @@ -304,7 +304,7 @@ (define reprs* (filter repr-supported? (platform-reprs pform))) (define impls* (filter (λ (impl) - (match-define (list _ _ spec) (impl-info impl 'spec)) + (define spec (impl-info impl 'spec)) (and (andmap op-supported? (ops-in-expr spec)) (repr-supported? (impl-info impl 'otype)) (andmap repr-supported? (impl-info impl 'itype)))) @@ -419,7 +419,8 @@ ;; Synthesizes the LHS and RHS of lifting/lowering rules. (define (impl->rule-parts impl) - (match-define (list _ vars spec) (impl-info impl 'spec)) + (define vars (impl-info impl 'vars)) + (define spec (impl-info impl 'spec)) (values vars spec (cons impl vars))) ;; Synthesizes lifting rules for a given platform. diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 711e4948b..794a7eaaa 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -138,7 +138,7 @@ (define (fpcore->impl-app op prop-dict args ctx) (define ireprs (map (lambda (arg) (repr-of arg ctx)) args)) (define impl (get-fpcore-impl op prop-dict ireprs)) - (match-define (list _ vars _) (impl-info impl 'spec)) + (define vars (impl-info impl 'vars)) (define pattern (match (impl-info impl 'fpcore) [(list '! _ ... body) body] @@ -211,7 +211,7 @@ [(list 'if cond ift iff) (list 'if (munge cond) (munge ift) (munge iff))] [(list (? impl-exists? impl) args ...) (define args* (map munge args)) - (match-define (list _ vars _) (impl-info impl 'spec)) + (define vars (impl-info impl 'vars)) (define node (replace-vars (map cons vars args*) (impl-info impl 'fpcore))) (if root? node (push! impl node))])) @@ -338,6 +338,7 @@ [(approx spec _) spec] [`(if ,cond ,ift ,iff) `(if ,(prog->spec cond) ,(prog->spec ift) ,(prog->spec iff))] [`(,impl ,args ...) - (match-define `(,_ (,vars ...) ,spec) (impl-info impl 'spec)) + (define vars (impl-info impl 'vars)) + (define spec (impl-info impl 'spec)) (define env (map cons vars (map prog->spec args))) (replace-vars env spec)])) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 38d809a27..15bc1a82d 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -83,7 +83,7 @@ ;; Looks up a property `field` of an real operator `op`. ;; Panics if the operator is not found. (define/contract (operator-info op field) - (-> symbol? (or/c 'itype 'otype 'spec) any/c) + (-> symbol? (or/c 'itype 'otype) any/c) (unless (hash-has-key? operators op) (error 'operator-info "Unknown operator ~a" op)) (define info (hash-ref operators op)) @@ -290,15 +290,18 @@ ;; Operator implementations ;; Floating-point operations that approximate mathematical operations +;; Operator implementations _approximate_ a program of +;; mathematical operators with fixed input and output representations. +;; ;; An operator implementation requires ;; - a (unique) name -;; - input and output representations +;; - input variables/representations +;; - output representation ;; - a specification it approximates ;; - its FPCore representation -;; - an implementation -;; Operator implementations _approximate_ a program of -;; mathematical operators with fixed input and output representations. -(struct operator-impl (name op itype otype spec fpcore fl)) +;; - a floating-point implementation +;; +(struct operator-impl (name ctx spec fpcore fl)) ;; Operator implementation table ;; Tracks implementations that are loaded into Racket's runtime @@ -312,13 +315,14 @@ ;; Looks up a property `field` of an real operator `op`. ;; Panics if the operator is not found. (define/contract (impl-info impl field) - (-> symbol? (or/c 'itype 'otype 'spec 'fpcore 'fl) any/c) + (-> symbol? (or/c 'vars 'itype 'otype 'spec 'fpcore 'fl) any/c) (unless (hash-has-key? operator-impls impl) (error 'impl-info "Unknown operator implementation ~a" impl)) (define info (hash-ref operator-impls impl)) (case field - [(itype) (operator-impl-itype info)] - [(otype) (operator-impl-otype info)] + [(vars) (context-vars (operator-impl-ctx info))] + [(itype) (context-var-reprs (operator-impl-ctx info))] + [(otype) (context-repr (operator-impl-ctx info))] [(spec) (operator-impl-spec info)] [(fpcore) (operator-impl-fpcore info)] [(fl) (operator-impl-fl info)])) @@ -346,58 +350,52 @@ (define (clear-active-operator-impls!) (set-clear! active-operator-impls)) -;; Registers an operator implementation `name` or real operator `op`. -;; The input and output representations must satisfy the types -;; specified by the `itype` and `otype` fields for `op`. +;; Register an operator implementation `name` with types `itype` and `otype`. (define/contract (register-operator-impl! op name ireprs orepr attrib-dict) (-> symbol? symbol? (listof representation?) representation? (listof pair?) void?) - (define op-info - (hash-ref - operators - op - (lambda () - (raise-herbie-missing-error "Cannot register `~a`, operator `~a` does not exist" name op)))) - - ; extract or generate the spec - (define spec - (match (dict-ref attrib-dict 'spec #f) - ; not provided => need to generate it - [#f - (define vars (gen-vars (length ireprs))) - `(lambda ,vars (,op ,@vars))] - ; provided => check for syntax and types - [spec + ; extract or generate the spec (and its free variables) + (define-values (vars spec) + (cond + [(dict-has-key? attrib-dict 'spec) ; provided => check for syntax and types + (define spec (dict-ref attrib-dict 'spec)) (check-spec! name (map representation-type ireprs) (representation-type orepr) spec) - spec])) + (match-define (list (or 'lambda 'λ) vars body) spec) + (values vars body)] + [else ; not provided => need to generate it + (define vars (gen-vars (length ireprs))) + (values vars `(,op ,@vars))])) + + ; make the context + (unless (= (length ireprs) (length vars)) + (error 'register-operator-impl + "~a: spec does not have expected arity; promised ~a, got ~a" + op + (length ireprs) + (length vars))) + (define ctx (context vars orepr ireprs)) ; extract or generate the fpcore translation - (match-define `(,(or 'lambda 'λ) ,vars ,body) spec) (define fpcore - (match (dict-ref attrib-dict 'fpcore #f) - ; not provided => need to generate it - [#f - ; special case: boolean-valued operations do not - ; need a precision annotation - (if (equal? orepr (get-representation 'bool)) - `(,op ,@vars) - `(! :precision ,(representation-name orepr) (,op ,@vars)))] + (cond ; provided -> TODO: check free variables - [fpcore fpcore])) + [(dict-has-key? attrib-dict 'fpcore) (dict-ref attrib-dict 'fpcore)] + [else ; not provided => need to generate it + (define bool-repr (get-representation 'bool)) + (if (equal? orepr bool-repr) + `(op ,@vars) ; special case: boolean-valued operations do not need a precision annotation + `(! :precision ,(representation-name orepr) (,op ,@vars)))])) ; extract or generate floating-point implementation (define fl-proc (match (dict-ref attrib-dict 'fl #f) - ; not provided => need to generate it - [#f - (define ctx (context vars orepr ireprs)) - (define compiler (make-real-compiler (list body) (list ctx))) - (define fail ((representation-bf->repr orepr) +nan.bf)) + [#f ; not provided => need to generate it + (define compiler (make-real-compiler (list spec) (list ctx))) + (define fail ((representation-bf->repr (context-repr ctx)) +nan.bf)) (procedure-rename (lambda pt (define-values (_ exs) (real-apply compiler pt)) (if exs (first exs) fail)) - (sym-append 'synth: name))] - ; provided - [(? procedure? proc) + name)] + [(? procedure? proc) ; provided (define expect-arity (length ireprs)) (unless (procedure-arity-includes? proc expect-arity #t) (error 'register-operator-impl! @@ -405,12 +403,11 @@ name expect-arity)) proc] - ; not a procedure - [bad + [bad ; not a procedure (error 'register-operator-impl! "~a: expected a procedure with attribute 'fl ~a" name bad)])) ; update tables - (define impl (operator-impl name op-info ireprs orepr spec fpcore fl-proc)) + (define impl (operator-impl name ctx spec fpcore fl-proc)) (hash-set! operator-impls name impl) (hash-update! operators-to-impls op (curry cons name))) @@ -533,17 +530,15 @@ (define (constant-operator? op) (and (symbol? op) (or (and (hash-has-key? operators op) (null? (operator-itype (hash-ref operators op)))) - (and (hash-has-key? operator-impls op) - (null? (operator-impl-itype (hash-ref operator-impls op))))))) + (and (hash-has-key? operator-impls op) (null? (impl-info op 'vars)))))) (define (variable? var) (and (symbol? var) (or (not (hash-has-key? operators var)) (not (null? (operator-itype (hash-ref operators var))))) - (or (not (hash-has-key? operator-impls var)) - (not (null? (operator-impl-itype (hash-ref operator-impls var))))))) + (or (not (hash-has-key? operator-impls var)) (not (null? (impl-info var 'vars)))))) -;; Floating-point expressions require that number +;; Floating-point expressions require that numbers ;; be rounded to a particular precision. (struct literal (value precision) #:prefab) From 3ab5c7510ecd7db997b1e2863f98d44047b908a5 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 14:00:05 -0700 Subject: [PATCH 20/64] fix --- src/syntax/syntax.rkt | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 15bc1a82d..8d29df6ab 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -380,10 +380,11 @@ ; provided -> TODO: check free variables [(dict-has-key? attrib-dict 'fpcore) (dict-ref attrib-dict 'fpcore)] [else ; not provided => need to generate it + (define repr (context-repr ctx)) (define bool-repr (get-representation 'bool)) - (if (equal? orepr bool-repr) - `(op ,@vars) ; special case: boolean-valued operations do not need a precision annotation - `(! :precision ,(representation-name orepr) (,op ,@vars)))])) + (if (equal? repr bool-repr) + `(,op ,@vars) ; special case: boolean-valued operations do not need a precision annotation + `(! :precision ,(representation-name repr) (,op ,@vars)))])) ; extract or generate floating-point implementation (define fl-proc From 16ade48c7d63f8bf72ab8bccdf99d25ac857428c Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 14:43:01 -0700 Subject: [PATCH 21/64] remove more unused procedures --- src/core/rules.rkt | 4 +++- src/platforms/bool.rkt | 1 - src/syntax/platform.rkt | 14 +++++------ src/syntax/syntax.rkt | 52 +++++++---------------------------------- 4 files changed, 18 insertions(+), 53 deletions(-) diff --git a/src/core/rules.rkt b/src/core/rules.rkt index 7fb47d422..ce854efff 100644 --- a/src/core/rules.rkt +++ b/src/core/rules.rkt @@ -732,7 +732,9 @@ (define-ruleset* erf-rules (special simplify) #:type ([x real]) [erf-odd (erf (neg x)) (neg (erf x))]) -; ; Specialized numerical functions +; Specialized numerical functions +; TODO: These are technically rules over impls +; ; (define-ruleset* special-numerical-reduce ; (numerics simplify) ; #:type ([x real] [y real] [z real]) diff --git a/src/platforms/bool.rkt b/src/platforms/bool.rkt index 878fd9839..527a61498 100644 --- a/src/platforms/bool.rkt +++ b/src/platforms/bool.rkt @@ -26,7 +26,6 @@ (define (and-fn . as) (andmap identity as)) - (define (or-fn . as) (ormap identity as)) diff --git a/src/syntax/platform.rkt b/src/syntax/platform.rkt index 92e76984d..7158c2537 100644 --- a/src/syntax/platform.rkt +++ b/src/syntax/platform.rkt @@ -4,6 +4,7 @@ "../utils/errors.rkt" "../core/programs.rkt" "../core/rules.rkt" + "matcher.rkt" "syntax.rkt" "types.rkt") @@ -234,11 +235,7 @@ ;; Casts between representations in a platform. (define (platform-casts pform) - (reap [sow] - (for ([impl (in-list (platform-impls pform))]) - (match (impl-info impl 'spec) - [(list 'cast _) (sow impl)] - [_ (void)])))) + (filter cast-impl? (platform-impls pform))) ;; Merger for costs. (define (merge-cost pform-costs key #:optional? [optional? #f]) @@ -464,8 +461,9 @@ [(list 'if rest ...) (loop rest assigns)] [(list (? (curryr assq assigns)) rest ...) (loop rest assigns)] [(list op rest ...) - (for ([impl (operator-all-impls op)]) - (when (set-member? impls impl) + (for ([impl (in-set impls)]) + (define pattern (cons op (map (lambda _ (gensym)) (operator-info op 'itype)))) + (when (pattern-match (impl-info impl 'spec) pattern) (loop rest (cons (cons op impl) assigns))))])))) ;; Attempts to lower a specification to an expression using @@ -530,5 +528,5 @@ (when (and input* output*) (define itypes* (merge-envs ienv oenv)) (when itypes* - (define name* (sym-append name '_ (repr->symbol repr))) + (define name* (apply sym-append name '_ (map cdr isubst))) (sow (rule name* input* output* itypes* repr)))))])))) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 8d29df6ab..58c268f18 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -22,8 +22,6 @@ impl-info all-operator-impls (rename-out [all-active-operator-impls active-operator-impls]) - operator-all-impls - operator-active-impls activate-operator-impl! clear-active-operator-impls! *functions* @@ -91,16 +89,6 @@ [(itype) (operator-itype info)] [(otype) (operator-otype info)])) -;; Map from operator to its implementations -(define operators-to-impls (make-hasheq)) - -;; All implementations of an operator `op`. -;; Panics if the operator is not found. -(define (operator-all-impls op) - (unless (hash-has-key? operators op) - (error 'operator-info "Unknown operator ~a" op)) - (hash-ref operators-to-impls op)) - ;; Checks a specification (define (check-spec! name itypes otype spec) (define (bad! fmt . args) @@ -169,8 +157,7 @@ (define deprecated? (dict-ref attrib-dict 'deprecated #f)) ; update tables (define info (operator name itypes* otype* deprecated?)) - (hash-set! operators name info) - (hash-set! operators-to-impls name '())) + (hash-set! operators name info)) ;; Syntactic form for `register-operator!` (define-syntax (define-operator stx) @@ -265,17 +252,6 @@ [pow : real real -> real] [remainder : real real -> real]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Accelerator operators - -(define-operators - [cast : real -> real] - [erfc : real -> real] - [expm1 : real -> real] - [log1p : real -> real] - [hypot : real real -> real] - [fma : real real real -> real]) - (module+ test ; check expected number of operators (check-equal? (length (all-operators)) 63) @@ -335,10 +311,6 @@ (define (all-active-operator-impls) (sort (set->list active-operator-impls) symbolfpcore impl) @@ -462,7 +427,7 @@ (define-values (prop-dict* expr) (impl->fpcore impl)) (define pattern (cons op (map (lambda (_) (gensym)) ireprs))) (when (and (andmap (lambda (prop) (member prop prop-dict)) prop-dict*) - (spec-equal? pattern expr)) + (pattern-match pattern expr)) (sow impl)))))) ; check that we have any matching impls (when (null? impls) @@ -493,12 +458,13 @@ ;; Casts and precision changes (define (cast-impl? x) - (and (symbol? x) (set-member? (operator-all-impls 'cast) x))) + (and (symbol? x) + (match (impl-info x 'spec) + [(list 'cast _) #t] + [_ #f]))) -(define (get-cast-impl irepr orepr #:all? [all? #f]) - (define get-impls (if all? operator-all-impls operator-active-impls)) - (for/or ([name (get-impls 'cast)]) - (and (equal? (impl-info name 'otype) orepr) (equal? (first (impl-info name 'itype)) irepr) name))) +(define (get-cast-impl irepr orepr #:impls [impls (all-active-operator-impls)]) + (get-fpcore-impl 'cast (repr->prop orepr) (list irepr) #:impls impls)) ; Similar to representation generators, conversion generators ; allow Herbie to query plugins for optimized implementations From 97455e4e4858923d3e817e7ee0c501a9284e74ad Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 16:14:57 -0700 Subject: [PATCH 22/64] fix --- src/syntax/syntax.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 58c268f18..e408d391b 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -254,7 +254,7 @@ (module+ test ; check expected number of operators - (check-equal? (length (all-operators)) 63) + (check-equal? (length (all-operators)) 57) ; check that Rival supports all non-accelerator operators (for ([op (in-list (all-operators))]) @@ -459,6 +459,7 @@ (define (cast-impl? x) (and (symbol? x) + (impl-exists? x) (match (impl-info x 'spec) [(list 'cast _) #t] [_ #f]))) From 5940181ae8bbdaf27e868fe55cf31c8ce9195ae0 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Wed, 7 Aug 2024 16:31:34 -0700 Subject: [PATCH 23/64] fix bugs --- src/syntax/platform.rkt | 7 ++++++- src/syntax/syntax-check.rkt | 11 +++++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/src/syntax/platform.rkt b/src/syntax/platform.rkt index 7158c2537..dc8a91a3b 100644 --- a/src/syntax/platform.rkt +++ b/src/syntax/platform.rkt @@ -528,5 +528,10 @@ (when (and input* output*) (define itypes* (merge-envs ienv oenv)) (when itypes* - (define name* (apply sym-append name '_ (map cdr isubst))) + (define name* + (string->symbol + (format "~a-~a-~a" + name + (representation-name repr) + (string-join (map (lambda (subst) (~a (cdr subst))) isubst) "-")))) (sow (rule name* input* output* itypes* repr)))))])))) diff --git a/src/syntax/syntax-check.rkt b/src/syntax/syntax-check.rkt index ec6490c6e..4e0163e89 100644 --- a/src/syntax/syntax-check.rkt +++ b/src/syntax/syntax-check.rkt @@ -63,6 +63,17 @@ ;; These expand by associativity so we don't check the number of arguments (for ([arg args]) (loop arg vars))] + [#`(,(? (curry set-member? '(erfc expm1 log1p hypot fma)) op) #,args ...) + ; FPCore operators that are composite in Herbie + (define arity + (case op + [(erfc expm1 log1p) 1] + [(hypot) 2] + [(fma) 3])) + (unless (= arity (length args)) + (error! stx "Operator ~a given ~a arguments (expects ~a)" op (length args) arity)) + (for ([arg (in-list args)]) + (loop arg vars))] [#`(#,f-syntax #,args ...) (define f (syntax->datum f-syntax)) (cond From 2b3667ff14a40e7f3ee7b5e6ab4d7f67284b2667 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Tue, 13 Aug 2024 13:16:00 -0700 Subject: [PATCH 24/64] fmt --- infra/ci.rkt | 3 +- infra/make-index.rkt | 13 ++-- infra/survey.rkt | 3 +- src/api/datafile.rkt | 12 ++-- src/api/demo.rkt | 3 +- src/api/improve.rkt | 4 +- src/api/sandbox.rkt | 9 ++- src/api/server.rkt | 3 +- src/api/shell.rkt | 3 +- src/api/thread-pool.rkt | 6 +- src/config.rkt | 6 +- src/core/alt-table.rkt | 25 +++++-- src/core/bsearch.rkt | 13 ++-- src/core/compiler.rkt | 9 ++- src/core/egg-herbie.rkt | 68 ++++++++++++------ src/core/explain.rkt | 13 ++-- src/core/localize.rkt | 15 ++-- src/core/mainloop.rkt | 15 ++-- src/core/patch.rkt | 9 ++- src/core/preprocess.rkt | 14 ++-- src/core/programs.rkt | 9 ++- src/core/reduce.rkt | 6 +- src/core/regimes.rkt | 31 +++++--- src/core/rival.rkt | 9 ++- src/core/rules.rkt | 5 +- src/core/sampling.rkt | 30 +++++--- src/core/searchreals.rkt | 15 ++-- src/core/simplify.rkt | 6 +- src/core/soundiness.rkt | 6 +- src/core/taylor.rkt | 120 ++++++++++++++++--------------- src/core/test-rules.rkt | 16 +++-- src/reports/common.rkt | 3 +- src/reports/core2mathjs.rkt | 17 +++-- src/reports/history.rkt | 21 ++++-- src/reports/make-graph.rkt | 5 +- src/reports/plot.rkt | 11 ++- src/reports/timeline.rkt | 34 ++++++--- src/syntax/matcher.rkt | 4 +- src/syntax/platform.rkt | 34 ++++++--- src/syntax/read.rkt | 22 ++++-- src/syntax/sugar.rkt | 29 +++++--- src/syntax/syntax-check.rkt | 19 +++-- src/syntax/syntax.rkt | 17 +++-- src/syntax/type-check.rkt | 12 +++- src/utils/common.rkt | 16 +++-- src/utils/multi-command-line.rkt | 3 +- src/utils/pareto.rkt | 14 ++-- src/utils/pretty-print.rkt | 6 +- src/utils/profile.rkt | 15 ++-- src/utils/timeline.rkt | 25 ++++--- 50 files changed, 539 insertions(+), 267 deletions(-) diff --git a/infra/ci.rkt b/infra/ci.rkt index 2f4649aa9..cb3294e90 100644 --- a/infra/ci.rkt +++ b/infra/ci.rkt @@ -34,7 +34,8 @@ (append-map load-tests bench-dirs))) (define seed (pseudo-random-generator->vector (current-pseudo-random-generator))) (printf "Running Herbie on ~a tests, seed: ~a\n" (length tests) seed) - (for/and ([the-test tests] [i (in-naturals)]) + (for/and ([the-test tests] + [i (in-naturals)]) (printf "~a/~a\t" (~a (+ 1 i) #:width 3 #:align 'right) (length tests)) (define the-test* (if (*precision*) (override-test-precision the-test (*precision*)) the-test)) (define result (run-herbie 'improve the-test* #:seed seed)) diff --git a/infra/make-index.rkt b/infra/make-index.rkt index 96bec879d..231683038 100644 --- a/infra/make-index.rkt +++ b/infra/make-index.rkt @@ -28,7 +28,8 @@ (define (get-options ri) (define flags - (for*/list ([(cat flags) (in-dict (or (report-info-flags ri) '()))] [fl flags]) + (for*/list ([(cat flags) (in-dict (or (report-info-flags ri) '()))] + [fl flags]) (string->symbol (format "~a:~a" cat fl)))) (if (equal? (report-info-iterations ri) 2) (cons 'fuel:2 flags) flags)) @@ -51,7 +52,8 @@ (define cache-row? (apply and/c hash? - (for*/list ([(valid? keys) (in-hash key-contracts)] [key keys]) + (for*/list ([(valid? keys) (in-hash key-contracts)] + [key keys]) (make-flat-contract #:name `(hash-has-key/c ,key) #:first-order (λ (x) (and (hash-has-key? x key) (valid? (hash-ref x key)))))))) @@ -73,7 +75,9 @@ info) (define-values (total-start total-end) - (for/fold ([start 0] [end 0]) ([row (or tests '())]) + (for/fold ([start 0] + [end 0]) + ([row (or tests '())]) (values (+ start (or (table-row-start row) 0)) (+ end (or (table-row-result row) 0))))) (define statuses (map table-row-status (or tests '()))) @@ -248,7 +252,8 @@ (hash-set (compute-row folder) 'folder (path->string (simplify-path path* false))))] [(file-exists? file) (define cached-info (call-with-input-file file read-json)) - (for ([v (in-list cached-info)] #:unless (cache-row? v)) + (for ([v (in-list cached-info)] + #:unless (cache-row? v)) (raise-user-error 'make-index "Invalid cache row ~a" v)) cached-info])) diff --git a/infra/survey.rkt b/infra/survey.rkt index 5ee7ef2c9..af1dc1458 100644 --- a/infra/survey.rkt +++ b/infra/survey.rkt @@ -36,7 +36,8 @@ section > div { width: 500; float: left; margin-right: 20px; } (body (h1 ,(format "Seed survey for ~a benchmarks" (hash-count results))) ,@ - (for/list ([(name metrics) (in-dict results)] [n (in-naturals)]) + (for/list ([(name metrics) (in-dict results)] + [n (in-naturals)]) `(section (h2 ,(~a name)) ,@ diff --git a/src/api/datafile.rkt b/src/api/datafile.rkt index 13b54e108..d6779605e 100644 --- a/src/api/datafile.rkt +++ b/src/api/datafile.rkt @@ -72,7 +72,8 @@ (exact->inexact (- 1 (/ initial-accuracies-sum maximum-accuracy))) 1.0))) (define rescaled - (for/list ([cost-accuracy (in-list cost-accuracies)] #:unless (null? cost-accuracy)) + (for/list ([cost-accuracy (in-list cost-accuracies)] + #:unless (null? cost-accuracy)) (match-define (list (and initial-point (list initial-cost _)) best-point other-points) cost-accuracy) ;; Has to be floating point so serializing to JSON doesn't complain @@ -180,7 +181,8 @@ (call-with-atomic-output-file file (λ (p name) (write-json data p))))) (define (flags->list flags) - (for*/list ([rec (hash->list flags)] [fl (cdr rec)]) + (for*/list ([rec (hash->list flags)] + [fl (cdr rec)]) (format "~a:~a" (car rec) fl))) (define (list->flags list) @@ -194,7 +196,8 @@ (define (parse-string s) (if s (call-with-input-string s read) #f)) - (let* ([json (call-with-input-file file read-json)] [get (λ (field) (hash-ref json field))]) + (let* ([json (call-with-input-file file read-json)] + [get (λ (field) (hash-ref json field))]) (report-info (seconds->date (get 'date)) (get 'commit) @@ -205,7 +208,8 @@ (get 'points) (get 'iterations) (hash-ref json 'note #f) - (for/list ([test (get 'tests)] #:when (hash-has-key? test 'vars)) + (for/list ([test (get 'tests)] + #:when (hash-has-key? test 'vars)) (let ([get (λ (field) (hash-ref test field))]) (define vars (match (hash-ref test 'vars) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index f581d6a60..f590025d2 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -527,7 +527,8 @@ (define local-error (job-result-backend result)) ;; TODO: potentially unsafe if resugaring changes the AST (define tree - (let loop ([expr expr] [err local-error]) + (let loop ([expr expr] + [err local-error]) (match expr [(list op args ...) ;; err => (List (listof Integer) List ...) diff --git a/src/api/improve.rkt b/src/api/improve.rkt index 605a6a6a0..4b26e4237 100644 --- a/src/api/improve.rkt +++ b/src/api/improve.rkt @@ -9,7 +9,9 @@ (define (print-outputs tests results p #:seed [seed #f]) (when seed (fprintf p ";; seed: ~a\n\n" seed)) - (for ([res results] [test tests] #:when res) + (for ([res results] + [test tests] + #:when res) (define name (table-row-name res)) (match (table-row-status res) ["error" diff --git a/src/api/sandbox.rkt b/src/api/sandbox.rkt index 798efba8b..e5fd4b854 100644 --- a/src/api/sandbox.rkt +++ b/src/api/sandbox.rkt @@ -96,7 +96,8 @@ (define-values (_ test-pcontext) (partition-pcontext pcontext)) (define errs (errors (test-input test) test-pcontext (*context*))) - (for/list ([(pt _) (in-pcontext test-pcontext)] [err (in-list errs)]) + (for/list ([(pt _) (in-pcontext test-pcontext)] + [err (in-list errs)]) (list pt err))) ;; Given a test and a sample of points, the ground truth of each point @@ -208,7 +209,8 @@ ;; optionally compute error/cost for input expression (define target-alt-data ;; When in platform, evaluate error - (for/list ([(expr is-valid?) (in-dict (test-output test))] #:when is-valid?) + (for/list ([(expr is-valid?) (in-dict (test-output test))] + #:when is-valid?) (define target-expr (fpcore->prog expr ctx)) (define target-train-errs (errors target-expr train-pcontext ctx)) (define target-test-errs (errors target-expr test-pcontext* ctx)) @@ -262,7 +264,8 @@ [_ (error 'run-herbie "command ~a timed out" command)]))) (define (compute-result test) - (parameterize ([*timeline-disabled* timeline-disabled?] [*warnings-disabled* false]) + (parameterize ([*timeline-disabled* timeline-disabled?] + [*warnings-disabled* false]) (define start-time (current-inexact-milliseconds)) (rollback-improve!) (*context* (test-context test)) diff --git a/src/api/server.rkt b/src/api/server.rkt index 8a10e9b71..c11c14e0c 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -34,7 +34,8 @@ ; I don't like how specific this function is but it keeps the API boundary. (define (get-improve-job-data) - (for/list ([(k v) (in-hash *completed-jobs*)] #:when (equal? (job-result-command v) 'improve)) + (for/list ([(k v) (in-hash *completed-jobs*)] + #:when (equal? (job-result-command v) 'improve)) (get-table-data v (make-path k)))) (define (job-count) diff --git a/src/api/shell.rkt b/src/api/shell.rkt index 835b2957b..feb811484 100644 --- a/src/api/shell.rkt +++ b/src/api/shell.rkt @@ -27,7 +27,8 @@ ['windows "Ctrl-Z Enter"] [_ "Ctrl-D"])) (with-handlers ([exn:break? (λ (e) (exit 0))]) - (for ([test (in-producer get-input eof-object?)] [idx (in-naturals)]) + (for ([test (in-producer get-input eof-object?)] + [idx (in-naturals)]) (define result (run-herbie 'improve test #:seed seed)) (define status (job-result-status result)) (define time (job-result-time result)) diff --git a/src/api/thread-pool.rkt b/src/api/thread-pool.rkt index 6b3eb4cea..04ad67c8b 100644 --- a/src/api/thread-pool.rkt +++ b/src/api/thread-pool.rkt @@ -100,7 +100,8 @@ (place-dead-evt worker))) (define work - (for/list ([id (in-naturals)] [prog progs]) + (for/list ([id (in-naturals)] + [prog progs]) (list id prog))) (eprintf "Starting ~a Herbie workers on ~a problems (seed: ~a)...\n" threads (length progs) seed) @@ -135,7 +136,8 @@ (eprintf "Terminating after ~a problem~a!\n" (length outs) (if (= (length outs) 1) "s" "")))]) - (for ([test progs] [i (in-naturals)]) + (for ([test progs] + [i (in-naturals)]) (define tr (run-test i test #:seed seed #:profile profile? #:dir dir)) (print-test-result (+ 1 i) (length progs) tr) (set! outs (cons tr outs)))) diff --git a/src/config.rkt b/src/config.rkt index 245b927ce..ac0a798aa 100644 --- a/src/config.rkt +++ b/src/config.rkt @@ -81,7 +81,8 @@ (define (changed-flags) (filter identity - (for*/list ([(class flags) all-flags] [flag flags]) + (for*/list ([(class flags) all-flags] + [flag flags]) (match* ((flag-set? class flag) (parameterize ([*flags* default-flags]) (flag-set? class flag))) [(#t #t) #f] @@ -156,7 +157,8 @@ (define (git-command #:default [default ""] gitcmd . args) (if (or (directory-exists? ".git") (file-exists? ".git")) ; gitlinks like for worktrees - (let* ([cmd (format "git ~a ~a" gitcmd (string-join args " "))] [out (run-command cmd)]) + (let* ([cmd (format "git ~a ~a" gitcmd (string-join args " "))] + [out (run-command cmd)]) (if (equal? out "") default out)) default)) diff --git a/src/core/alt-table.rkt b/src/core/alt-table.rkt index 1c2134c1a..49f96b471 100644 --- a/src/core/alt-table.rkt +++ b/src/core/alt-table.rkt @@ -90,7 +90,8 @@ (match-define (alt-table pnts->alts alts->pnts alt->done? alt->cost _ _) atab) (define tied (list->mutable-seteq (hash-keys alts->pnts))) (define coverage '()) - (for* ([pcurve (in-hash-values pnts->alts)] [ppt (in-list pcurve)]) + (for* ([pcurve (in-hash-values pnts->alts)] + [ppt (in-list pcurve)]) (match (pareto-point-data ppt) [(list) (error "This point has no alts which are best at it!" ppt)] [(list altn) (set-remove! tied altn)] @@ -100,10 +101,14 @@ (define (set-cover-remove! sc altn) (match-define (set-cover removable coverage) sc) (set-remove! removable altn) - (for ([j (in-naturals)] [s (in-vector coverage)] #:when s) + (for ([j (in-naturals)] + [s (in-vector coverage)] + #:when s) (define count 0) (define last #f) - (for ([i (in-naturals)] [a (in-vector s)] #:when a) + (for ([i (in-naturals)] + [a (in-vector s)] + #:when a) (cond [(eq? a altn) (vector-set! s i #f)] [a @@ -161,8 +166,11 @@ (define (atab-add-altns atab altns errss costs) (define-values (atab* progs*) - (for/fold ([atab atab] [progs (list->set (map alt-expr (alt-table-all atab)))]) - ([altn (in-list altns)] [errs (in-list errss)] [cost (in-list costs)]) + (for/fold ([atab atab] + [progs (list->set (map alt-expr (alt-table-all atab)))]) + ([altn (in-list altns)] + [errs (in-list errss)] + [cost (in-list costs)]) ;; this is subtle, we actually want to check for duplicates ;; in terms of expressions, not alts: the default `equal?` ;; returns #f for the same expression with different derivations. @@ -180,7 +188,9 @@ (define (invert-index idx) (define alt->points* (make-hasheq)) - (for* ([(pt curve) (in-hash idx)] [ppt (in-list curve)] [alt (in-list (pareto-point-data ppt))]) + (for* ([(pt curve) (in-hash idx)] + [ppt (in-list curve)] + [alt (in-list (pareto-point-data ppt))]) (hash-set! alt->points* alt (cons pt (hash-ref alt->points* alt '())))) (make-immutable-hash (hash->list alt->points*))) @@ -188,7 +198,8 @@ (match-define (alt-table point->alts alt->points alt->done? alt->cost pcontext all-alts) atab) (define point->alts* - (for/hash ([(pt ex) (in-pcontext pcontext)] [err (in-list errs)]) + (for/hash ([(pt ex) (in-pcontext pcontext)] + [err (in-list errs)]) (define ppt (pareto-point cost err (list altn))) (values pt (pareto-union (list ppt) (hash-ref point->alts pt))))) diff --git a/src/core/bsearch.rkt b/src/core/bsearch.rkt index 087cbe998..7efcaad3a 100644 --- a/src/core/bsearch.rkt +++ b/src/core/bsearch.rkt @@ -55,7 +55,9 @@ (alt expr* (list 'regimes splitpoints*) alts* '())])) (define (remove-unused-alts alts splitpoints) - (for/fold ([alts* '()] [splitpoints* '()]) ([splitpoint splitpoints]) + (for/fold ([alts* '()] + [splitpoints* '()]) + ([splitpoint splitpoints]) (define alt (list-ref alts (sp-cidx splitpoint))) ;; It's important to snoc the alt in order for the indices not to change (define alts** (remove-duplicates (append alts* (list alt)))) @@ -144,7 +146,8 @@ (left-point p1 p2)) (define (left-point p1 p2) - (let ([left ((representation-repr->bf repr) p1)] [right ((representation-repr->bf repr) p2)]) + (let ([left ((representation-repr->bf repr) p1)] + [right ((representation-repr->bf repr) p2)]) (define out (if (bfnegative? left) (bigfloat-interval-shortest left (bfmin (bf/ left 2.bf) right)) @@ -157,7 +160,8 @@ ;; Binary search is only valid if we correctly extracted the branch expression (andmap identity (cons start-prog progs)))) - (append (for/list ([si1 sindices] [si2 (cdr sindices)]) + (append (for/list ([si1 sindices] + [si2 (cdr sindices)]) (define prog1 (list-ref progs (si-cidx si1))) (define prog2 (list-ref progs (si-cidx si2))) @@ -180,7 +184,8 @@ (define ctx* (struct-copy context ctx [repr (repr-of bexpr ctx)])) (define prog (compile-prog bexpr ctx*)) - (for/list ([i (in-naturals)] [alt alts]) ;; alts necessary to terminate loop + (for/list ([i (in-naturals)] + [alt alts]) ;; alts necessary to terminate loop (λ (pt) (define val (apply prog pt)) (for/first ([right splitpoints] diff --git a/src/core/compiler.rkt b/src/core/compiler.rkt index 22c8434d3..196dfe638 100644 --- a/src/core/compiler.rkt +++ b/src/core/compiler.rkt @@ -23,9 +23,11 @@ (define varc (length vars)) (define vregs (make-vector (+ varc iveclen))) (define (compiled-prog . args) - (for ([arg (in-list args)] [n (in-naturals)]) + (for ([arg (in-list args)] + [n (in-naturals)]) (vector-set! vregs n arg)) - (for ([instr (in-vector ivec)] [n (in-naturals varc)]) + (for ([instr (in-vector ivec)] + [n (in-naturals varc)]) (vector-set! vregs n (apply-instruction instr vregs))) (for/vector #:length rootlen ([root (in-vector rootvec)]) @@ -51,7 +53,8 @@ (define (progs->batch exprs vars) (define icache (reverse vars)) (define exprhash - (make-hash (for/list ([var vars] [i (in-naturals)]) + (make-hash (for/list ([var vars] + [i (in-naturals)]) (cons var i)))) ; Counts (define size 0) diff --git a/src/core/egg-herbie.rkt b/src/core/egg-herbie.rkt index 850e3dc9a..7f17250da 100644 --- a/src/core/egg-herbie.rkt +++ b/src/core/egg-herbie.rkt @@ -236,11 +236,15 @@ [(list op args ...) (cons op (map loop args))]))) (define (flatten-let expr) - (let loop ([expr expr] [env (hash)]) + (let loop ([expr expr] + [env (hash)]) (match expr [(? number?) expr] [(? symbol?) (hash-ref env expr expr)] - [`(let (,var ,term) ,body) (loop body (hash-set env var (loop term env)))] + [`(let (,var + ,term) + ,body) + (loop body (hash-set env var (loop term env)))] [`(,op ,args ...) (cons op (map (curryr loop env) args))]))) ;; Converts an S-expr from egg into one Herbie understands @@ -248,7 +252,8 @@ ;; we may process mixed spec/impl expressions; ;; only need `type` to correctly interpret numbers (define (egg-parsed->expr expr rename-dict type) - (let loop ([expr expr] [type type]) + (let loop ([expr expr] + [type type]) (match expr [(? number?) (if (representation? type) (literal expr (representation-name type)) expr)] [(? symbol?) @@ -426,7 +431,8 @@ (define itype (dict-ref (rule-itypes ru) input)) (unless (type-name? itype) (error 'rule->egg-rules "expansive rules over impls is unsound ~a" input)) - (for/list ([op (all-operators)] #:when (eq? (operator-info op 'otype) itype)) + (for/list ([op (all-operators)] + #:when (eq? (operator-info op 'otype) itype)) (define itypes (operator-info op 'itype)) (define vars (map (lambda (_) (gensym)) itypes)) (rule (sym-append (rule-name ru) '-expand- op) @@ -571,7 +577,8 @@ (define dirty? #f) (define dirty?-vec* (make-vector n #f)) (define changed?-vec* (make-vector n #f)) - (for ([id (in-range n)] #:when (vector-ref dirty?-vec id)) + (for ([id (in-range n)] + #:when (vector-ref dirty?-vec id)) (define eclass (vector-ref eclasses id)) (when (eclass-proc analysis changed?-vec iter eclass id) ; eclass analysis was updated: need to revisit the parents @@ -771,7 +778,9 @@ (define (type/intersect ty1 ty2) (match* (ty1 ty2) [((list 'or tys1 ...) (list 'or tys2 ...)) - (match (for/fold ([tys '()]) ([ty (in-list tys1)] #:when (member ty tys2)) + (match (for/fold ([tys '()]) + ([ty (in-list tys1)] + #:when (member ty tys2)) (cons ty tys)) ['() #f] [(list ty) ty] @@ -790,7 +799,9 @@ [(? number?) ; NOTE: a number by itself is untyped, but we can constrain ; the type of the number by the platform - (for/fold ([ty #f]) ([repr (in-list reprs)] #:when (eq? (representation-type repr) 'real)) + (for/fold ([ty #f]) + ([repr (in-list reprs)] + #:when (eq? (representation-type repr) 'real)) (type/union ty repr (representation-type repr)))] [(? symbol?) (define repr (cdr (hash-ref egg->herbie node))) @@ -813,7 +824,9 @@ (define ty* (if (= iter 0) ; first iteration: only run analysis on leaves - (for/fold ([ty ty]) ([node (in-vector eclass)] #:unless (node-has-children? node)) + (for/fold ([ty ty]) + ([node (in-vector eclass)] + #:unless (node-has-children? node)) (type/union ty (node->type analysis node))) ; other iterations: run only on non-leaves with updated children (for/fold ([ty ty]) @@ -842,7 +855,9 @@ [(? number?) ; NOTE: a number by itself is untyped, but we can constrain ; the type of the number by the platform - (for/fold ([ty #f]) ([repr (in-list reprs)] #:when (eq? (representation-type repr) 'real)) + (for/fold ([ty #f]) + ([repr (in-list reprs)] + #:when (eq? (representation-type repr) 'real)) (type/union ty repr (representation-type repr)))] [(? symbol?) (define repr (cdr (hash-ref egg->herbie node))) @@ -885,7 +900,8 @@ (for ([ty (in-vector node-types)]) (match ty [(list 'or tys ...) - (for ([ty (in-list tys)] #:when (representation? ty)) + (for ([ty (in-list tys)] + #:when (representation? ty)) (hash-set! table ty #f))] [(? representation?) (hash-set! table ty #f)] [(? type-name?) (void)] @@ -980,10 +996,13 @@ (= iter 0))) ; Iterate over the nodes - (for ([node (in-vector eclass)] [ty (in-vector node-types)] [ready? (in-vector ready?/node)]) + (for ([node (in-vector eclass)] + [ty (in-vector node-types)] + [ready? (in-vector ready?/node)]) (match ty [(list 'or tys ...) ; node is a union type (only for some `if` nodes) - (for ([ty (in-list tys)] [ready? (in-list ready?)]) + (for ([ty (in-list tys)] + [ready? (in-list ready?)]) (when (and (representation? ty) (node-requires-update? node)) (define new-cost (node-cost node ty ready?)) (update-cost! ty new-cost node)))] @@ -1009,7 +1028,8 @@ (define (build-expr id type) (let/ec return - (let loop ([id id] [type type]) + (let loop ([id id] + [type type]) (match (unsafe-best-node id type) [(? number? n) n] ; number [(? symbol? s) s] ; variable @@ -1119,7 +1139,8 @@ [(list (? impl-exists? impl) ids ...) (when (equal? (impl-info impl 'otype) type) (define args - (for/list ([id (in-list ids)] [itype (in-list (impl-info impl 'itype))]) + (for/list ([id (in-list ids)] + [itype (in-list (impl-info impl 'itype))]) (match-define (cons _ expr) (extract id itype)) expr)) (when (andmap identity args) ; guard against failed extraction @@ -1127,7 +1148,8 @@ [(list (? operator-exists? op) ids ...) (when (equal? (operator-info op 'otype) type) (define args - (for/list ([id (in-list ids)] [itype (in-list (operator-info op 'itype))]) + (for/list ([id (in-list ids)] + [itype (in-list (operator-info op 'itype))]) (match-define (cons _ expr) (extract id itype)) expr)) (when (andmap identity args) ; guard against failed extraction @@ -1187,7 +1209,9 @@ (define-values (egg-graph* iteration-data) (egraph-run-rules egg-graph egg-rules params)) ; get cost statistics - (for/fold ([time 0]) ([iter (in-list iteration-data)] [i (in-naturals)]) + (for/fold ([time 0]) + ([iter (in-list iteration-data)] + [i (in-naturals)]) (define cnt (iteration-data-num-nodes iter)) (define cost (apply + (map (λ (id) (egraph-get-cost egg-graph* id i)) root-ids))) (define new-time (+ time (iteration-data-time iter))) @@ -1277,16 +1301,19 @@ (define regraph (make-regraph egg-graph)) (define extract-id (extractor regraph)) (define reprs (egg-runner-reprs runner)) - (for/list ([id (in-list root-ids)] [repr (in-list reprs)]) + (for/list ([id (in-list root-ids)] + [repr (in-list reprs)]) (regraph-extract-best regraph extract-id id repr))] [`(multi . ,extractor) ; multi expression extraction (define regraph (make-regraph egg-graph)) (define extract-id (extractor regraph)) (define reprs (egg-runner-reprs runner)) - (for/list ([id (in-list root-ids)] [repr (in-list reprs)]) + (for/list ([id (in-list root-ids)] + [repr (in-list reprs)]) (regraph-extract-variants regraph extract-id id repr))] [`(proofs . ((,start-exprs . ,end-exprs) ...)) ; proof extraction - (for/list ([start (in-list start-exprs)] [end (in-list end-exprs)]) + (for/list ([start (in-list start-exprs)] + [end (in-list end-exprs)]) (unless (egraph-expr-equal? egg-graph start end ctx) (error 'run-egg "cannot find proof; start and end are not equal.\n start: ~a \n end: ~a" @@ -1297,6 +1324,7 @@ (error 'run-egg "proof extraction failed between`~a` and `~a`" start end)) proof)] [`(equal? . ((,start-exprs . ,end-exprs) ...)) ; term equality? - (for/list ([start (in-list start-exprs)] [end (in-list end-exprs)]) + (for/list ([start (in-list start-exprs)] + [end (in-list end-exprs)]) (egraph-expr-equal? egg-graph start end ctx))] [_ (error 'run-egg "unknown command `~a`\n" cmd)])) diff --git a/src/core/explain.rkt b/src/core/explain.rkt index c63073afd..c79ff9071 100644 --- a/src/core/explain.rkt +++ b/src/core/explain.rkt @@ -39,7 +39,8 @@ (define pt-worst-subexpr (append* (reap [sow] - (for ([pt-errors (in-list pt-errorss)] [(pt _) (in-pcontext pcontext)]) + (for ([pt-errors (in-list pt-errorss)] + [(pt _) (in-pcontext pcontext)]) (define sub-error (map cons subexprs pt-errors)) (define filtered-sub-error (filter (lambda (p) (> (cdr p) 16)) sub-error)) (define mapped-sub-error (map (lambda (p) (cons (car p) pt)) filtered-sub-error)) @@ -82,7 +83,9 @@ (for ([(pt _) (in-pcontext pctx)]) (define (silence expr) (define subexprs (all-subexpressions expr #:reverse? #t)) - (for* ([subexpr (in-list subexprs)] #:when (list? subexpr) [expl (in-list all-explanations)]) + (for* ([subexpr (in-list subexprs)] + #:when (list? subexpr) + [expl (in-list all-explanations)]) (define key (cons subexpr expl)) (when (hash-has-key? expls->points key) (hash-update! expls->points key (lambda (x) (set-remove x pt)))) @@ -516,11 +519,13 @@ (and (not (empty? upred)) (values->json (first upred) repr))))) (define true-error-hash - (for/hash ([(key _) (in-pcontext pctx)] [value (in-list (errors expr pctx ctx))]) + (for/hash ([(key _) (in-pcontext pctx)] + [value (in-list (errors expr pctx ctx))]) (values key value))) (define explanations-table - (for/list ([(key val) (in-dict expls->points)] #:unless (zero? (length val))) + (for/list ([(key val) (in-dict expls->points)] + #:unless (zero? (length val))) (define expr (car key)) (define expl (cdr key)) (define err-count (length val)) diff --git a/src/core/localize.rkt b/src/core/localize.rkt index 2e0bface2..ee5530334 100644 --- a/src/core/localize.rkt +++ b/src/core/localize.rkt @@ -102,7 +102,8 @@ (define subexprss (map all-subexpressions exprs)) (define errss (compute-local-errors subexprss ctx)) - (for/list ([_ (in-list exprs)] [errs (in-list errss)]) + (for/list ([_ (in-list exprs)] + [errs (in-list errss)]) (sort (sort (for/list ([(subexpr err) (in-hash errs)] #:when (or (list? subexpr) (approx? subexpr))) (cons err subexpr)) @@ -114,23 +115,27 @@ ; Compute local error or each sampled point at each node in `prog`. (define (compute-local-errors subexprss ctx) (define spec-list - (for*/list ([subexprs (in-list subexprss)] [subexpr (in-list subexprs)]) + (for*/list ([subexprs (in-list subexprss)] + [subexpr (in-list subexprs)]) (prog->spec subexpr))) (define ctx-list - (for*/list ([subexprs (in-list subexprss)] [subexpr (in-list subexprs)]) + (for*/list ([subexprs (in-list subexprss)] + [subexpr (in-list subexprs)]) (struct-copy context ctx [repr (repr-of subexpr ctx)]))) (define subexprs-fn (eval-progs-real spec-list ctx-list)) ; Mutable error hack, this is bad (define errs - (make-hash (for*/list ([subexprs (in-list subexprss)] [subexpr (in-list subexprs)]) + (make-hash (for*/list ([subexprs (in-list subexprss)] + [subexpr (in-list subexprs)]) (cons subexpr '())))) (for ([(pt ex) (in-pcontext (*pcontext*))]) (define exacts (apply subexprs-fn pt)) (define exacts-hash (make-immutable-hash (map cons (apply append subexprss) exacts))) - (for* ([subexprs (in-list subexprss)] [expr (in-list subexprs)]) + (for* ([subexprs (in-list subexprss)] + [expr (in-list subexprs)]) (define err (match expr [(? literal?) 1] diff --git a/src/core/mainloop.rkt b/src/core/mainloop.rkt index e14e02372..dde4ea509 100644 --- a/src/core/mainloop.rkt +++ b/src/core/mainloop.rkt @@ -82,7 +82,8 @@ (*pcontext* pcontext) (explain! simplified context pcontext) (initialize-alt-table! simplified context pcontext) - (for ([iteration (in-range iterations)] #:break (atab-completed? (^table^))) + (for ([iteration (in-range iterations)] + #:break (atab-completed? (^table^))) (run-iter!)) (extract!)) @@ -114,7 +115,8 @@ (define (list-alts) (printf "Key: [.] = done, [>] = chosen\n") (let ([ndone-alts (atab-not-done-alts (^table^))]) - (for ([alt (atab-active-alts (^table^))] [n (in-naturals)]) + (for ([alt (atab-active-alts (^table^))] + [n (in-naturals)]) (printf "~a ~a ~a\n" (cond [(set-member? (^next-alts^) alt) ">"] @@ -243,14 +245,16 @@ ;; Returns the locations of `subexpr` within `expr` (define (get-locations expr subexpr) (reap [sow] - (let loop ([expr expr] [loc '()]) + (let loop ([expr expr] + [loc '()]) (match expr [(== subexpr) (sow (reverse loc))] [(? literal?) (void)] [(? symbol?) (void)] [(approx _ impl) (loop impl (cons 2 loc))] [(list _ args ...) - (for ([arg (in-list args)] [i (in-naturals 1)]) + (for ([arg (in-list args)] + [i (in-naturals 1)]) (loop arg (cons i loc)))])))) ;; Converts a patch to full alt with valid history @@ -419,7 +423,8 @@ default-egg-cost-proc))))) ; de-duplication - (remove-duplicates (for/list ([altn (in-list alts)] [prog (in-list simplified)]) + (remove-duplicates (for/list ([altn (in-list alts)] + [prog (in-list simplified)]) (if (equal? (alt-expr altn) prog) altn (alt prog 'final-simplify (list altn) (alt-preprocessing altn)))) diff --git a/src/core/patch.rkt b/src/core/patch.rkt index 7aa37f5d0..199d4a1d3 100644 --- a/src/core/patch.rkt +++ b/src/core/patch.rkt @@ -54,7 +54,8 @@ ; convert to altns (define simplified (reap [sow] - (for ([altn (in-list approxs)] [outputs (in-list simplification-options)]) + (for ([altn (in-list approxs)] + [outputs (in-list simplification-options)]) (match-define (cons _ simplified) outputs) (define prev (hash-ref approx->prev altn)) (for ([expr (in-list simplified)]) @@ -79,7 +80,8 @@ (define (taylor-alt altn) (define expr (prog->spec (alt-expr altn))) (reap [sow] - (for* ([var (free-variables expr)] [transform-type transforms-to-try]) + (for* ([var (free-variables expr)] + [transform-type transforms-to-try]) (match-define (list name f finv) transform-type) (define timeline-stop! (timeline-start! 'series (~a expr) (~a var) (~a name))) (define genexpr (approximate expr var #:transform (cons f finv))) @@ -131,7 +133,8 @@ ; apply changelists (define rewritten (reap [sow] - (for ([changelists changelistss] [altn altns]) + (for ([changelists changelistss] + [altn altns]) (for ([cl changelists]) (match-define (list subexpr input) cl) (sow (alt subexpr (list 'rr input #f #f) (list altn) '())))))) diff --git a/src/core/preprocess.rkt b/src/core/preprocess.rkt index eee84949f..7cffac5c9 100644 --- a/src/core/preprocess.rkt +++ b/src/core/preprocess.rkt @@ -113,7 +113,9 @@ (define abs-instrs '()) (define negabs-instrs '()) (define swaps '()) - (for ([ident (in-list identities)] [expr-equal? (in-list equal?-lst)] #:when expr-equal?) + (for ([ident (in-list identities)] + [expr-equal? (in-list equal?-lst)] + #:when expr-equal?) (match ident [(list 'even var _) (set! abs-instrs (cons (list 'abs var) abs-instrs))] [(list 'odd var _) (set! negabs-instrs (cons (list 'negabs var) negabs-instrs))] @@ -121,7 +123,8 @@ (define components (connected-components (context-vars ctx) swaps)) (define sort-instrs - (for/list ([component (in-list components)] #:when (> (length component) 1)) + (for/list ([component (in-list components)] + #:when (> (length component) 1)) (cons 'sort component))) (define instrs (append abs-instrs negabs-instrs sort-instrs)) @@ -160,7 +163,8 @@ (error 'instruction->operator "component should always be a subsequence of variables")) (define indices (indexes-where variables (curryr member component))) (lambda (x y) - (let* ([subsequence (map (curry list-ref x) indices)] [sorted (sort* subsequence)]) + (let* ([subsequence (map (curry list-ref x) indices)] + [sorted (sort* subsequence)]) (values (list-set* x indices sorted) y)))] [(list 'abs variable) (define index (index-of variables variable)) @@ -188,7 +192,9 @@ preprocessing #:removed [removed empty]) (define-values (result newly-removed) - (let loop ([preprocessing preprocessing] [i 0] [removed removed]) + (let loop ([preprocessing preprocessing] + [i 0] + [removed removed]) (cond [(>= i (length preprocessing)) (values preprocessing removed)] [(preprocessing-<=? expression context pcontext (drop-at preprocessing i) preprocessing) diff --git a/src/core/programs.rkt b/src/core/programs.rkt index ade554825..05c0bdaef 100644 --- a/src/core/programs.rkt +++ b/src/core/programs.rkt @@ -91,7 +91,8 @@ [(< len-a len-b) -1] [(> len-a len-b) 1] [else - (let loop ([a a] [b b]) + (let loop ([a a] + [b b]) (if (null? a) 0 (let ([cmp (expr-cmp (car a) (car b))]) @@ -147,7 +148,8 @@ (define (invalid! where loc) (error 'location-do "invalid location `~a` for `~a` in `~a`" loc where prog)) - (let loop ([prog prog] [loc loc]) + (let loop ([prog prog] + [loc loc]) (match* (prog loc) [(_ (? null?)) (f prog)] [((or (? literal?) (? number?) (? symbol?)) _) (invalid! prog loc)] @@ -157,7 +159,8 @@ [(2) (approx spec (loop impl rest))] [else (invalid! prog loc)])] [((list op args ...) (cons idx rest)) ; operator - (let seek ([elts (cons op args)] [idx idx]) + (let seek ([elts (cons op args)] + [idx idx]) (cond [(= idx 0) (cons (loop (car elts) rest) (cdr elts))] [(null? elts) (invalid! prog loc)] diff --git a/src/core/reduce.rkt b/src/core/reduce.rkt index abcc27a08..106ba8713 100644 --- a/src/core/reduce.rkt +++ b/src/core/reduce.rkt @@ -29,7 +29,8 @@ [(and (not (zero? a)) (integer? b)) (expt a b)] [else #f])] [(list 'sqrt (? exact-value? a)) - (let ([s1 (sqrt (numerator a))] [s2 (sqrt (denominator a))]) + (let ([s1 (sqrt (numerator a))] + [s2 (sqrt (denominator a))]) (and (real? s1) (real? s2) (exact? s1) (exact? s2) (/ s1 s2)))] [(list 'cbrt (? exact-value? a)) (define inexact-num (inexact->exact (expt (numerator a) 1/3))) @@ -175,7 +176,8 @@ (let ([terms (gather-multiplicative-terms arg)]) (cons (if (member (car terms) '(0 NAN)) 'NAN (/ (car terms))) (map negate-term (cdr terms))))] [`(/ ,arg ,args ...) - (let ([num (gather-multiplicative-terms arg)] [dens (map gather-multiplicative-terms args)]) + (let ([num (gather-multiplicative-terms arg)] + [dens (map gather-multiplicative-terms args)]) (cons (if (or (eq? (car num) 'NAN) (ormap (compose (curryr member '(0 NAN)) car) dens)) 'NAN (apply / (car num) (map car dens))) diff --git a/src/core/regimes.rkt b/src/core/regimes.rkt index 7ec839cf4..465886132 100644 --- a/src/core/regimes.rkt +++ b/src/core/regimes.rkt @@ -38,7 +38,9 @@ (define err-lsts (flip-lists (batch-errors (map alt-expr sorted) (*pcontext*) ctx))) (define branches (if (null? sorted) '() (exprs-to-branch-on sorted ctx))) (define branch-exprs (if (flag-set? 'reduce 'branch-expressions) branches (context-vars ctx))) - (let loop ([alts sorted] [errs (hash)] [err-lsts err-lsts]) + (let loop ([alts sorted] + [errs (hash)] + [err-lsts err-lsts]) (cond [(null? alts) '()] ; Only return one option if not pareto mode @@ -61,7 +63,10 @@ ;; invariant: ;; errs[bexpr] is some best option on branch expression bexpr computed on more alts than we have right now. (define-values (best best-err errs) - (for/fold ([best '()] [best-err +inf.0] [errs cerrs] #:result (values best best-err errs)) + (for/fold ([best '()] + [best-err +inf.0] + [errs cerrs] + #:result (values best best-err errs)) ([bexpr sorted-bexprs] ;; stop if we've computed this (and following) branch-expr on more alts and it's still worse #:break (> (hash-ref cerrs bexpr -1) best-err)) @@ -125,7 +130,8 @@ (for/list ([pt pts]) (apply fn pt))) (define big-table ; val and errors for each alt, per point - (for/list ([(pt ex) (in-pcontext (*pcontext*))] [err-lst err-lsts]) + (for/list ([(pt ex) (in-pcontext (*pcontext*))] + [err-lst err-lsts]) (list* pt (apply fn pt) err-lst))) (match-define (list pts* splitvals* err-lsts* ...) (flip-lists (sort big-table (curryr split-indices bit-err-lsts* can-split?)) (define out (option split-indices alts pts* expr (pick-errors split-indices pts* err-lsts* repr))) @@ -151,8 +158,11 @@ [errss (listof (listof real?))] [r representation?]) [idxs (listof nonnegative-integer?)]) - (for/list ([i (in-naturals)] [pt pts] [errs (flip-lists err-lsts)]) - (for/first ([si split-indices] #:when (< i (si-pidx si))) + (for/list ([i (in-naturals)] + [pt pts] + [errs (flip-lists err-lsts)]) + (for/first ([si split-indices] + #:when (< i (si-pidx si))) (list-ref errs (si-cidx si))))) (module+ test @@ -219,7 +229,8 @@ (define result-alt-idxs (make-vector number-of-points 0)) (define result-prev-idxs (make-vector number-of-points number-of-points)) - (for ([alt-idx (in-naturals)] [alt-errors (in-vector flvec-psums)]) + (for ([alt-idx (in-naturals)] + [alt-errors (in-vector flvec-psums)]) (for ([point-idx (in-range number-of-points)] [err (in-flvector alt-errors)] #:when (< err (flvector-ref result-error-sums point-idx))) @@ -244,7 +255,8 @@ (set! best-alt-costs (make-flvector number-of-points +inf.0)) ;; For each alt loop over its vector of errors - (for ([alt-idx (in-naturals)] [alt-error-sums (in-vector flvec-psums)]) + (for ([alt-idx (in-naturals)] + [alt-error-sums (in-vector flvec-psums)]) ;; Loop over the points up to our current point (for ([prev-split-idx (in-range 0 point-idx)] [prev-alt-error-sum (in-flvector alt-error-sums)] @@ -296,7 +308,8 @@ ;; Loop over results vectors in reverse and build the output split index list (define next number-of-points) (define split-idexs #f) - (for ([i (in-range (- number-of-points 1) -1 -1)] #:when (= (+ i 1) next)) + (for ([i (in-range (- number-of-points 1) -1 -1)] + #:when (= (+ i 1) next)) (define alt-idx (vector-ref result-alt-idxs i)) (define split-idx (vector-ref result-prev-idxs i)) (set! next (+ split-idx 1)) diff --git a/src/core/rival.rkt b/src/core/rival.rkt index c625ac483..ab219ce0c 100644 --- a/src/core/rival.rkt +++ b/src/core/rival.rkt @@ -69,17 +69,20 @@ (define start (current-inexact-milliseconds)) (define pt* (for/vector #:length (length vars) - ([val (in-list pt)] [repr (in-list var-reprs)]) + ([val (in-list pt)] + [repr (in-list var-reprs)]) ((representation-repr->bf repr) val))) (define-values (status value) (with-handlers ([exn:rival:invalid? (lambda (e) (values 'invalid #f))] [exn:rival:unsamplable? (lambda (e) (values 'exit #f))]) - (parameterize ([*rival-max-precision* (*max-mpfr-prec*)] [*rival-max-iterations* 5]) + (parameterize ([*rival-max-precision* (*max-mpfr-prec*)] + [*rival-max-iterations* 5]) (values 'valid (rest (vector->list (rival-apply machine pt*))))))) ; rest = drop precondition (when (> (rival-profile machine 'bumps) 0) (warn 'ground-truth "Could not converge on a ground truth" - #:extra (for/list ([var (in-list vars)] [val (in-list pt)]) + #:extra (for/list ([var (in-list vars)] + [val (in-list pt)]) (format "~a = ~a" var val)))) (define executions (rival-profile machine 'executions)) (when (>= (vector-length executions) (*rival-profile-executions*)) diff --git a/src/core/rules.rkt b/src/core/rules.rkt index c52546cfa..7fbcf1e81 100644 --- a/src/core/rules.rkt +++ b/src/core/rules.rkt @@ -101,7 +101,8 @@ ;; (define ((type/repr-of-rule op-info name) input output ctx) - (let loop ([input input] [output output]) + (let loop ([input input] + [output output]) (match* (input output) ; first, try the input expression ; special case for `if` expressions @@ -724,7 +725,7 @@ ; Specialized numerical functions ; TODO: These are technically rules over impls -; +; ; (define-ruleset* special-numerical-reduce ; (numerics simplify) ; #:type ([x real] [y real] [z real]) diff --git a/src/core/sampling.rkt b/src/core/sampling.rkt index 2c87600f6..a4d2ade12 100644 --- a/src/core/sampling.rkt +++ b/src/core/sampling.rkt @@ -24,7 +24,8 @@ ;; FPBench needs unparameterized operators (define range-table (condition->range-table pre)) (apply cartesian-product - (for/list ([var-name vars] [var-repr var-reprs]) + (for/list ([var-name vars] + [var-repr var-reprs]) (map (lambda (interval) (fpbench-ival->ival var-repr interval)) (range-table-ref range-table var-name))))) @@ -52,7 +53,8 @@ ;; we want a index i such that vector[i] > num and vector[i-1] <= num ;; assumes vector strictly increasing (define (binary-search vector num) - (let loop ([left 0] [right (- (vector-length vector) 1)]) + (let loop ([left 0] + [right (- (vector-length vector) 1)]) (cond [(>= left right) (min left (- (vector-length vector) 1))] [else @@ -80,12 +82,14 @@ (define lo-ends (for/vector #:length (vector-length hyperrects) ([hyperrect (in-vector hyperrects)]) - (for/list ([interval (in-list hyperrect)] [repr (in-list reprs)]) + (for/list ([interval (in-list hyperrect)] + [repr (in-list reprs)]) ((representation-repr->ordinal repr) ((representation-bf->repr repr) (ival-lo interval)))))) (define hi-ends (for/vector #:length (vector-length hyperrects) ([hyperrect (in-vector hyperrects)]) - (for/list ([interval (in-list hyperrect)] [repr (in-list reprs)]) + (for/list ([interval (in-list hyperrect)] + [repr (in-list reprs)]) (+ 1 ((representation-repr->ordinal repr) ((representation-bf->repr repr) (ival-hi interval))))))) @@ -96,7 +100,9 @@ (define idx (binary-search weights rand-ordinal)) (define los (vector-ref lo-ends idx)) (define his (vector-ref hi-ends idx)) - (for/list ([lo (in-list los)] [hi (in-list his)] [repr (in-list reprs)]) + (for/list ([lo (in-list los)] + [hi (in-list his)] + [repr (in-list reprs)]) ((representation-ordinal->repr repr) (random-integer lo hi))))) #;(module+ test @@ -143,7 +149,10 @@ (real-compiler-clear! compiler) ; Clear profiling vector (define-values (points exactss) - (let loop ([sampled 0] [skipped 0] [points '()] [exactss '()]) + (let loop ([sampled 0] + [skipped 0] + [points '()] + [exactss '()]) (define pt (sampler)) (define-values (status exs) (real-apply compiler pt)) @@ -152,10 +161,12 @@ (warn 'ground-truth #:url "faq.html#ground-truth" "could not determine a ground truth" - #:extra (for/list ([var vars] [val pt]) + #:extra (for/list ([var vars] + [val pt]) (format "~a = ~a" var val)))] [(valid) - (for ([ex (in-list exs)] [repr (in-list reprs)]) + (for ([ex (in-list exs)] + [repr (in-list reprs)]) ; The `bool` representation does not produce bigfloats (define maybe-bf ((representation-repr->bf repr) ex)) (when (and (bigfloat? maybe-bf) (bfinfinite? maybe-bf)) @@ -164,7 +175,8 @@ (hash-update! outcomes status (curry + 1) 0) (define is-bad? - (for/or ([input (in-list pt)] [repr (in-list var-reprs)]) + (for/or ([input (in-list pt)] + [repr (in-list var-reprs)]) ((representation-special-value? repr) input))) (cond diff --git a/src/core/searchreals.rkt b/src/core/searchreals.rkt index 803eb31fa..a8cad3c8a 100644 --- a/src/core/searchreals.rkt +++ b/src/core/searchreals.rkt @@ -27,7 +27,8 @@ (define (hyperrect-weight hyperrect reprs) (apply * - (for/list ([interval (in-list hyperrect)] [repr (in-list reprs)]) + (for/list ([interval (in-list hyperrect)] + [repr (in-list reprs)]) (define ->ordinal (compose (representation-repr->ordinal repr) (representation-bf->repr repr))) (+ 1 (- (->ordinal (ival-hi interval)) (->ordinal (ival-lo interval))))))) @@ -49,13 +50,18 @@ (define reprs (real-compiler-var-reprs compiler)) (match-define (search-space true false other) space) (define-values (true* false* other*) - (for/fold ([true* true] [false* false] [other* '()]) ([rect (in-list other)]) + (for/fold ([true* true] + [false* false] + [other* '()]) + ([rect (in-list other)]) (match-define (ival err err?) (real-compiler-analyze compiler (list->vector rect))) (when (eq? err 'unsamplable) (warn 'ground-truth #:url "faq.html#ground-truth" "could not determine a ground truth" - #:extra (for/list ([var vars] [repr reprs] [ival rect]) + #:extra (for/list ([var vars] + [repr reprs] + [ival rect]) (define val (value->string ((representation-bf->repr repr) (bigfloat-pick-point (ival-lo ival) (ival-hi ival))) @@ -92,7 +98,8 @@ (define var-reprs (real-compiler-var-reprs compiler)) (if (or (null? rects) (null? (first rects))) (map (curryr cons 'other) rects) - (let loop ([space (apply make-search-space rects)] [n 0]) + (let loop ([space (apply make-search-space rects)] + [n 0]) (match-define (search-space true false other) space) (timeline-push! 'sampling n (make-sampling-table var-reprs true false other)) diff --git a/src/core/simplify.rkt b/src/core/simplify.rkt index 46aa7e396..f194fb98a 100644 --- a/src/core/simplify.rkt +++ b/src/core/simplify.rkt @@ -25,7 +25,8 @@ (define simplifieds (run-egg runner (cons 'single extractor))) (define out - (for/list ([simplified simplifieds] [expr (egg-runner-exprs runner)]) + (for/list ([simplified simplifieds] + [expr (egg-runner-exprs runner)]) (remove-duplicates (cons expr simplified)))) (timeline-push! 'outputs (map ~a (apply append out))) @@ -76,7 +77,8 @@ (*timeline-disabled* true) (define outputs (apply test-simplify (dict-keys test-exprs))) - (for ([(original target) (in-dict test-exprs)] [output outputs]) + (for ([(original target) (in-dict test-exprs)] + [output outputs]) (with-check-info (['original original]) (check-equal? output target))) (check set-member? '((* x 6) (* 6 x)) (first (test-simplify '(+ (+ (+ (+ (+ x x) x) x) x) x)))) diff --git a/src/core/soundiness.rkt b/src/core/soundiness.rkt index 791e63ace..0525f21ba 100644 --- a/src/core/soundiness.rkt +++ b/src/core/soundiness.rkt @@ -22,7 +22,8 @@ (define errss (batch-errors proof-progs pcontext ctx)) (define prog->errs - (for/hash ([prog (in-list proof-progs)] [errs (in-list errss)]) + (for/hash ([prog (in-list proof-progs)] + [errs (in-list errss)]) (values prog errs))) (define proof-errors @@ -31,7 +32,8 @@ (define proof-diffs (cons (list 0 0) - (for/list ([prev proof-errors] [current (rest proof-errors)]) + (for/list ([prev proof-errors] + [current (rest proof-errors)]) (and prev current (list (count > current prev) ; num points where error increased diff --git a/src/core/taylor.rkt b/src/core/taylor.rkt index a8bfd8488..f7a919ee7 100644 --- a/src/core/taylor.rkt +++ b/src/core/taylor.rkt @@ -268,27 +268,29 @@ (hash-set! hash 0 (simplify `(sqrt ,(coeffs* 0)))) (hash-set! hash 1 (simplify `(/ ,(coeffs* 1) (* 2 (sqrt ,(coeffs* 0)))))) (letrec ([f (λ (n) - (hash-ref! - hash - n - (λ () - (simplify (cond - [(even? n) - `(/ (- ,(coeffs* n) - (pow ,(f (/ n 2)) 2) - (+ ,@(for/list ([k (in-naturals 1)] #:break (>= k (- n k))) - `(* 2 (* ,(f k) ,(f (- n k))))))) - (* 2 ,(f 0)))] - [(odd? n) - `(/ (- ,(coeffs* n) - (+ ,@(for/list ([k (in-naturals 1)] #:break (>= k (- n k))) - `(* 2 (* ,(f k) ,(f (- n k))))))) - (* 2 ,(f 0)))])))))]) + (hash-ref! hash + n + (λ () + (simplify (cond + [(even? n) + `(/ (- ,(coeffs* n) + (pow ,(f (/ n 2)) 2) + (+ ,@(for/list ([k (in-naturals 1)] + #:break (>= k (- n k))) + `(* 2 (* ,(f k) ,(f (- n k))))))) + (* 2 ,(f 0)))] + [(odd? n) + `(/ (- ,(coeffs* n) + (+ ,@(for/list ([k (in-naturals 1)] + #:break (>= k (- n k))) + `(* 2 (* ,(f k) ,(f (- n k))))))) + (* 2 ,(f 0)))])))))]) (cons (/ offset* 2) f)))) (define (taylor-cbrt var num) (match-define (cons offset* coeffs*) (modulo-series var 3 num)) - (let* ([f0 (simplify `(cbrt ,(coeffs* 0)))] [hash (make-hash)]) + (let* ([f0 (simplify `(cbrt ,(coeffs* 0)))] + [hash (make-hash)]) (hash-set! hash 0 f0) (hash-set! hash 1 (simplify `(/ ,(coeffs* 1) (* 3 (cbrt (* ,f0 ,f0)))))) (letrec ([f (λ (n) @@ -350,53 +352,57 @@ (define (taylor-sin coeffs) (let ([hash (make-hash)]) (hash-set! hash 0 0) - (cons - 0 - (λ (n) - (hash-ref! - hash - n - (λ () - (define coeffs* (list->vector (map coeffs (range 1 (+ n 1))))) - (define nums - (for/list ([i (in-range 1 (+ n 1))] [coeff (in-vector coeffs*)] #:unless (equal? coeff 0)) - i)) - (simplify `(+ ,@(for/list ([p (all-partitions n (sort nums >))]) - (if (= (modulo (apply + (map car p)) 2) 1) - `(* ,(if (= (modulo (apply + (map car p)) 4) 1) 1 -1) - ,@(for/list ([(count num) (in-dict p)]) - `(/ (pow ,(vector-ref coeffs* (- num 1)) ,count) - ,(factorial count)))) - 0)))))))))) + (cons 0 + (λ (n) + (hash-ref! hash + n + (λ () + (define coeffs* (list->vector (map coeffs (range 1 (+ n 1))))) + (define nums + (for/list ([i (in-range 1 (+ n 1))] + [coeff (in-vector coeffs*)] + #:unless (equal? coeff 0)) + i)) + (simplify `(+ ,@ + (for/list ([p (all-partitions n (sort nums >))]) + (if (= (modulo (apply + (map car p)) 2) 1) + `(* ,(if (= (modulo (apply + (map car p)) 4) 1) 1 -1) + ,@(for/list ([(count num) (in-dict p)]) + `(/ (pow ,(vector-ref coeffs* (- num 1)) ,count) + ,(factorial count)))) + 0)))))))))) (define (taylor-cos coeffs) (let ([hash (make-hash)]) (hash-set! hash 0 1) - (cons - 0 - (λ (n) - (hash-ref! - hash - n - (λ () - (define coeffs* (list->vector (map coeffs (range 1 (+ n 1))))) - (define nums - (for/list ([i (in-range 1 (+ n 1))] [coeff (in-vector coeffs*)] #:unless (equal? coeff 0)) - i)) - (simplify `(+ ,@(for/list ([p (all-partitions n (sort nums >))]) - (if (= (modulo (apply + (map car p)) 2) 0) - `(* ,(if (= (modulo (apply + (map car p)) 4) 0) 1 -1) - ,@(for/list ([(count num) (in-dict p)]) - `(/ (pow ,(vector-ref coeffs* (- num 1)) ,count) - ,(factorial count)))) - 0)))))))))) + (cons 0 + (λ (n) + (hash-ref! hash + n + (λ () + (define coeffs* (list->vector (map coeffs (range 1 (+ n 1))))) + (define nums + (for/list ([i (in-range 1 (+ n 1))] + [coeff (in-vector coeffs*)] + #:unless (equal? coeff 0)) + i)) + (simplify `(+ ,@ + (for/list ([p (all-partitions n (sort nums >))]) + (if (= (modulo (apply + (map car p)) 2) 0) + `(* ,(if (= (modulo (apply + (map car p)) 4) 0) 1 -1) + ,@(for/list ([(count num) (in-dict p)]) + `(/ (pow ,(vector-ref coeffs* (- num 1)) ,count) + ,(factorial count)))) + 0)))))))))) ;; This is a hyper-specialized symbolic differentiator for log(f(x)) (define initial-logtable '((1 -1 1))) (define (list-setinc l i) - (let loop ([i i] [l l] [rest '()]) + (let loop ([i i] + [l l] + [rest '()]) (if (= i 0) (if (null? (cdr l)) (append (reverse rest) (list (- (car l) 1) 1)) @@ -409,7 +415,8 @@ (match term [`(,coeff ,ps ...) (filter identity - (for/list ([i (in-naturals)] [p ps]) + (for/list ([i (in-naturals)] + [p ps]) (if (zero? p) #f `(,(* coeff p) ,@(list-setinc ps i)))))])))) (define (lognormalize table) @@ -441,7 +448,8 @@ (match term [`(,coeff ,k ,ps ...) `(* ,coeff - (/ (* ,@(for/list ([i (in-naturals 1)] [p ps]) + (/ (* ,@(for/list ([i (in-naturals 1)] + [p ps]) (if (= p 0) 1 `(pow (* ,(factorial i) ,(coeffs i)) ,p)))) (pow ,(coeffs 0) ,(- k))))]))) ,(factorial n))))))) diff --git a/src/core/test-rules.rkt b/src/core/test-rules.rkt index 7c0557a0f..42e5211a8 100644 --- a/src/core/test-rules.rkt +++ b/src/core/test-rules.rkt @@ -47,11 +47,13 @@ (define ctx (env->ctx env out)) (match-define (list pts exs) - (parameterize ([*num-points* (num-test-points)] [*max-find-range-depth* 0]) + (parameterize ([*num-points* (num-test-points)] + [*max-find-range-depth* 0]) (cdr (sample-points '(TRUE) (list p1) (list ctx))))) (define compiler (make-real-compiler (list p2) (list ctx))) - (for ([pt (in-list pts)] [v1 (in-list exs)]) + (for ([pt (in-list pts)] + [v1 (in-list exs)]) (with-check-info* (map make-check-info (context-vars ctx) pt) (λ () (define-values (status v2) (real-apply compiler pt)) @@ -67,10 +69,13 @@ (define pre (dict-ref *conditions* name '(TRUE))) (match-define (list pts exs1 exs2) - (parameterize ([*num-points* (num-test-points)] [*max-find-range-depth* 0]) + (parameterize ([*num-points* (num-test-points)] + [*max-find-range-depth* 0]) (cdr (sample-points pre (list p1 p2) (list ctx ctx))))) - (for ([pt (in-list pts)] [v1 (in-list exs1)] [v2 (in-list exs2)]) + (for ([pt (in-list pts)] + [v1 (in-list exs1)] + [v2 (in-list exs2)]) (with-check-info* (map make-check-info (context-vars ctx) pt) (λ () (with-check-info (['lhs v1] ['rhs v2]) @@ -107,7 +112,8 @@ (module+ test (define _ (*simplify-rules*)) ; force an update - (for* ([(_ test-ruleset) (in-dict (*rulesets*))] [test-rule (first test-ruleset)]) + (for* ([(_ test-ruleset) (in-dict (*rulesets*))] + [test-rule (first test-ruleset)]) (test-case (~a (rule-name test-rule)) (check-rule-correct test-rule))) diff --git a/src/reports/common.rkt b/src/reports/common.rkt index 5c45e400d..149ad372a 100644 --- a/src/reports/common.rkt +++ b/src/reports/common.rkt @@ -235,7 +235,8 @@ #:before-last ", and "))])])) (define (format-less-than-condition variables) - (string-join (for/list ([a (in-list variables)] [b (in-list (cdr variables))]) + (string-join (for/list ([a (in-list variables)] + [b (in-list (cdr variables))]) (format "~a < ~a" a b)) " && ")) diff --git a/src/reports/core2mathjs.rkt b/src/reports/core2mathjs.rkt index 95767c1be..d2353f809 100644 --- a/src/reports/core2mathjs.rkt +++ b/src/reports/core2mathjs.rkt @@ -50,7 +50,8 @@ [(list (or '+ '- '* '/) a b) (format "(~a ~a ~a)" a op b)] [(list (or '== '< '> '<= '>=) arg args ...) (format "(~a)" - (string-join (for/list ([a (cons arg args)] [b args]) + (string-join (for/list ([a (cons arg args)] + [b args]) (format "~a ~a ~a" a op b)) " && "))] [(list '!= args ...) @@ -76,7 +77,9 @@ (define (visit-let_/mathjs vtor let_ vars vals body #:ctx ctx) (define ctx* - (for/fold ([ctx* ctx]) ([var (in-list vars)] [val (in-list vals)]) + (for/fold ([ctx* ctx]) + ([var (in-list vars)] + [val (in-list vals)]) (define val* (visit/ctx vtor val @@ -125,8 +128,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;; public ;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (expr->mathjs prog [name ""]) - (parameterize - ([*gensym-used-names* (mutable-set)] [*gensym-collisions* 1] [*gensym-fix-name* fix-name]) + (parameterize ([*gensym-used-names* (mutable-set)] + [*gensym-collisions* 1] + [*gensym-fix-name* fix-name]) ; make compiler context (define ctx (ctx-update-props (make-compiler-ctx) (append '(:precision binary64 :round nearestEven)))) @@ -141,8 +145,9 @@ (format "~a~a" body* ret))) (define (core->mathjs prog [name ""]) - (parameterize - ([*gensym-used-names* (mutable-set)] [*gensym-collisions* 1] [*gensym-fix-name* fix-name]) + (parameterize ([*gensym-used-names* (mutable-set)] + [*gensym-collisions* 1] + [*gensym-fix-name* fix-name]) ; decompose FPCore (define-values (args props body) (match prog diff --git a/src/reports/history.rkt b/src/reports/history.rkt index 5e3e17911..6ef558b5c 100644 --- a/src/reports/history.rkt +++ b/src/reports/history.rkt @@ -43,7 +43,8 @@ (define (splice-proof-step step) (let/ec k - (let loop ([expr step] [loc '()]) + (let loop ([expr step] + [loc '()]) (match expr [(list 'Rewrite=> rule sub) (define loc* (reverse loc)) @@ -52,7 +53,8 @@ (define loc* (reverse loc)) (k 'Rewrite<= rule loc* (location-do loc* step (λ _ sub)))] [(list op args ...) - (for ([arg (in-list args)] [i (in-naturals 1)]) + (for ([arg (in-list args)] + [i (in-naturals 1)]) (loop arg (cons i loc)))] [_ (void)])) (k 'Goal #f '() step))) @@ -112,7 +114,8 @@ [(alt _ `(regimes ,splitpoints) prevs _) (define intervals - (for/list ([start-sp (cons (sp -1 -1 #f) splitpoints)] [end-sp splitpoints]) + (for/list ([start-sp (cons (sp -1 -1 #f) splitpoints)] + [end-sp splitpoints]) (interval (sp-cidx end-sp) (sp-point start-sp) (sp-point end-sp) (sp-bexpr end-sp)))) (define repr (context-repr ctx)) @@ -168,7 +171,8 @@ (define (render-proof proof soundiness pcontext ctx) `(div ((class "proof")) (details (summary "Step-by-step derivation") - (ol ,@(for/list ([step proof] [sound soundiness]) + (ol ,@(for/list ([step proof] + [sound soundiness]) (define-values (dir rule loc expr) (splice-proof-step step)) ;; need to handle mixed real/float expressions (define-values (err prog) @@ -213,12 +217,14 @@ [(alt prog `(regimes ,splitpoints) prevs _) (define intervals - (for/list ([start-sp (cons (sp -1 -1 #f) splitpoints)] [end-sp splitpoints]) + (for/list ([start-sp (cons (sp -1 -1 #f) splitpoints)] + [end-sp splitpoints]) (interval (sp-cidx end-sp) (sp-point start-sp) (sp-point end-sp) (sp-bexpr end-sp)))) `#hash((program . ,(fpcore->string (expr->fpcore prog ctx))) (type . "regimes") - (conditions . ,(for/list ([entry prevs] [idx (in-naturals)]) + (conditions . ,(for/list ([entry prevs] + [idx (in-naturals)]) (let ([entry-ivals (filter (λ (intrvl) (= (interval-alt-idx intrvl) idx)) intervals)]) (map (curryr interval->string repr) entry-ivals)))) @@ -278,7 +284,8 @@ (preprocessing . ,(map (curry map symbol->string) preprocessing)))])) (define (render-proof-json proof soundiness pcontext ctx) - (for/list ([step proof] [sound soundiness]) + (for/list ([step proof] + [sound soundiness]) (define-values (dir rule loc expr) (splice-proof-step step)) (define err (if (impl-prog? expr) (errors-score (errors expr pcontext ctx)) "N/A")) diff --git a/src/reports/make-graph.rkt b/src/reports/make-graph.rkt index 94d97fba1..8dfe2e526 100644 --- a/src/reports/make-graph.rkt +++ b/src/reports/make-graph.rkt @@ -152,7 +152,10 @@ ,dropdown ,(render-help "report.html#alternatives")) ,body)) - ,@(for/list ([i (in-naturals 1)] [alt end-alts] [errs end-errors] [cost end-costs]) + ,@(for/list ([i (in-naturals 1)] + [alt end-alts] + [errs end-errors] + [cost end-costs]) (define-values (dropdown body) (render-program (alt-expr alt) ctx #:ident identifier #:instructions preprocessing)) `(section ([id ,(format "alternative~a" i)] (class "programs")) diff --git a/src/reports/plot.rkt b/src/reports/plot.rkt index d910b1458..cbfa47d46 100644 --- a/src/reports/plot.rkt +++ b/src/reports/plot.rkt @@ -58,14 +58,17 @@ (define end-error (map ulps->bits-tenths (car end-errors))) (define target-error-entries - (for/list ([i (in-naturals)] [error-value (in-list target-error)]) + (for/list ([i (in-naturals)] + [error-value (in-list target-error)]) (cons (format "target~a" (+ i 1)) error-value))) (define error-entries (list* (cons "start" start-error) (cons "end" end-error) target-error-entries)) (define ticks - (for/list ([var (in-list vars)] [idx (in-naturals)] #:unless (all-same? newpoints idx)) + (for/list ([var (in-list vars)] + [idx (in-naturals)] + #:unless (all-same? newpoints idx)) ; We want to bail out since choose-ticks will crash otherwise (define points-at-idx (map (curryr list-ref idx) points)) (define real-ticks (choose-ticks (apply min points-at-idx) (apply max points-at-idx) repr)) @@ -141,7 +144,9 @@ [(< (- (cadr necessary) (car necessary)) sub-range) (loop (cdr necessary))] [else (cons (car necessary) (loop (cdr necessary)))]))) (define all - (let loop ([necessary necessary*] [min* min] [start 0]) + (let loop ([necessary necessary*] + [min* min] + [start 0]) (cond [(>= start number) '()] [(empty? necessary) (choose-between min* max (- number start) repr)] diff --git a/src/reports/timeline.rkt b/src/reports/timeline.rkt index cfc17aa99..547163e23 100644 --- a/src/reports/timeline.rkt +++ b/src/reports/timeline.rkt @@ -37,12 +37,14 @@ ([id "process-info"]) (p ((class "header")) "Time bar (total: " (span ((class "number")) ,(format-time time)) ")") (div ((class "timeline")) - ,@(for/list ([n (in-naturals)] [curr timeline]) + ,@(for/list ([n (in-naturals)] + [curr timeline]) `(div ((class ,(format "timeline-phase timeline-~a" (dict-ref curr 'type))) [data-id ,(format "timeline~a" n)] [data-type ,(~a (dict-ref curr 'type))] [data-timespan ,(~a (dict-ref curr 'time))])))) - ,@(for/list ([phase timeline] [n (in-naturals)]) + ,@(for/list ([phase timeline] + [n (in-naturals)]) (render-phase phase n time)))) (define/contract (render-phase curr n total-time) @@ -164,7 +166,8 @@ (define (render-phase-stop data) (match-define (list (list reasons counts) ...) (sort data > #:key second)) `((dt "Stop Event") (dd (table ((class "times")) - ,@(for/list ([reason reasons] [count counts]) + ,@(for/list ([reason reasons] + [count counts]) `(tr (td ,(~r count #:group-sep " ") "×") (td ,(~a reason)))))))) (define (format-percent num den) @@ -245,7 +248,11 @@ (define (render-phase-accuracy accuracy oracle baseline name link repr-name) (define rows - (sort (for/list ([acc accuracy] [ora oracle] [bas baseline] [name name] [link link]) + (sort (for/list ([acc accuracy] + [ora oracle] + [bas baseline] + [name name] + [link link]) (list (- acc ora) (- bas acc) link name)) > #:key first)) @@ -268,7 +275,8 @@ ")") ,@(if (> (length rows) 1) `((table ((class "times")) - ,@(for/list ([rec (in-list rows)] [_ (in-range 5)]) + ,@(for/list ([rec (in-list rows)] + [_ (in-range 5)]) (match-define (list left gained link name) rec) `(tr (td ,(format-bits left #:unit #t)) (td ,(format-percent gained (+ left gained))) @@ -321,7 +329,8 @@ (define (render-phase-rules rules) `((dt "Rules") (dd (table ((class "times")) - ,@(for/list ([rec (in-list (sort rules > #:key second))] [_ (in-range 5)]) + ,@(for/list ([rec (in-list (sort rules > #:key second))] + [_ (in-range 5)]) (match-define (list rule count) rec) `(tr (td ,(~r count #:group-sep " ") "×") (td (code ,(~a rule) " ")))))))) @@ -449,7 +458,8 @@ "Weighted histogram; height corresponds to percentage of runtime in that bucket."])) (script "histogram(\"" ,(format "calls-~a" n) "\", " ,(jsexpr->string (map first times)) ")") (table ((class "times")) - ,@(for/list ([rec (in-list (sort times > #:key first))] [_ (in-range 5)]) + ,@(for/list ([rec (in-list (sort times > #:key first))] + [_ (in-range 5)]) (match-define (list time expr) rec) `(tr (td ,(format-time time)) (td (pre ,(~a expr))))))))) @@ -465,7 +475,8 @@ ((class "times")) (thead (tr (th "Time") (th "Variable") (th) (th "Point") (th "Expression"))) ,@ - (for/list ([rec (in-list (sort times > #:key first))] [_ (in-range 5)]) + (for/list ([rec (in-list (sort times > #:key first))] + [_ (in-range 5)]) (match-define (list time expr var transform) rec) `(tr (td ,(format-time time)) (td (pre ,var)) (td "@") (td ,transform) (td (pre ,expr)))))))) @@ -503,7 +514,9 @@ (td ,(~a category)))))))) (define (render-phase-inputs inputs outputs) - `((dt "Calls") (dd ,@(for/list ([call inputs] [output outputs] [n (in-naturals 1)]) + `((dt "Calls") (dd ,@(for/list ([call inputs] + [output outputs] + [n (in-naturals 1)]) `(details (summary "Call " ,(~a n)) (table (thead (tr (th "Inputs"))) ,@(for/list ([arg call]) @@ -543,7 +556,8 @@ (tr (th "Flags:") (td ((id "flag-list")) (div ((id "all-flags")) - ,@(for*/list ([(class flags) (*flags*)] [flag flags]) + ,@(for*/list ([(class flags) (*flags*)] + [flag flags]) `(kbd ,(~a class) ":" ,(~a flag)))) (div ((id "changed-flags")) ,@(if (null? (changed-flags)) diff --git a/src/syntax/matcher.rkt b/src/syntax/matcher.rkt index c32367e24..12d0c2699 100644 --- a/src/syntax/matcher.rkt +++ b/src/syntax/matcher.rkt @@ -22,7 +22,9 @@ [((list phead prest ...) (list head rest ...)) (and (equal? phead head) (= (length prest) (length rest)) - (for/fold ([bindings '()]) ([pat (in-list prest)] [term (in-list rest)]) + (for/fold ([bindings '()]) + ([pat (in-list prest)] + [term (in-list rest)]) (merge-bindings bindings (pattern-match pat term))))] [(_ _) #f])) diff --git a/src/syntax/platform.rkt b/src/syntax/platform.rkt index dc8a91a3b..6f4160699 100644 --- a/src/syntax/platform.rkt +++ b/src/syntax/platform.rkt @@ -183,8 +183,14 @@ (raise-syntax-error 'platform why stx sub-stx)) (syntax-case stx () [(_ id cs ...) - (let ([if-cost #f] [default-cost #f] [optional? #f]) - (let loop ([cs #'(cs ...)] [impls '()] [costs '()] [reprs '()] [repr-costs '()]) + (let ([if-cost #f] + [default-cost #f] + [optional? #f]) + (let loop ([cs #'(cs ...)] + [impls '()] + [costs '()] + [reprs '()] + [repr-costs '()]) (syntax-case cs () [() (let ([platform-id #'id]) @@ -314,10 +320,13 @@ (raise-syntax-error 'platform why stx sub-stx)) (syntax-case stx () [(_ cs ... pform) - (let loop ([clauses (syntax->list #'(cs ...))] [repr-filter #f] [op-filter #f]) + (let loop ([clauses (syntax->list #'(cs ...))] + [repr-filter #f] + [op-filter #f]) (syntax-case clauses () [() - (with-syntax ([repr-filter repr-filter] [op-filter op-filter]) + (with-syntax ([repr-filter repr-filter] + [op-filter op-filter]) #'((make-platform-filter (or repr-filter (const #t)) (or op-filter (const #t))) pform))] [(#:representations [reprs ...] rest ...) (begin @@ -395,7 +404,8 @@ (define bool-repr (get-representation 'bool)) (define node-cost-proc (platform-node-cost-proc pform)) (λ (expr repr) - (let loop ([expr expr] [repr repr]) + (let loop ([expr expr] + [repr repr]) (match expr [(? literal?) ((node-cost-proc expr repr))] [(? symbol?) ((node-cost-proc expr repr))] @@ -455,7 +465,8 @@ ;; All possible assignments of implementations. (define (impl-combinations ops impls) (reap [sow] - (let loop ([ops ops] [assigns '()]) + (let loop ([ops ops] + [assigns '()]) (match ops [(? null?) (sow assigns)] [(list 'if rest ...) (loop rest assigns)] @@ -473,7 +484,8 @@ (let/ec k (define env '()) (define expr* - (let loop ([expr expr] [repr repr]) + (let loop ([expr expr] + [repr repr]) (match expr [(? symbol? x) ; variable (match (dict-ref env x #f) @@ -530,8 +542,8 @@ (when itypes* (define name* (string->symbol - (format "~a-~a-~a" - name - (representation-name repr) - (string-join (map (lambda (subst) (~a (cdr subst))) isubst) "-")))) + (format "~a-~a-~a" + name + (representation-name repr) + (string-join (map (lambda (subst) (~a (cdr subst))) isubst) "-")))) (sow (rule name* input* output* itypes* repr)))))])))) diff --git a/src/syntax/read.rkt b/src/syntax/read.rkt index 8691715c3..90961ec69 100644 --- a/src/syntax/read.rkt +++ b/src/syntax/read.rkt @@ -48,14 +48,16 @@ [#`(let* ([#,vars #,vals] ...) #,body) (datum->syntax #f (list 'let* - (for/list ([var (in-list vars)] [val (in-list vals)]) + (for/list ([var (in-list vars)] + [val (in-list vals)]) (list var (expand val))) (expand body)) stx)] [#`(let ([#,vars #,vals] ...) #,body) (datum->syntax #f (list 'let - (for/list ([var (in-list vars)] [val (in-list vals)]) + (for/list ([var (in-list vars)] + [val (in-list vals)]) (list var (expand val))) (expand body)) stx)] @@ -84,7 +86,8 @@ (unless (null? rest) (warn 'variary-operator "~a is deprecated as a variary operator" op)) (define prev (datum->syntax #f (list op (expand arg1) (expand arg2)) stx)) - (let loop ([prev prev] [rest rest]) + (let loop ([prev prev] + [rest rest]) (match rest [(list) prev] [(list next rest ...) @@ -93,7 +96,9 @@ [#`(,(and (or '< '<= '> '>= '=) op) #,args ...) (define args* (map expand args)) (define out - (for/fold ([out #f]) ([term args*] [next (cdr args*)]) + (for/fold ([out #f]) + ([term args*] + [next (cdr args*)]) (datum->syntax #f (if out (list 'and out (list op term next)) (list op term next)) term))) (or out (datum->syntax #f 'TRUE stx))] [#`(!= #,args ...) @@ -168,7 +173,8 @@ (define pre* (fpcore->prog (dict-ref prop-dict ':pre 'TRUE) ctx)) (define targets - (for/list ([(key val) (in-dict prop-dict)] #:when (eq? key ':alt)) + (for/list ([(key val) (in-dict prop-dict)] + #:when (eq? key ':alt)) (match (parse-platform-name val) ; plat-name is symbol or #f ; If plat-name extracted, check if name matches [(? symbol? plat-name) (cons val (equal? plat-name (*platform-name*)))] @@ -193,7 +199,8 @@ pre* (dict-ref prop-dict ':herbie-preprocess empty) (representation-name default-repr) - (for/list ([var (in-list var-names)] [repr (in-list var-reprs)]) + (for/list ([var (in-list var-names)] + [repr (in-list var-reprs)]) (cons var (representation-name repr))))) (define (check-unused-variables vars precondition expr) @@ -212,7 +219,8 @@ (string-join (map ~a unused) ", ")))) (define (check-weird-variables vars) - (for* ([var vars] [const (all-constants)]) + (for* ([var vars] + [const (all-constants)]) (when (string-ci=? (symbol->string var) (symbol->string const)) (warn 'strange-variable #:url "faq.html#strange-variable" diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 794a7eaaa..0ce7add30 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -72,16 +72,22 @@ ;; Expression pre-processing for normalizing expressions. ;; Used for conversion from FPCore to other IRs. (define (expand-expr expr) - (let loop ([expr expr] [env '()]) + (let loop ([expr expr] + [env '()]) (match expr ; empty let/let* expression [`(,(or 'let 'let*) () ,body) (loop body env)] ; let* expression - [`(let* ([,var ,val] ,rest ...) ,body) (loop `(let ([,var ,val]) (let* ,rest ,body)) env)] + [`(let* ([,var ,val] + ,rest ...) + ,body) + (loop `(let ([,var ,val]) (let* ,rest ,body)) env)] ; let expression [`(let ([,vars ,vals] ...) ,body) (define env* - (for/fold ([env* env]) ([var (in-list vars)] [val (in-list vals)]) + (for/fold ([env* env]) + ([var (in-list vars)] + [val (in-list vals)]) (dict-set env* var (loop val env)))) (loop body env*)] ; nullary expressions @@ -99,7 +105,9 @@ [`(,(and (or '< '<= '> '>= '=) op) ,as ...) (define as* (map (curryr loop env) as)) (define out - (for/fold ([out #f]) ([term as*] [next (cdr as*)]) + (for/fold ([out #f]) + ([term as*] + [next (cdr as*)]) (if out (list 'and out (list op term next)) (list op term next)))) (or out '(TRUE))] [`(!= ,as ...) @@ -118,7 +126,9 @@ [(list (? (curry hash-has-key? (*functions*)) fname) args ...) (match-define (list vars _ body) (hash-ref (*functions*) fname)) (define env* - (for/fold ([env* '()]) ([var (in-list vars)] [arg (in-list args)]) + (for/fold ([env* '()]) + ([var (in-list vars)] + [arg (in-list args)]) (dict-set env* var (loop arg env)))) (loop body env*)] ; applications @@ -148,7 +158,8 @@ ;; Translates from FPCore to an LImpl. (define (fpcore->prog prog ctx) - (let loop ([expr (expand-expr prog)] [prop-dict (repr->prop (context-repr ctx))]) + (let loop ([expr (expand-expr prog)] + [prop-dict (repr->prop (context-repr ctx))]) (match expr [(? number? n) (literal (match n @@ -226,7 +237,8 @@ (define (inline! root ivec ctx) (define global-prop-dict (repr->prop (context-repr ctx))) - (let loop ([node root] [prop-dict global-prop-dict]) + (let loop ([node root] + [prop-dict global-prop-dict]) (match node [(? number?) node] ; number [(? symbol?) node] ; variable @@ -302,7 +314,8 @@ ; need fresh variables for reachable, non-inlined subexpressions (define reachable (reachable-indices ivec expr)) (define id->name (make-hash)) - (for ([expr (in-vector ivec)] [idx (in-naturals)]) + (for ([expr (in-vector ivec)] + [idx (in-naturals)]) (when (and expr (set-member? reachable idx)) (hash-set! id->name idx (gensym)))) diff --git a/src/syntax/syntax-check.rkt b/src/syntax/syntax-check.rkt index 4e0163e89..4d53745b2 100644 --- a/src/syntax/syntax-check.rkt +++ b/src/syntax/syntax-check.rkt @@ -8,7 +8,8 @@ (provide assert-program!) (define (check-expression* stx vars error! deprecated-ops) - (let loop ([stx stx] [vars vars]) + (let loop ([stx stx] + [vars vars]) (match stx [#`,(? number?) (void)] [#`,(? constant-operator?) (void)] @@ -17,7 +18,9 @@ (error! stx "Unknown variable ~a" var))] [#`(let* ([#,vars* #,vals] ...) #,body) (define bindings - (for/fold ([vars vars]) ([var vars*] [val vals]) + (for/fold ([vars vars]) + ([var vars*] + [val vals]) (unless (identifier? var) (error! var "Invalid variable name ~a" var)) (loop val vars) @@ -25,7 +28,8 @@ (loop body bindings)] [#`(let ([#,vars* #,vals] ...) #,body) ;; These are unfolded by desugaring - (for ([var vars*] [val vals]) + (for ([var vars*] + [val vals]) (unless (identifier? var) (error! var "Invalid variable name ~a" var)) (loop val vars)) @@ -101,7 +105,8 @@ (define (check-properties* props vars error! deprecated-ops) (define prop-dict - (let loop ([props props] [out '()]) + (let loop ([props props] + [out '()]) (match props [(list (? identifier? prop-name) value rest ...) (check-property* prop-name error!) @@ -131,7 +136,8 @@ (when (dict-has-key? prop-dict ':cite) (define cite (dict-ref prop-dict ':cite)) (if (list? (syntax-e cite)) - (for ([citation (syntax-e cite)] #:unless (identifier? citation)) + (for ([citation (syntax-e cite)] + #:unless (identifier? citation)) (error! citation "Invalid citation ~a; must be a variable name" citation)) (error! cite "Invalid :cite ~a; must be a list" cite))) @@ -148,7 +154,8 @@ (error! stx "Invalid arguments list ~a; must be a list" stx)) (define vars* (filter identifier? vars)) (when (list? vars) - (for ([var vars] #:unless (identifier? var)) + (for ([var vars] + #:unless (identifier? var)) (error! stx "Argument ~a is not a variable name" var)) (when (check-duplicate-identifier vars*) (error! stx "Duplicate argument name ~a" (check-duplicate-identifier vars*)))) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index e408d391b..2ab60d102 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -74,7 +74,8 @@ ;; Returns all constant operators (operators with no arguments). (define (all-constants) - (sort (for/list ([(name rec) (in-hash operators)] #:when (null? (operator-itype rec))) + (sort (for/list ([(name rec) (in-hash operators)] + #:when (null? (operator-itype rec))) name) symbollist #'(key ...))] [vals (syntax->list #'(val ...))]) + (let ([id #'id] + [keys (syntax->list #'(key ...))] + [vals (syntax->list #'(val ...))]) (unless (identifier? id) (bad! "expected identifier" id)) - (with-syntax ([id id] [(val ...) (map attribute-val keys vals)]) + (with-syntax ([id id] + [(val ...) (map attribute-val keys vals)]) #'(register-operator-impl! 'op 'id (list (get-representation 'itype) ...) @@ -461,8 +466,8 @@ (and (symbol? x) (impl-exists? x) (match (impl-info x 'spec) - [(list 'cast _) #t] - [_ #f]))) + [(list 'cast _) #t] + [_ #f]))) (define (get-cast-impl irepr orepr #:impls [impls (all-active-operator-impls)]) (get-fpcore-impl 'cast (repr->prop orepr) (list irepr) #:impls impls)) diff --git a/src/syntax/type-check.rkt b/src/syntax/type-check.rkt index 1114f9d64..bf22dbbb0 100644 --- a/src/syntax/type-check.rkt +++ b/src/syntax/type-check.rkt @@ -56,7 +56,9 @@ " "))) (define (expression->type stx prop-dict ctx error!) - (let loop ([stx stx] [prop-dict prop-dict] [ctx ctx]) + (let loop ([stx stx] + [prop-dict prop-dict] + [ctx ctx]) (match stx [#`,(? number?) (get-representation (dict-ref prop-dict ':precision))] [#`,(? variable? x) (context-lookup ctx x)] @@ -71,12 +73,16 @@ [_ (impl-info impl 'otype)])] [#`(let ([,ids #,exprs] ...) #,body) (define ctx* - (for/fold ([ctx* ctx]) ([id (in-list ids)] [expr (in-list exprs)]) + (for/fold ([ctx* ctx]) + ([id (in-list ids)] + [expr (in-list exprs)]) (context-extend ctx* id (loop expr prop-dict ctx)))) (loop body prop-dict ctx*)] [#`(let* ([,ids #,exprs] ...) #,body) (define ctx* - (for/fold ([ctx* ctx]) ([id (in-list ids)] [expr (in-list exprs)]) + (for/fold ([ctx* ctx]) + ([id (in-list ids)] + [expr (in-list exprs)]) (context-extend ctx* id (loop expr prop-dict ctx*)))) (loop body prop-dict ctx*)] [#`(if #,branch #,ifstmt #,elsestmt) diff --git a/src/utils/common.rkt b/src/utils/common.rkt index e031b0815..a51507868 100644 --- a/src/utils/common.rkt +++ b/src/utils/common.rkt @@ -60,10 +60,14 @@ ;; Utility list functions (define (argmins f lst) - (let loop ([lst lst] [best-score #f] [best-elts '()]) + (let loop ([lst lst] + [best-score #f] + [best-elts '()]) (if (null? lst) (reverse best-elts) - (let* ([elt (car lst)] [lst* (cdr lst)] [score (f elt)]) + (let* ([elt (car lst)] + [lst* (cdr lst)] + [score (f elt)]) (cond [(not best-score) (loop lst* score (list elt))] [(< score best-score) (loop lst* score (list elt))] @@ -133,7 +137,10 @@ (check-false (subsequence? '(1 2 10) l))) (define (list-set* l p v) - (let loop ([l l] [p p] [v v] [i 0]) + (let loop ([l l] + [p p] + [v v] + [i 0]) (cond [(empty? l) empty] [(and (not (empty? p)) (equal? (first p) i)) @@ -288,7 +295,8 @@ ;; Prop list to dict (define/contract (props->dict props) (-> list? (listof (cons/c symbol? any/c))) - (let loop ([props props] [dict '()]) + (let loop ([props props] + [dict '()]) (match props [(list key val rest ...) (loop rest (dict-set dict key val))] [(list key) (error 'props->dict "unmatched key" key)] diff --git a/src/utils/multi-command-line.rkt b/src/utils/multi-command-line.rkt index 1e1a0ae66..30e6019aa 100644 --- a/src/utils/multi-command-line.rkt +++ b/src/utils/multi-command-line.rkt @@ -16,7 +16,8 @@ #:program true-name #:multi [("-v" "--version") ("Print the version and exit") (printf "~a\n" version) (exit)] #:usage-help "This command has subcommands:" - #,@(for/list ([name (syntax->list #'(name ...))] [help (syntax->list #'(help ...))]) + #,@(for/list ([name (syntax->list #'(name ...))] + [help (syntax->list #'(help ...))]) (datum->syntax name (format " ~a:\t~a" (syntax->datum name) (syntax->datum help)))) "Learn more about a subcommand with --help" #:args cmdline-args diff --git a/src/utils/pareto.rkt b/src/utils/pareto.rkt index 7107a078b..5ddc89fcc 100644 --- a/src/utils/pareto.rkt +++ b/src/utils/pareto.rkt @@ -38,7 +38,8 @@ ;; and returns the Pareto-optimal subset of their union. ;; The curves most be sorted using the same method. (define (pareto-union curve1 curve2) - (let loop ([curve1 curve1] [curve2 curve2]) + (let loop ([curve1 curve1] + [curve2 curve2]) ; The curve is sorted so that highest accuracy is first (match* (curve1 curve2) [('() _) curve2] @@ -59,7 +60,8 @@ ;; Takes a Pareto frontier and returns the subset of ;; points that are convex. (define (pareto-convex ppts) - (let loop ([ppts* '()] [ppts ppts]) + (let loop ([ppts* '()] + [ppts ppts]) (match ppts [(list p0 p1 p2 pns ...) (match-define (pareto-point p0x p0y _) p0) @@ -90,10 +92,14 @@ (define (finalize f) (if convex? (pareto-convex f) f)) (define frontiers* (map (λ (f) (pareto-minimize (map pt->ppt f))) frontiers)) - (for/fold ([combined (list)] #:result (map ppt->pt combined)) ([frontier (in-list frontiers*)]) + (for/fold ([combined (list)] + #:result (map ppt->pt combined)) + ([frontier (in-list frontiers*)]) (if (null? combined) (finalize frontier) - (for/fold ([combined* (list)] #:result (finalize combined*)) ([ppt (in-list combined)]) + (for/fold ([combined* (list)] + #:result (finalize combined*)) + ([ppt (in-list combined)]) (let ([ppts (pareto-minimize (pareto-shift ppt frontier))]) (pareto-union ppts combined*)))))) diff --git a/src/utils/pretty-print.rkt b/src/utils/pretty-print.rkt index 46893b9bb..f1d42612e 100644 --- a/src/utils/pretty-print.rkt +++ b/src/utils/pretty-print.rkt @@ -30,7 +30,8 @@ (values pre "0" e) (values (substring pre 0 1) (substring pre 1) (- (string-length pre) 1)))] [(list "0" s) - (let loop ([idx 0] [e e]) + (let loop ([idx 0] + [e e]) (if (eq? (string-ref s idx) #\0) (loop (+ idx 1) (- e 1)) (values (substring s idx (+ idx 1)) (substring s (+ idx 1)) (- e 1))))] @@ -60,7 +61,8 @@ (define (digit-interval-shortest a b) (define digits '(0 5 2 4 6 8 1 3 7 9)) - (for/first ([d digits] #:when (<= a d b)) + (for/first ([d digits] + #:when (<= a d b)) d)) (define (string-interval-shortest a b) diff --git a/src/utils/profile.rkt b/src/utils/profile.rkt index 50fbbf30d..63bd868b7 100644 --- a/src/utils/profile.rkt +++ b/src/utils/profile.rkt @@ -8,9 +8,11 @@ (define nodes (make-hash)) (define root-node (node #f #f '() 0 0 '() '())) (hash-set! nodes (cons #f #f) root-node) - (for* ([p (in-list ps)] [n (profile-nodes p)]) + (for* ([p (in-list ps)] + [n (profile-nodes p)]) (hash-set! nodes (node-loc n) (node (node-id n) (node-src n) '() 0 0 '() '()))) - (for* ([p ps] [node (profile-nodes p)]) + (for* ([p ps] + [node (profile-nodes p)]) (profile-add nodes node)) (for ([p ps]) (profile-add nodes (profile-*-node p))) @@ -56,14 +58,16 @@ (define (merge-thread-times . ts) (define h (make-hash)) - (for* ([t (in-list ts)] [(id time) (in-dict t)]) + (for* ([t (in-list ts)] + [(id time) (in-dict t)]) (hash-update! h id (curry + time) 0)) h) (define (profile->json p) (define nodes (cons (profile-*-node p) (profile-nodes p))) (define loc-hash - (for/hash ([node (in-list nodes)] [n (in-naturals)]) + (for/hash ([node (in-list nodes)] + [n (in-naturals)]) (values (node-loc node) n))) (define node-hash (for/hash ([node (in-list nodes)]) @@ -123,7 +127,8 @@ (hash-ref n 'self) '() '()))) - (for ([n (in-list (hash-ref j 'nodes))] [n* (in-vector nodes)]) + (for ([n (in-list (hash-ref j 'nodes))] + [n* (in-vector nodes)]) (set-node-callees! n* (for/list ([e (hash-ref n 'callees)]) (edge (hash-ref e 'total) diff --git a/src/utils/timeline.rkt b/src/utils/timeline.rkt index a71dc7f2c..0d5e00a47 100644 --- a/src/utils/timeline.rkt +++ b/src/utils/timeline.rkt @@ -43,7 +43,8 @@ (unless (*timeline-disabled*) (when (pair? (unbox (*timeline*))) - (for ([key (in-list always-compact)] #:when (hash-has-key? (car (unbox (*timeline*))) key)) + (for ([key (in-list always-compact)] + #:when (hash-has-key? (car (unbox (*timeline*))) key)) (timeline-compact! key))) (define live-memory (current-memory-use #f)) (define alloc-memory (current-memory-use 'cumulative)) @@ -73,7 +74,8 @@ (define (timeline-adjust! type key . values) (unless (*timeline-disabled*) - (for/first ([cell (unbox (*timeline*))] #:when (equal? (hash-ref cell 'type) (~a type))) + (for/first ([cell (unbox (*timeline*))] + #:when (equal? (hash-ref cell 'type) (~a type))) (hash-set! cell key values) true) (void))) @@ -131,7 +133,8 @@ (current-inexact-milliseconds) 'memory (list (list (current-memory-use #f) (current-memory-use 'cumulative))))) - (reverse (for/list ([evt (unbox (*timeline*))] [next (cons end (unbox (*timeline*)))]) + (reverse (for/list ([evt (unbox (*timeline*))] + [next (cons end (unbox (*timeline*)))]) (define evt* (hash-copy evt)) (hash-update! evt* 'time (λ (v) (- (hash-ref next 'time) v))) (hash-update! evt* 'memory (λ (v) (diff-memory-records (hash-ref next 'memory) v))) @@ -165,18 +168,22 @@ (hash-update! groups key (λ (old) - (for/list ([value2 old] [(value1 fn) (in-dict values)]) + (for/list ([value2 old] + [(value1 fn) (in-dict values)]) (fn value2 value1)))) (hash-set! groups key (map car values)))) (for/list ([(k v) (in-hash groups)]) - (let loop ([fields fields] [k k] [v v]) + (let loop ([fields fields] + [k k] + [v v]) (match* (fields k v) [((cons #f f*) (cons k k*) v) (cons k (loop f* k* v))] [((cons _ f*) k (cons v v*)) (cons v (loop f* k v*))] [('() '() '()) '()]))))) (define (merge-sampling-tables l1 l2) - (let loop ([l1 (sort l1 < #:key first)] [l2 (sort l2 < #:key first)]) + (let loop ([l1 (sort l1 < #:key first)] + [l2 (sort l2 < #:key first)]) (match-define (list n1 t1) (car l1)) (match-define (list n2 t2) (car l2)) (define rec (list n1 (hash-union t1 t2 #:combine +))) @@ -230,9 +237,11 @@ (define (timeline-merge . timelines) ;; The timelines in this case are JSON objects, as above (define types (make-hash)) - (for* ([tl (in-list timelines)] [event tl]) + (for* ([tl (in-list timelines)] + [event tl]) (define data (hash-ref! types (hash-ref event 'type) (make-hash))) - (for ([(k v) (in-dict event)] #:when (hash-ref timeline-types k #f)) + (for ([(k v) (in-dict event)] + #:when (hash-ref timeline-types k #f)) (if (hash-has-key? data k) (hash-update! data k (λ (old) ((hash-ref timeline-types k) v old))) (hash-set! data k v)))) From f3f9b15dcc44322732c953fb4572cfc65bb32c3d Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Tue, 13 Aug 2024 15:06:13 -0700 Subject: [PATCH 25/64] fix bad merge --- src/core/egg-herbie.rkt | 6 +- src/platforms/binary32.rkt | 2 +- src/platforms/fallback.rkt | 3 +- src/platforms/runtime/libm.rkt | 18 +++-- src/syntax/syntax.rkt | 119 +++++++++++++++++---------------- 5 files changed, 77 insertions(+), 71 deletions(-) diff --git a/src/core/egg-herbie.rkt b/src/core/egg-herbie.rkt index 1cfdb461a..2c4648959 100644 --- a/src/core/egg-herbie.rkt +++ b/src/core/egg-herbie.rkt @@ -947,12 +947,12 @@ [(list '$approx _ impl) (rec impl)] [(list 'if cond ift iff) (+ 1 (rec cond) (rec ift) (rec iff))] [(list (? impl-exists? impl) args ...) - (cond - [(equal? (impl->operator impl) 'pow) + (match (impl-info impl 'spec) + [(list 'pow _ _) (match-define (list b e) args) (define n (vector-ref (regraph-constants regraph) e)) (if (fraction-with-odd-denominator? n) +inf.0 (+ 1 (rec b) (rec e)))] - [else (apply + 1 (map rec args))])] + [_ (apply + 1 (map rec args))])] [(list 'pow b e) (define n (vector-ref (regraph-constants regraph) e)) (if (fraction-with-odd-denominator? n) +inf.0 (+ 1 (rec b) (rec e)))] diff --git a/src/platforms/binary32.rkt b/src/platforms/binary32.rkt index 418441c4c..aeeff104b 100644 --- a/src/platforms/binary32.rkt +++ b/src/platforms/binary32.rkt @@ -57,7 +57,7 @@ #:spec (+ x y) #:fpcore (! :precision binary32 (+ x y)) #:fl fl32+) - + (define-operator-impl (-.f32 [x : binary32] [y : binary32]) binary32 #:spec (- x y) diff --git a/src/platforms/fallback.rkt b/src/platforms/fallback.rkt index ffe054382..8d79a525d 100644 --- a/src/platforms/fallback.rkt +++ b/src/platforms/fallback.rkt @@ -125,8 +125,7 @@ binary64 #:spec (+ (* x y) z) #:fpcore (! :precision binary64 :math-library racket (fma x y z)) - #:fl (from-bigfloat bffma) - #:op fma) + #:fl (from-bigfloat bffma)) (define-comparator-impls binary64 [== ==.rkt =] diff --git a/src/platforms/runtime/libm.rkt b/src/platforms/runtime/libm.rkt index 0659e71f3..e123d5e89 100644 --- a/src/platforms/runtime/libm.rkt +++ b/src/platforms/runtime/libm.rkt @@ -51,18 +51,22 @@ [integer #'integer] [_ (oops! "unknown type" repr)])) (syntax-case stx () - [(_ cname (id name itype ...) otype attrib ...) + [(_ cname (op name itype ...) otype fields ...) (begin (unless (identifier? #'cname) (oops! "expected identifier" #'cname)) - (unless (identifier? #'id) - (oops! "expected identifier" #'id)) + (unless (identifier? #'op) + (oops! "expected identifier" #'op)) (unless (identifier? #'name) (oops! "expected identifier" #'name)) - (with-syntax ([(citype ...) (map repr->type (syntax->list #'(itype ...)))] - [cotype (repr->type #'otype)] - [(var ...) (generate-temporaries #'(itype ...))]) + (with-syntax ([(var ...) (generate-temporaries #'(itype ...))] + [(citype ...) (map repr->type (syntax->list #'(itype ...)))] + [cotype (repr->type #'otype)]) #'(begin (define-libm proc (cname citype ... cotype)) (when proc - (define-operator-impl (name [var : itype] ...) otype #:fl proc #:op id)))))])) + (define-operator-impl (name [var : itype] ...) + otype + #:spec (op var ...) + #:fl proc + fields ...)))))])) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index c04f01fbb..4db76b8a7 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -90,61 +90,6 @@ [(itype) (operator-itype info)] [(otype) (operator-otype info)])) -;; Checks a specification -(define (check-spec! name itypes otype spec) - (define (bad! fmt . args) - (error name "~a in `~a`" (apply format fmt args) spec)) - - (define (type-error! expr actual-ty expect-ty) - (bad! "expression `~a` has type `~a`, expected `~a`" expr actual-ty expect-ty)) - - (define-values (vars body) - (match spec - [`(,(or 'lambda 'λ) (,vars ...) ,spec) - (for ([var (in-list vars)]) - (unless (symbol? var) - (bad! "expected symbol `~a` in `~a`" var spec))) - (values vars spec)] - [_ (bad! "malformed specification, expected `(lambda )`")])) - - (unless (= (length itypes) (length vars)) - (bad! "arity mismatch; expected ~a, got ~a" (length itypes) (length vars))) - - (define env (map cons vars itypes)) - (define actual-ty - (let type-of ([expr body]) - (match expr - [(? number?) 'real] - [(? symbol?) - (cond - [(assq expr env) - => - cdr] - [else (bad! "unbound variable `~a`" expr)])] - [`(if ,cond ,ift ,iff) - (define cond-ty (type-of cond)) - (unless (equal? cond-ty 'bool) - (type-error! cond cond-ty 'bool)) - (define ift-ty (type-of ift)) - (define iff-ty (type-of iff)) - (unless (equal? ift-ty iff-ty) - (type-error! iff iff-ty ift-ty)) - ift-ty] - [`(,op ,args ...) - (unless (operator-exists? op) - (bad! "expected operator at `~a`, got `~a` in `~a`" expr op)) - (define itypes (operator-info op 'itype)) - (for ([arg (in-list args)] - [itype (in-list itypes)]) - (define arg-ty (type-of arg)) - (unless (equal? itype arg-ty) - (type-error! arg arg-ty itype))) - (operator-info op 'otype)] - [_ (bad! "expected an expression, got `~a`" expr)]))) - - (unless (equal? actual-ty otype) - (type-error! body actual-ty otype))) - ;; Registers an operator with an attribute mapping. ;; Panics if an operator with name `name` has already been registered. ;; By default, the input types are specified by `itypes`, the output type @@ -323,7 +268,62 @@ (define (clear-active-operator-impls!) (set-clear! active-operator-impls)) -;; Collects all operators +;; Collects all operators + +;; Expands and checks a specification. +(define (expand-spec name itypes otype spec) + (define (bad! fmt . args) + (error name "~a in `~a`" (apply format fmt args) spec)) + + (define (type-error! expr actual-ty expect-ty) + (bad! "expression `~a` has type `~a`, expected `~a`" expr actual-ty expect-ty)) + + (define-values (vars body) + (match spec + [`(,(or 'lambda 'λ) (,vars ...) ,spec) + (for ([var (in-list vars)]) + (unless (symbol? var) + (bad! "expected symbol `~a` in `~a`" var spec))) + (values vars spec)] + [_ (bad! "malformed specification, expected `(lambda )`")])) + + (unless (= (length itypes) (length vars)) + (bad! "arity mismatch; expected ~a, got ~a" (length itypes) (length vars))) + + (define env (map cons vars itypes)) + (define actual-ty + (let type-of ([expr body]) + (match expr + [(? number?) 'real] + [(? symbol?) + (cond + [(assq expr env) + => + cdr] + [else (bad! "unbound variable `~a`" expr)])] + [`(if ,cond ,ift ,iff) + (define cond-ty (type-of cond)) + (unless (equal? cond-ty 'bool) + (type-error! cond cond-ty 'bool)) + (define ift-ty (type-of ift)) + (define iff-ty (type-of iff)) + (unless (equal? ift-ty iff-ty) + (type-error! iff iff-ty ift-ty)) + ift-ty] + [`(,op ,args ...) + (unless (operator-exists? op) + (bad! "expected operator at `~a`, got `~a` in `~a`" expr op)) + (define itypes (operator-info op 'itype)) + (for ([arg (in-list args)] + [itype (in-list itypes)]) + (define arg-ty (type-of arg)) + (unless (equal? itype arg-ty) + (type-error! arg arg-ty itype))) + (operator-info op 'otype)] + [_ (bad! "expected an expression, got `~a`" expr)]))) + + (unless (equal? actual-ty otype) + (type-error! body actual-ty otype))) ; Registers an operator implementation `name` with context `ctx` and spec `spec. ; Can optionally specify a floating-point implementation and fpcore translation. @@ -331,7 +331,10 @@ (->* (symbol? context? any/c) (#:fl (or/c procedure? #f) #:fpcore any/c) void?) (match-define (context vars orepr ireprs) ctx) ; check specification - (check-spec! name (map representation-type ireprs) (representation-type orepr) spec) + (expand-spec name + (map representation-type ireprs) + (representation-type orepr) + (list 'lambda vars spec)) ; synthesize operator (if the spec contains exactly one operator) (define op (match spec @@ -356,7 +359,7 @@ (define fl-proc* (cond [fl-proc ; provided => check arity - (unless (procedure-arity-includes? fl-proc (length vars) #t) + (unless (procedure-arity-includes? fl-proc (length vars) #t) (error 'register-operator-impl! "~a: procedure does not accept ~a arguments" name From 0e679b2a6bcf30384f32216db1855ab5749c534a Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Tue, 13 Aug 2024 15:18:50 -0700 Subject: [PATCH 26/64] fixes --- src/platforms/binary32.rkt | 16 ++++++++-------- src/platforms/binary64.rkt | 16 ++++++++-------- src/platforms/fallback.rkt | 28 ++++++++++++++++++++++++---- src/syntax/syntax.rkt | 28 ++++++++++------------------ src/syntax/test-syntax.rkt | 21 +++++++++------------ 5 files changed, 59 insertions(+), 50 deletions(-) diff --git a/src/platforms/binary32.rkt b/src/platforms/binary32.rkt index aeeff104b..e7f5142db 100644 --- a/src/platforms/binary32.rkt +++ b/src/platforms/binary32.rkt @@ -116,19 +116,12 @@ [(binary32 binary32 binary32) (atan2 copysign fdim fmax fmin fmod pow remainder)]) -(define-libm c_expm1f (expm1 float float)) (define-libm c_erfcf (erfc float float)) +(define-libm c_expm1f (expm1 float float)) (define-libm c_log1pf (log1p float float)) (define-libm c_hypotf (hypot float float float)) (define-libm c_fmaf (fma float float float float)) -(when c_expm1f - (define-operator-impl (expm1.f32 [x : binary32]) - binary32 - #:spec (- (exp x) 1) - #:fpcore (! :precision binary32 (expm1 x)) - #:fl c_expm1f)) - (when c_erfcf (define-operator-impl (erfc.f32 [x : binary32]) binary32 @@ -136,6 +129,13 @@ #:fpcore (! :precision binary32 (erfc x)) #:fl c_erfcf)) +(when c_expm1f + (define-operator-impl (expm1.f32 [x : binary32]) + binary32 + #:spec (- (exp x) 1) + #:fpcore (! :precision binary32 (expm1 x)) + #:fl c_expm1f)) + (when c_log1pf (define-operator-impl (log1p.f32 [x : binary32]) binary32 diff --git a/src/platforms/binary64.rkt b/src/platforms/binary64.rkt index b3691a1ce..e42705515 100644 --- a/src/platforms/binary64.rkt +++ b/src/platforms/binary64.rkt @@ -108,19 +108,12 @@ [(binary64 binary64 binary64) (atan2 copysign fdim fmax fmin fmod pow remainder)]) -(define-libm c_expm1 (expm1 double double)) (define-libm c_erfc (erfc double double)) +(define-libm c_expm1 (expm1 double double)) (define-libm c_log1p (log1p double double)) (define-libm c_hypot (hypot double double double)) (define-libm c_fma (fma double double double double)) -(when c_expm1 - (define-operator-impl (expm1.f64 [x : binary64]) - binary64 - #:spec (- (exp x) 1) - #:fpcore (! :precision binary64 (expm1 x)) - #:fl c_expm1)) - (when c_erfc (define-operator-impl (erfc.f64 [x : binary64]) binary64 @@ -128,6 +121,13 @@ #:fpcore (! :precision binary64 (erfc x)) #:fl c_erfc)) +(when c_expm1 + (define-operator-impl (expm1.f64 [x : binary64]) + binary64 + #:spec (- (exp x) 1) + #:fpcore (! :precision binary64 (expm1 x)) + #:fl c_expm1)) + (when c_log1p (define-operator-impl (log1p.f64 [x : binary64]) binary64 diff --git a/src/platforms/fallback.rkt b/src/platforms/fallback.rkt index 8d79a525d..8456e0ff8 100644 --- a/src/platforms/fallback.rkt +++ b/src/platforms/fallback.rkt @@ -75,16 +75,13 @@ [cos cos] [cosh cosh] [erf (no-complex erf)] - [erfc erfc] [exp exp] [exp2 (no-complex (λ (x) (expt 2 x)))] - [expm1 (from-bigfloat bfexpm1)] [fabs abs] [floor floor] [lgamma log-gamma] [log (no-complex log)] [log10 (no-complex (λ (x) (log x 10)))] - [log1p (from-bigfloat bflog1p)] [log2 (from-bigfloat bflog2)] [logb (λ (x) (floor (bigfloat->flonum (bflog2 (bf (abs x))))))] [rint round] @@ -117,10 +114,33 @@ [(nan? y) x] [else (min x y)]))] [fmod (from-bigfloat bffmod)] - [hypot (from-bigfloat bfhypot)] [pow (no-complex expt)] [remainder remainder]) +(define-operator-impl (erfc.rkt [x : binary64]) + binary64 + #:spec (- 1 (erf x)) + #:fpcore (! :precision binary64 :math-library racket (erfc x)) + #:fl erfc) + +(define-operator-impl (expm1.rkt [x : binary64]) + binary64 + #:spec (- (exp x) 1) + #:fpcore (! :precision binary64 :math-library racket (expm1 x)) + #:fl (from-bigfloat bfexpm1)) + +(define-operator-impl (log1p.rkt [x : binary64]) + binary64 + #:spec (log (+ 1 x)) + #:fpcore (! :precision binary64 :math-library racket (log1p x)) + #:fl (from-bigfloat bflog1p)) + +(define-operator-impl (hypot.rkt [x : binary64] [y : binary64]) + binary64 + #:spec (sqrt (+ (* x x) (* y y))) + #:fpcore (! :precision binary64 :math-library racket (hypot x y)) + #:fl (from-bigfloat bfhypot)) + (define-operator-impl (fma.rkt [x : binary64] [y : binary64] [z : binary64]) binary64 #:spec (+ (* x y) z) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 4db76b8a7..a976fe3c2 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -270,29 +270,24 @@ ;; Collects all operators -;; Expands and checks a specification. -(define (expand-spec name itypes otype spec) +;; Checks a specification. +(define (check-spec! name ctx spec) (define (bad! fmt . args) (error name "~a in `~a`" (apply format fmt args) spec)) (define (type-error! expr actual-ty expect-ty) (bad! "expression `~a` has type `~a`, expected `~a`" expr actual-ty expect-ty)) - (define-values (vars body) - (match spec - [`(,(or 'lambda 'λ) (,vars ...) ,spec) - (for ([var (in-list vars)]) - (unless (symbol? var) - (bad! "expected symbol `~a` in `~a`" var spec))) - (values vars spec)] - [_ (bad! "malformed specification, expected `(lambda )`")])) + (match-define (context vars repr var-reprs) ctx) + (define itypes (map representation-type var-reprs)) + (define otype (representation-type repr)) (unless (= (length itypes) (length vars)) (bad! "arity mismatch; expected ~a, got ~a" (length itypes) (length vars))) (define env (map cons vars itypes)) (define actual-ty - (let type-of ([expr body]) + (let type-of ([expr spec]) (match expr [(? number?) 'real] [(? symbol?) @@ -323,18 +318,15 @@ [_ (bad! "expected an expression, got `~a`" expr)]))) (unless (equal? actual-ty otype) - (type-error! body actual-ty otype))) + (type-error! spec actual-ty otype))) ; Registers an operator implementation `name` with context `ctx` and spec `spec. ; Can optionally specify a floating-point implementation and fpcore translation. (define/contract (register-operator-impl! name ctx spec #:fl [fl-proc #f] #:fpcore [fpcore #f]) (->* (symbol? context? any/c) (#:fl (or/c procedure? #f) #:fpcore any/c) void?) - (match-define (context vars orepr ireprs) ctx) ; check specification - (expand-spec name - (map representation-type ireprs) - (representation-type orepr) - (list 'lambda vars spec)) + (check-spec! name ctx spec) + (define vars (context-vars ctx)) ; synthesize operator (if the spec contains exactly one operator) (define op (match spec @@ -373,7 +365,7 @@ (if exs (first exs) fail)) name)])) ; update tables - (define impl (operator-impl name ctx spec fpcore fl-proc)) + (define impl (operator-impl name ctx spec fpcore* fl-proc*)) (hash-set! operator-impls name impl)) (define-syntax (define-operator-impl stx) diff --git a/src/syntax/test-syntax.rkt b/src/syntax/test-syntax.rkt index d14c12f32..6004c713c 100644 --- a/src/syntax/test-syntax.rkt +++ b/src/syntax/test-syntax.rkt @@ -13,12 +13,10 @@ ; log1pmd(x) = log1p(x) - log1p(-x) - (define-operator (log1pmd real) real) - - (define-operator-impl (log1pmd log1pmd.f64 binary64) + (define-operator-impl (log1pmd.f64 [x : binary64]) binary64 - [spec (lambda (x) (- (log (+ 1 x)) (log (+ 1 (neg x)))))] - [fpcore (! :precision binary64 (log1pmd x))]) + #:spec (- (log (+ 1 x)) (log (+ 1 (neg x)))) + #:fpcore (! :precision binary64 (log1pmd x))) (define log1pmd-proc (impl-info 'log1pmd.f64 'fl)) (define log1pmd-vals '((0.0 . 0.0) (0.5 . 1.0986122886681098) (-0.5 . -1.0986122886681098))) @@ -27,14 +25,13 @@ ; fast sine - (define-operator-impl (sin fast-sin.f64 binary64) + (define-operator-impl (fast-sin.f64 [x : binary64]) binary64 - [spec (lambda (x) (sin x))] - [fpcore (! :precision binary64 :math-library fast (sin x))] - [fl - (lambda (x) - (parameterize ([bf-precision 12]) - (bigfloat->flonum (bfsin (bf x)))))]) + #:spec (sin x) + #:fpcore (! :precision binary64 :math-library fast (sin x)) + #:fl (lambda (x) + (parameterize ([bf-precision 12]) + (bigfloat->flonum (bfsin (bf x)))))) (define sin-proc (impl-info 'fast-sin.f64 'fl)) (define sin-vals '((0.0 . 0.0) (1.0 . 0.841552734375) (-1.0 . -0.841552734375))) From 411f4a2dcdb44fac3f64c43072590c57f719fa5d Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Tue, 13 Aug 2024 16:32:47 -0700 Subject: [PATCH 27/64] fix bugs --- src/api/demo.rkt | 2 +- src/platforms/fallback.rkt | 5 ++--- src/syntax/syntax.rkt | 7 ++++++- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index f590025d2..e4ef2edb6 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -426,7 +426,7 @@ (eprintf "Explanations job started on ~a...\n" formula-str) (define test (parse-test formula)) - (define expr (prog->fpcore (test-input test))) + (define expr (prog->fpcore (test-input test) (test-context test))) (define pcontext (json->pcontext sample (test-context test))) (define command (create-job 'explanations diff --git a/src/platforms/fallback.rkt b/src/platforms/fallback.rkt index 8456e0ff8..10a768e29 100644 --- a/src/platforms/fallback.rkt +++ b/src/platforms/fallback.rkt @@ -4,7 +4,6 @@ (require math/base math/bigfloat - math/flonum math/special-functions) (require "runtime/utils.rkt") @@ -37,8 +36,8 @@ (define-syntax-rule (define-2ary-fallback-operator op fn) (define-fallback-operator (op [x : binary64] [y : binary64]) - #:spec (op x) - #:fpcore (! :precision binary64 :math-library racket (op x)) + #:spec (op x y) + #:fpcore (! :precision binary64 :math-library racket (op x y)) #:fl fn)) (define-syntax-rule (define-1ary-fallback-operators [op fn] ...) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index a976fe3c2..5f63e6fa4 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -307,8 +307,13 @@ ift-ty] [`(,op ,args ...) (unless (operator-exists? op) - (bad! "expected operator at `~a`, got `~a` in `~a`" expr op)) + (bad! "at `~a`, `~a` not an operator" expr op)) (define itypes (operator-info op 'itype)) + (unless (= (length itypes) (length args)) + (bad! "arity mismatch at `~a`: expected `~a`, got `~a`" + expr + (length itypes) + (length args))) (for ([arg (in-list args)] [itype (in-list itypes)]) (define arg-ty (type-of arg)) From bae1e3c6b7e1e14b89551d3455cd7a4f4d0ebfa5 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Tue, 13 Aug 2024 16:35:01 -0700 Subject: [PATCH 28/64] remove unused --- src/api/demo.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index e4ef2edb6..cd6b6a798 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -426,7 +426,6 @@ (eprintf "Explanations job started on ~a...\n" formula-str) (define test (parse-test formula)) - (define expr (prog->fpcore (test-input test) (test-context test))) (define pcontext (json->pcontext sample (test-context test))) (define command (create-job 'explanations From a06bab59e051cd0735a7bec13d69ac30b441f9d0 Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Fri, 23 Aug 2024 10:57:06 -0600 Subject: [PATCH 29/64] Convert lookup-id from a hash table to a u32vector --- src/core/egg-herbie.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/core/egg-herbie.rkt b/src/core/egg-herbie.rkt index 221d6f3ce..adf084887 100644 --- a/src/core/egg-herbie.rkt +++ b/src/core/egg-herbie.rkt @@ -591,10 +591,13 @@ ;; Nodes are duplicated across their possible types. (define (split-untyped-eclasses egraph-data egg->herbie) (define eclass-ids (egraph-eclasses egraph-data)) - (define egg-id->idx (make-hash)) + (define max-id + (for/fold ([current-max 0]) ([egg-id (in-u32vector eclass-ids)]) + (max current-max egg-id))) + (define egg-id->idx (make-u32vector max-id)) (for ([egg-id (in-u32vector eclass-ids)] [idx (in-naturals)]) - (hash-set! egg-id->idx egg-id idx)) + (u32vector-set! egg-id->idx egg-id idx)) (define types (all-reprs/types)) (define type->idx (make-hasheq)) @@ -609,7 +612,7 @@ ; maps (untyped eclass id, type) to typed eclass id (define (lookup-id eid type) - (idx+type->id (hash-ref egg-id->idx eid) type)) + (idx+type->id (u32vector-ref egg-id->idx eid) type)) ; allocate enough eclasses for every (egg-id, type) combination (define n (* (u32vector-length eclass-ids) num-types)) From 70addcb6234974dfaa3f0406e033da56bbb2844a Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Fri, 23 Aug 2024 11:01:47 -0600 Subject: [PATCH 30/64] Fix up other uses of egg-id->idx --- src/core/egg-herbie.rkt | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/core/egg-herbie.rkt b/src/core/egg-herbie.rkt index adf084887..12b376706 100644 --- a/src/core/egg-herbie.rkt +++ b/src/core/egg-herbie.rkt @@ -594,7 +594,7 @@ (define max-id (for/fold ([current-max 0]) ([egg-id (in-u32vector eclass-ids)]) (max current-max egg-id))) - (define egg-id->idx (make-u32vector max-id)) + (define egg-id->idx (make-u32vector (+ max-id 1))) (for ([egg-id (in-u32vector eclass-ids)] [idx (in-naturals)]) (u32vector-set! egg-id->idx egg-id idx)) @@ -649,7 +649,7 @@ ; dedup `id->parents` values (for ([id (in-range n)]) (vector-set! id->parents id (list->vector (remove-duplicates (vector-ref id->parents id))))) - (values id->eclass id->parents id->leaf? egg-id->idx type->idx)) + (values id->eclass id->parents id->leaf? eclass-ids egg-id->idx type->idx)) ;; TODO: reachable from roots? ;; Prunes e-nodes that are not well-typed. @@ -706,7 +706,7 @@ [_ (void)])))) ;; Rebuilds eclasses and associated data after pruning. -(define (rebuild-eclasses id->eclass egg-id->idx type->idx) +(define (rebuild-eclasses id->eclass eclass-ids egg-id->idx type->idx) (define n (vector-length id->eclass)) (define remap (make-vector n #f)) @@ -746,7 +746,8 @@ ; build the canonical id map (define egg-id->id (make-hash)) - (for ([(eid idx) (in-hash egg-id->idx)]) + (for ([eid (in-u32vector eclass-ids)]) + (define idx (u32vector-ref egg-id->idx eid)) (define id0 (* idx num-types)) (for ([id (in-range id0 (+ id0 num-types))]) (define id* (vector-ref remap id)) @@ -760,7 +761,7 @@ ;; keeping only the subset of enodes that are well-typed. (define (make-typed-eclasses egraph-data egg->herbie) ;; Step 1: split Rust-eclasses by type - (define-values (id->eclass id->parents id->leaf? egg-id->idx type->idx) + (define-values (id->eclass id->parents id->leaf? eclass-ids egg-id->idx type->idx) (split-untyped-eclasses egraph-data egg->herbie)) ;; Step 2: keep well-typed e-nodes @@ -770,7 +771,7 @@ ;; Step 3: remap e-classes ;; Any empty e-classes must be removed, so we re-map every id - (rebuild-eclasses id->eclass egg-id->idx type->idx)) + (rebuild-eclasses id->eclass eclass-ids egg-id->idx type->idx)) ;; Analyzes eclasses for their properties. ;; The result are vector-maps from e-class ids to data. From b430ec36a44edf0c4e6c9b1514bb70dceac95e8e Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Fri, 23 Aug 2024 17:27:16 -0600 Subject: [PATCH 31/64] Hacky fix for miss using `parse-test`. --- src/api/sandbox.rkt | 4 ++-- src/api/server.rkt | 22 ++++++++++++++++------ src/reports/make-graph.rkt | 5 ++--- 3 files changed, 20 insertions(+), 11 deletions(-) diff --git a/src/api/sandbox.rkt b/src/api/sandbox.rkt index 6027fff74..1ce5ecceb 100644 --- a/src/api/sandbox.rkt +++ b/src/api/sandbox.rkt @@ -435,8 +435,7 @@ [target target-cost-score] [result-est end-est-score] [result end-score] - [output - (test-input (parse-test (read-syntax 'web (open-input-string (car end-exprs)))))] + [output (car end-exprs)] [cost-accuracy cost&accuracy])] ['failure (match-define (list 'exn type _ ...) backend) @@ -507,6 +506,7 @@ [(< end-score (+ start-test-score fuzz)) "apx-start"] [else "uni-start"]))) + (eprintf "Sendable: ~a\n" (place-message-allowed? end-exprs)) (struct-copy table-row (dummy-table-row result status link) [start-est start-train-score] diff --git a/src/api/server.rkt b/src/api/server.rkt index 78babd0f8..bf01c9fe5 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -5,7 +5,6 @@ json) (require "sandbox.rkt" - "../core/preprocess.rkt" "../core/points.rkt" "../reports/history.rkt" "../reports/plot.rkt" @@ -14,6 +13,7 @@ "../syntax/read.rkt" "../syntax/sugar.rkt" "../syntax/load-plugin.rkt" + "../syntax/platform.rkt" "../utils/alternative.rkt" "../utils/common.rkt" "../utils/errors.rkt" @@ -410,14 +410,24 @@ (improve-result-bogosity backend))) (define (end-hash end repr pcontexts test) + + ; analysis of output expressions + (define expr-cost (platform-cost-proc (*active-platform*))) + (define-values (end-exprs-c end-train-scores-c end-test-scores-c end-costs-c) + (for/lists (l1 l2 l3 l4) + ([result end]) + (match-define (alt-analysis alt train-errors test-errors) result) + (values (alt-expr alt) + (errors-score train-errors) + (errors-score test-errors) + (expr-cost (alt-expr alt) repr)))) + (define-values (end-alts train-errors end-errors end-costs) (for/lists (l1 l2 l3 l4) ([analysis end]) (match-define (alt-analysis alt train-errors test-errs) analysis) (values alt train-errors test-errs (alt-cost alt repr)))) - (define fpcores - (for/list ([altn end-alts]) - (~a (program->fpcore (alt-expr altn) (test-context test))))) + (define alts-histories (for/list ([alt end-alts]) (render-history alt (first pcontexts) (second pcontexts) (test-context test)))) @@ -431,8 +441,8 @@ (real->ordinal (repr->real val repr) repr)) '()))) - (hasheq 'end-alts - fpcores + (hasheq 'end-alts ; wrong + end-exprs-c 'end-histories alts-histories 'end-train-scores diff --git a/src/reports/make-graph.rkt b/src/reports/make-graph.rkt index 1756472d8..5733b11b5 100644 --- a/src/reports/make-graph.rkt +++ b/src/reports/make-graph.rkt @@ -174,10 +174,9 @@ [errs end-errors] [cost end-costs] [history (hash-ref end 'end-histories)]) - (define formula (read-syntax 'web (open-input-string alt-fpcore))) - (define expr (parse-test formula)) + (define-values (dropdown body) - (render-program (test-input expr) ctx #:ident identifier #:instructions preprocessing)) + (render-program alt-fpcore ctx #:ident identifier #:instructions preprocessing)) `(section ([id ,(format "alternative~a" i)] (class "programs")) (h2 "Alternative " ,(~a i) From b647b383a724778793a013f8a614bb56a8a4a370 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Fri, 23 Aug 2024 17:34:28 -0600 Subject: [PATCH 32/64] Fix fmt. --- infra/convert-demo.rkt | 5 ++++- src/reports/plot.rkt | 4 +++- src/syntax/types.rkt | 3 ++- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/infra/convert-demo.rkt b/infra/convert-demo.rkt index f25e2a3e2..123fa02e7 100644 --- a/infra/convert-demo.rkt +++ b/infra/convert-demo.rkt @@ -34,7 +34,10 @@ (define exprs-unfiltered (for/list ([test tests]) (read-expr (hash-ref test 'input) is-version-10))) - (define exprs (for/set ([expr exprs-unfiltered] #:when (not (set-member? existing-set expr))) expr)) + (define exprs + (for/set ([expr exprs-unfiltered] + #:when (not (set-member? existing-set expr))) + expr)) (for ([expr (in-set exprs)]) (fprintf output-file "~a\n" (make-fpcore expr))) exprs) diff --git a/src/reports/plot.rkt b/src/reports/plot.rkt index 0b1b691bf..928b809e9 100644 --- a/src/reports/plot.rkt +++ b/src/reports/plot.rkt @@ -20,7 +20,9 @@ splitpoints->json) (define (all-same? pts idx) - (= 1 (set-count (for/set ([pt pts]) (list-ref pt idx))))) + (= 1 + (set-count (for/set ([pt pts]) + (list-ref pt idx))))) (define (ulps->bits-tenths x) (string->number (real->decimal-string (ulps->bits x) 1))) diff --git a/src/syntax/types.rkt b/src/syntax/types.rkt index 52618fb86..0565ecc98 100644 --- a/src/syntax/types.rkt +++ b/src/syntax/types.rkt @@ -26,7 +26,8 @@ (define (type-name? x) (hash-has-key? type-dict x)) -(define-syntax-rule (define-type name _ ...) (hash-set! type-dict 'name #t)) +(define-syntax-rule (define-type name _ ...) + (hash-set! type-dict 'name #t)) (define-type real) (define-type bool) From 3de5da68f0c4a4510609f85f5c73df40ce665622 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Fri, 23 Aug 2024 17:47:39 -0600 Subject: [PATCH 33/64] Minimize changes. --- src/api/sandbox.rkt | 2 +- src/api/server.rkt | 16 ++-------------- src/reports/make-graph.rkt | 2 +- 3 files changed, 4 insertions(+), 16 deletions(-) diff --git a/src/api/sandbox.rkt b/src/api/sandbox.rkt index 1ce5ecceb..1607e4924 100644 --- a/src/api/sandbox.rkt +++ b/src/api/sandbox.rkt @@ -398,7 +398,7 @@ (define best-score (if (null? target-cost-score) target-cost-score (apply min (map second target-cost-score)))) - (define end-exprs (hash-ref end 'end-alts)) + (define end-exprs (hash-ref end 'end-exprs)) (define end-train-scores (map errors-score (hash-ref end 'end-train-scores))) (define end-test-scores (map errors-score (hash-ref end 'end-errors))) (define end-costs (hash-ref end 'end-costs)) diff --git a/src/api/server.rkt b/src/api/server.rkt index bf01c9fe5..29ee13c26 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -13,7 +13,6 @@ "../syntax/read.rkt" "../syntax/sugar.rkt" "../syntax/load-plugin.rkt" - "../syntax/platform.rkt" "../utils/alternative.rkt" "../utils/common.rkt" "../utils/errors.rkt" @@ -411,17 +410,6 @@ (define (end-hash end repr pcontexts test) - ; analysis of output expressions - (define expr-cost (platform-cost-proc (*active-platform*))) - (define-values (end-exprs-c end-train-scores-c end-test-scores-c end-costs-c) - (for/lists (l1 l2 l3 l4) - ([result end]) - (match-define (alt-analysis alt train-errors test-errors) result) - (values (alt-expr alt) - (errors-score train-errors) - (errors-score test-errors) - (expr-cost (alt-expr alt) repr)))) - (define-values (end-alts train-errors end-errors end-costs) (for/lists (l1 l2 l3 l4) ([analysis end]) @@ -441,8 +429,8 @@ (real->ordinal (repr->real val repr) repr)) '()))) - (hasheq 'end-alts ; wrong - end-exprs-c + (hasheq 'end-exprs + (map alt-expr end-alts) 'end-histories alts-histories 'end-train-scores diff --git a/src/reports/make-graph.rkt b/src/reports/make-graph.rkt index 5733b11b5..a5c5dd809 100644 --- a/src/reports/make-graph.rkt +++ b/src/reports/make-graph.rkt @@ -77,7 +77,7 @@ (for/list ([target targets]) (alt-cost (alt-analysis-alt target) repr))) - (define end-alts (hash-ref end 'end-alts)) + (define end-alts (hash-ref end 'end-exprs)) (define end-errors (hash-ref end 'end-errors)) (define end-costs (hash-ref end 'end-costs)) From 730929131bc714a11b1138cbb406f9feb37cd5fc Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Fri, 23 Aug 2024 17:53:24 -0600 Subject: [PATCH 34/64] Fix variable names and eprintf clean up. --- src/api/sandbox.rkt | 1 - src/reports/make-graph.rkt | 13 ++++++------- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/src/api/sandbox.rkt b/src/api/sandbox.rkt index 1607e4924..b946c0bd3 100644 --- a/src/api/sandbox.rkt +++ b/src/api/sandbox.rkt @@ -506,7 +506,6 @@ [(< end-score (+ start-test-score fuzz)) "apx-start"] [else "uni-start"]))) - (eprintf "Sendable: ~a\n" (place-message-allowed? end-exprs)) (struct-copy table-row (dummy-table-row result status link) [start-est start-train-score] diff --git a/src/reports/make-graph.rkt b/src/reports/make-graph.rkt index a5c5dd809..3dcf1f373 100644 --- a/src/reports/make-graph.rkt +++ b/src/reports/make-graph.rkt @@ -77,13 +77,12 @@ (for/list ([target targets]) (alt-cost (alt-analysis-alt target) repr))) - (define end-alts (hash-ref end 'end-exprs)) + (define end-exprs (hash-ref end 'end-exprs)) (define end-errors (hash-ref end 'end-errors)) (define end-costs (hash-ref end 'end-costs)) (define speedup - (let ([better (for/list ([alt end-alts] - [err end-errors] + (let ([better (for/list ([err end-errors] [cost end-costs] #:when (<= (errors-score err) (errors-score start-error))) (/ start-cost cost))]) @@ -117,7 +116,7 @@ (format-accuracy (apply max (map ulps->bits start-error)) repr-bits #:unit "%") (format-accuracy (apply max (map ulps->bits end-error)) repr-bits #:unit "%"))) ,(render-large "Time" (format-time time)) - ,(render-large "Alternatives" (~a (length end-alts))) + ,(render-large "Alternatives" (~a (length end-exprs))) ,(if (*pareto-mode*) (render-large "Speedup" (if speedup (~r speedup #:precision '(= 1)) "N/A") @@ -148,7 +147,7 @@ "?")) (div ((class "figure-row")) (svg) - (div (p "Herbie found " ,(~a (length end-alts)) " alternatives:") + (div (p "Herbie found " ,(~a (length end-exprs)) " alternatives:") (table (thead (tr (th "Alternative") (th ((class "numeric")) "Accuracy") (th ((class "numeric")) "Speedup"))) @@ -170,13 +169,13 @@ ,(render-help "report.html#alternatives")) ,body)) ,@(for/list ([i (in-naturals 1)] - [alt-fpcore end-alts] + [expr end-exprs] [errs end-errors] [cost end-costs] [history (hash-ref end 'end-histories)]) (define-values (dropdown body) - (render-program alt-fpcore ctx #:ident identifier #:instructions preprocessing)) + (render-program expr ctx #:ident identifier #:instructions preprocessing)) `(section ([id ,(format "alternative~a" i)] (class "programs")) (h2 "Alternative " ,(~a i) From 10485f430729a8898d3ffd0b2a2b31da4bc5454a Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 10:29:26 -0700 Subject: [PATCH 35/64] fix bad merge --- src/api/sandbox.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/api/sandbox.rkt b/src/api/sandbox.rkt index 6f138746d..9eab291f6 100644 --- a/src/api/sandbox.rkt +++ b/src/api/sandbox.rkt @@ -348,15 +348,15 @@ (table-row (test-name test) (test-identifier test) status - (prog->fpcore (test-pre test)) + (prog->fpcore (test-pre test) (test-context test)) preprocess (representation-name repr) '() ; TODO: eliminate field (test-vars test) (map car (hash-ref result-hash 'warnings)) - (prog->fpcore (test-input test)) + (prog->fpcore (test-input test) (test-context test)) #f - (prog->fpcore (test-spec test)) + (prog->fpcore (test-spec test) (test-context test)) (test-output test) #f #f From 777ede7e1d06a23d9bf179e3a5bb0d8aa01174c0 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 10:40:26 -0700 Subject: [PATCH 36/64] guard against missing impl --- src/core/mainloop.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/core/mainloop.rkt b/src/core/mainloop.rkt index c8850f2ec..dda971923 100644 --- a/src/core/mainloop.rkt +++ b/src/core/mainloop.rkt @@ -10,6 +10,7 @@ "regimes.rkt" "simplify.rkt" "../utils/alternative.rkt" + "../utils/errors.rkt" "../utils/common.rkt" "explain.rkt" "patch.rkt" @@ -353,7 +354,9 @@ [(and (flag-set? 'reduce 'regimes) (> (length alts) 1) (equal? (representation-type repr) 'real) - (not (null? (context-vars ctx)))) + (not (null? (context-vars ctx))) + (with-handlers ([exn:fail:user:herbie:missing? (const #f)]) + (get-fpcore-impl '<= '() (list repr repr)))) (define opts (pareto-regimes (sort alts < #:key (curryr alt-cost repr)) ctx)) (for/list ([opt (in-list opts)]) (combine-alts opt ctx))] From 8ec0e3a1996f9230ef6c18abc41fa84769855919 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 11:21:58 -0700 Subject: [PATCH 37/64] better frac pow detection --- src/config.rkt | 2 +- src/core/egg-herbie.rkt | 24 +++++++++++++++++++----- src/platforms/runtime/libm.rkt | 25 ++++++++++++++++--------- src/syntax/syntax.rkt | 1 + 4 files changed, 37 insertions(+), 15 deletions(-) diff --git a/src/config.rkt b/src/config.rkt index 046fb0d4a..5e007ebb6 100644 --- a/src/config.rkt +++ b/src/config.rkt @@ -138,7 +138,7 @@ (define *platform-name* (make-parameter 'default)) ;; True iff using the old cost function -(define *egraph-platform-cost* (make-parameter #t)) +(define *egraph-platform-cost* (make-parameter #f)) ;; Plugins loaded locally rather than through Racket. (define *loose-plugins* (make-parameter '())) diff --git a/src/core/egg-herbie.rkt b/src/core/egg-herbie.rkt index 71119308f..420664758 100644 --- a/src/core/egg-herbie.rkt +++ b/src/core/egg-herbie.rkt @@ -11,6 +11,7 @@ (require "programs.rkt" "rules.rkt" + "../syntax/matcher.rkt" "../syntax/platform.rkt" "../syntax/syntax.rkt" "../syntax/types.rkt" @@ -996,6 +997,19 @@ (define (fraction-with-odd-denominator? frac) (and (rational? frac) (let ([denom (denominator frac)]) (and (> denom 1) (odd? denom))))) +;; Decompose an e-node representing an impl of `(pow b e)`. +;; Returns either `#f` or the `(cons b e)` +(define (pow-impl-args impl args) + (define vars (impl-info impl 'vars)) + (match (impl-info impl 'spec) + [(list 'pow b e) + #:when (set-member? vars e) + (define env (map cons vars args)) + (define b* (dict-ref env b b)) + (define e* (dict-ref env e e)) + (cons b* e*)] + [_ #f])) + ;; Old cost model version (define (default-egg-cost-proc regraph cache node type rec) (match node @@ -1005,11 +1019,11 @@ [(list '$approx _ impl) (rec impl)] [(list 'if cond ift iff) (+ 1 (rec cond) (rec ift) (rec iff))] [(list (? impl-exists? impl) args ...) - (match (impl-info impl 'spec) - [(list 'pow _ _) - (match-define (list b e) args) - (define n (vector-ref (regraph-constants regraph) e)) - (if (fraction-with-odd-denominator? n) +inf.0 (+ 1 (rec b) (rec e)))] + (match (pow-impl-args impl args) + [(cons _ e) + #:when (let ([n (vector-ref (regraph-constants regraph) e)]) + (fraction-with-odd-denominator? n)) + +inf.0] [_ (apply + 1 (map rec args))])] [(list 'pow b e) (define n (vector-ref (regraph-constants regraph) e)) diff --git a/src/platforms/runtime/libm.rkt b/src/platforms/runtime/libm.rkt index e123d5e89..bbaf216f5 100644 --- a/src/platforms/runtime/libm.rkt +++ b/src/platforms/runtime/libm.rkt @@ -52,15 +52,22 @@ [_ (oops! "unknown type" repr)])) (syntax-case stx () [(_ cname (op name itype ...) otype fields ...) - (begin - (unless (identifier? #'cname) - (oops! "expected identifier" #'cname)) - (unless (identifier? #'op) - (oops! "expected identifier" #'op)) - (unless (identifier? #'name) - (oops! "expected identifier" #'name)) - (with-syntax ([(var ...) (generate-temporaries #'(itype ...))] - [(citype ...) (map repr->type (syntax->list #'(itype ...)))] + (let ([op #'op] + [name #'name] + [cname #'cname] + [itypes (syntax->list #'(itype ...))]) + (unless (identifier? op) + (oops! "expected identifier" op)) + (unless (identifier? name) + (oops! "expected identifier" name)) + (unless (identifier? cname) + (oops! "expected identifier" cname)) + (with-syntax ([op op] + [name name] + [cname cname] + [(var ...) (build-list (length itypes) (lambda (i) (string->symbol (format "x~a" i))))] + [(itype ...) itypes] + [(citype ...) (map repr->type itypes)] [cotype (repr->type #'otype)]) #'(begin (define-libm proc (cname citype ... cotype)) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 5f63e6fa4..b3dd81ff4 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -398,6 +398,7 @@ [spec spec] [core core] [fl-expr fl-expr]) + (eprintf "~a\n" #'(var ...)) #'(register-operator-impl! 'id (context '(var ...) (get-representation 'rtype) From 8f05291f65f51de3a496f92848bfb5beb261e6a9 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 11:28:23 -0700 Subject: [PATCH 38/64] fix cast check --- src/syntax/syntax.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index b3dd81ff4..3c58b7d31 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -483,8 +483,10 @@ (define (cast-impl? x) (and (symbol? x) (impl-exists? x) - (match (impl-info x 'spec) - [(list 'cast _) #t] + (match (impl-info x 'vars) + [(list v) + #:when (eq? (impl-info x 'spec) v) + #t] [_ #f]))) (define (get-cast-impl irepr orepr #:impls [impls (all-active-operator-impls)]) From 4e7ccd99dbfd6d1e688caf3c8ee5b77c96e7664d Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 13:03:09 -0700 Subject: [PATCH 39/64] fix --- src/api/server.rkt | 2 +- src/platforms/runtime/libm.rkt | 3 ++- src/syntax/syntax.rkt | 5 ++++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/api/server.rkt b/src/api/server.rkt index 29ee13c26..becbeb7e5 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -285,7 +285,7 @@ (make-path job-id))) (define (make-local-error-result herbie-result test job-id) - (define expr (prog->fpcore (test-input test))) + (define expr (prog->fpcore (test-input test) (test-context test))) (define local-error (job-result-backend herbie-result)) ;; TODO: potentially unsafe if resugaring changes the AST (define tree diff --git a/src/platforms/runtime/libm.rkt b/src/platforms/runtime/libm.rkt index bbaf216f5..50e5d79f3 100644 --- a/src/platforms/runtime/libm.rkt +++ b/src/platforms/runtime/libm.rkt @@ -65,7 +65,8 @@ (with-syntax ([op op] [name name] [cname cname] - [(var ...) (build-list (length itypes) (lambda (i) (string->symbol (format "x~a" i))))] + [(var ...) (build-list (length itypes) + (lambda (i) (string->symbol (format "x~a" i))))] [(itype ...) itypes] [(citype ...) (map repr->type itypes)] [cotype (repr->type #'otype)]) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 3c58b7d31..6dd610260 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -398,7 +398,6 @@ [spec spec] [core core] [fl-expr fl-expr]) - (eprintf "~a\n" #'(var ...)) #'(register-operator-impl! 'id (context '(var ...) (get-representation 'rtype) @@ -427,6 +426,10 @@ (set! fl-expr #'expr) (loop #'(rest ...))])] [(#:fl) (oops! "expected value after keyword `#:fl`" stx)] + ; deprecated + [(#:operator _ rest ...) (loop #'(rest ...))] + [(#:operator) (oops! "expected value after keyword `#:operator`" stx)] + ; bad [_ (oops! "bad syntax" fields)])))] [_ (oops! "bad syntax")])) From fbe34dd1b285f7a65740a65a0562487132e36f67 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 13:14:21 -0700 Subject: [PATCH 40/64] oops --- src/syntax/syntax.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 6dd610260..c1fee0ffd 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -427,8 +427,8 @@ (loop #'(rest ...))])] [(#:fl) (oops! "expected value after keyword `#:fl`" stx)] ; deprecated - [(#:operator _ rest ...) (loop #'(rest ...))] - [(#:operator) (oops! "expected value after keyword `#:operator`" stx)] + [(#:op _ rest ...) (loop #'(rest ...))] + [(#:op) (oops! "expected value after keyword `#:operator`" stx)] ; bad [_ (oops! "bad syntax" fields)])))] [_ (oops! "bad syntax")])) From ca84d096409d77a15027c75bd31e110cb3741469 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 13:27:58 -0700 Subject: [PATCH 41/64] comment on batches --- src/syntax/sugar.rkt | 6 ++++++ src/syntax/syntax.rkt | 3 --- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/syntax/sugar.rkt b/src/syntax/sugar.rkt index 0ce7add30..b002c48ef 100644 --- a/src/syntax/sugar.rkt +++ b/src/syntax/sugar.rkt @@ -189,6 +189,12 @@ ;; LImpl -> FPCore ;; Translates from LImpl to an FPCore +;; TODO: this process uses a batch-like data structure +;; but _without_ deduplication since different use sites +;; of a particular subexpression may have different +;; parent rounding contexts. Would be nice to explore +;; if the batch data structure can be used. + ;; Instruction vector index (struct index (v) #:prefab) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index c1fee0ffd..aa347bf95 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -426,9 +426,6 @@ (set! fl-expr #'expr) (loop #'(rest ...))])] [(#:fl) (oops! "expected value after keyword `#:fl`" stx)] - ; deprecated - [(#:op _ rest ...) (loop #'(rest ...))] - [(#:op) (oops! "expected value after keyword `#:operator`" stx)] ; bad [_ (oops! "bad syntax" fields)])))] [_ (oops! "bad syntax")])) From 2d446b3a85dd72886a44397bee37ea45381eab03 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 13:46:34 -0700 Subject: [PATCH 42/64] add fpcore check --- src/syntax/syntax.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index aa347bf95..1ee7e434d 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -342,9 +342,11 @@ (cond [fpcore ; provided -> TODO: check free variables, props (match fpcore - [`(! ,props ... (,operator ,args ...)) (void)] + [`(! ,props ... (,operator ,args ...)) + (unless (even? (length props)) + (error 'register-operator-impl! "umatched property for ~a: ~a" name fpcore))] [`(,operator ,args ...) (void)] - [_ (raise-herbie-syntax-error "Invalid fpcore for ~a: ~a" name fpcore)]) + [_ (error 'register-operator-impl! "Invalid fpcore for ~a: ~a" name fpcore)]) fpcore] [else ; not provided => need to generate it (define repr (context-repr ctx)) From 0328f68d438e0e0abed2c30853dfb03a10b5a471 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 15:22:39 -0700 Subject: [PATCH 43/64] switch to eq based tables --- src/core/alt-table.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/core/alt-table.rkt b/src/core/alt-table.rkt index 49f96b471..b75192917 100644 --- a/src/core/alt-table.rkt +++ b/src/core/alt-table.rkt @@ -37,14 +37,14 @@ (define (make-alt-table pcontext initial-alt ctx) (define cost (alt-cost* initial-alt (context-repr ctx))) - (alt-table (make-immutable-hash (for/list ([(pt ex) (in-pcontext pcontext)] + (alt-table (make-immutable-hasheq (for/list ([(pt ex) (in-pcontext pcontext)] [err (errors (alt-expr initial-alt) pcontext ctx)]) (cons pt (list (pareto-point cost err (list initial-alt)))))) - (hash initial-alt + (hasheq initial-alt (for/list ([(pt ex) (in-pcontext pcontext)]) pt)) - (hash initial-alt #f) - (hash initial-alt cost) + (hasheq initial-alt #f) + (hasheq initial-alt cost) pcontext (list initial-alt))) @@ -192,7 +192,7 @@ [ppt (in-list curve)] [alt (in-list (pareto-point-data ppt))]) (hash-set! alt->points* alt (cons pt (hash-ref alt->points* alt '())))) - (make-immutable-hash (hash->list alt->points*))) + (make-immutable-hasheq (hash->list alt->points*))) (define (atab-add-altn atab altn errs cost) (match-define (alt-table point->alts alt->points alt->done? alt->cost pcontext all-alts) atab) From 340dded195d6b685412fc53b0fc90e686ba3ca41 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 15:59:01 -0700 Subject: [PATCH 44/64] revert one table back --- src/core/alt-table.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/alt-table.rkt b/src/core/alt-table.rkt index b75192917..2a54a42e8 100644 --- a/src/core/alt-table.rkt +++ b/src/core/alt-table.rkt @@ -37,7 +37,7 @@ (define (make-alt-table pcontext initial-alt ctx) (define cost (alt-cost* initial-alt (context-repr ctx))) - (alt-table (make-immutable-hasheq (for/list ([(pt ex) (in-pcontext pcontext)] + (alt-table (make-immutable-hash (for/list ([(pt ex) (in-pcontext pcontext)] [err (errors (alt-expr initial-alt) pcontext ctx)]) (cons pt (list (pareto-point cost err (list initial-alt)))))) (hasheq initial-alt From cfb60db3a75688ee590559745aefceb7a29fb4dd Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Mon, 26 Aug 2024 15:59:11 -0700 Subject: [PATCH 45/64] raco fmt --- src/core/alt-table.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/alt-table.rkt b/src/core/alt-table.rkt index 2a54a42e8..1384a5d86 100644 --- a/src/core/alt-table.rkt +++ b/src/core/alt-table.rkt @@ -41,8 +41,8 @@ [err (errors (alt-expr initial-alt) pcontext ctx)]) (cons pt (list (pareto-point cost err (list initial-alt)))))) (hasheq initial-alt - (for/list ([(pt ex) (in-pcontext pcontext)]) - pt)) + (for/list ([(pt ex) (in-pcontext pcontext)]) + pt)) (hasheq initial-alt #f) (hasheq initial-alt cost) pcontext From 98085b2197cbd3227c2cd188f3a56bf725a28766 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Tue, 13 Aug 2024 15:45:13 -0600 Subject: [PATCH 46/64] Give worker a thread to monitor. --- src/api/server.rkt | 77 ++++++++++++++++++++++++++++++++++++---------- 1 file changed, 60 insertions(+), 17 deletions(-) diff --git a/src/api/server.rkt b/src/api/server.rkt index 29ee13c26..01b017bfd 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -16,7 +16,8 @@ "../utils/alternative.rkt" "../utils/common.rkt" "../utils/errors.rkt" - "../utils/float.rkt") + "../utils/float.rkt" + (submod "../utils/timeline.rkt" debug)) (provide make-path get-improve-table-data @@ -252,26 +253,68 @@ *loose-plugins*) (parameterize ([current-error-port (open-output-nowhere)]) ; hide output (load-herbie-plugins)) + (define worker-thread + (thread (λ () + (let loop ([seed #f]) + (match (thread-receive) + [`(init rand + ,vec + flags + ,flag-table + num-iters + ,iterations + points + ,points + timeout + ,timeout + output-dir + ,output + reeval + ,reeval + demo? + ,demo?) + (set! seed vec) + (*flags* flag-table) + (*num-iterations* iterations) + (*num-points* points) + (*timeout* timeout) + (*demo-output* output) + (*reeval-pts* reeval) + (*demo?* demo?)] + [job-info (run-job job-info)]) + (loop seed))))) + (define timeline (*timeline*)) (for ([_ (in-naturals)]) (match (place-channel-get ch) [(list 'apply manager command job-id) + (set! timeline (*timeline*)) (log "[~a] working on [~a].\n" job-id (test-name (herbie-command-test command))) - (define herbie-result (wrapper-run-herbie command job-id)) - (match-define (job-result kind test status time _ _ backend) herbie-result) - (define out-result - (match kind - ['alternatives (make-alternatives-result herbie-result test job-id)] - ['evaluate (make-calculate-result herbie-result job-id)] - ['cost (make-cost-result herbie-result job-id)] - ['errors (make-error-result herbie-result job-id)] - ['exacts (make-exacts-result herbie-result job-id)] - ['improve (make-improve-result herbie-result test job-id)] - ['local-error (make-local-error-result herbie-result test job-id)] - ['explanations (make-explanation-result herbie-result job-id)] - ['sample (make-sample-result herbie-result test job-id)] - [_ (error 'compute-result "unknown command ~a" kind)])) - (log "Job: ~a finished, returning work to manager\n" job-id) - (place-channel-put manager (list 'finished manager worker-id job-id out-result))])))) + (thread-send worker-thread (work manager worker-id job-id command))])))) + +(struct work (manager worker-id job-id job)) + +(define *demo-output* (make-parameter false)) +(define *demo?* (make-parameter false)) + +(define (run-job job-info) + (match-define (work manager worker-id job-id command) job-info) + (eprintf "run-job: ~a, ~a\n" worker-id job-id) + (define herbie-result (wrapper-run-herbie command job-id)) + (match-define (job-result kind test status time _ _ backend) herbie-result) + (define out-result + (match kind + ['alternatives (make-alternatives-result herbie-result test job-id)] + ['evaluate (make-calculate-result herbie-result job-id)] + ['cost (make-cost-result herbie-result job-id)] + ['errors (make-error-result herbie-result job-id)] + ['exacts (make-exacts-result herbie-result job-id)] + ['improve (make-improve-result herbie-result test job-id)] + ['local-error (make-local-error-result herbie-result test job-id)] + ['explanations (make-explanation-result herbie-result job-id)] + ['sample (make-sample-result herbie-result test job-id)] + [_ (error 'compute-result "unknown command ~a" kind)])) + (log "Job: ~a finished, returning work to manager\n" job-id) + (place-channel-put manager (list 'finished manager worker-id job-id out-result))) (define (make-explanation-result herbie-result job-id) (define explanations (job-result-backend herbie-result)) From 9723905d36e9ba180bf01548a3343c4329a6773f Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Tue, 13 Aug 2024 16:08:25 -0600 Subject: [PATCH 47/64] Basic outline roughed out. Now to find the timeline. --- src/api/server.rkt | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/src/api/server.rkt b/src/api/server.rkt index 01b017bfd..c4144899c 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -23,6 +23,7 @@ get-improve-table-data make-improve-result get-results-for + get-timeline-for job-count is-server-up create-job @@ -60,6 +61,12 @@ (log "Getting result for job: ~a.\n" job-id) (place-channel-get a)) +(define (get-timeline-for job-id) + (define-values (a b) (place-channel)) + (place-channel-put manager (list 'timeline job-id b)) + (log "Getting result for job: ~a.\n" job-id) + (place-channel-get a)) + (define (get-improve-table-data) (define-values (a b) (place-channel)) (place-channel-put manager (list 'improve b)) @@ -169,6 +176,7 @@ (define completed-work (make-hash)) (define busy-workers (make-hash)) (define waiting-workers (make-hash)) + (define current-jobs (make-hash)) (for ([i (in-range worker-count)]) (hash-set! waiting-workers i (make-worker i))) (log "~a workers ready.\n" (hash-count waiting-workers)) @@ -193,6 +201,7 @@ (log "Starting worker [~a] on [~a].\n" (work-item-id job) (test-name (herbie-command-test (work-item-command job)))) + (hash-set! current-jobs (work-item-id job) wid) (place-channel-put worker (list 'apply self (work-item-command job) (work-item-id job))) (hash-set! reassigned wid worker) (hash-set! busy-workers wid worker)) @@ -206,6 +215,7 @@ (hash-set! completed-work job-id result) ; move worker to waiting list + (hash-remove! current-jobs job-id) (hash-set! waiting-workers wid (hash-ref busy-workers wid)) (hash-remove! busy-workers wid) @@ -229,6 +239,17 @@ (hash-remove! waiting job-id)] ; Get the result for the given id, return false if no work found. [(list 'result job-id handler) (place-channel-put handler (hash-ref completed-work job-id #f))] + [(list 'timeline job-id handler) + (define wid (hash-ref current-jobs job-id #f)) + (when (not (false? wid)) + (log "Worker[~a] working on ~a.\n" wid job-id) + (define-values (a b) (place-channel)) + (place-channel-put (hash-ref busy-workers wid) (list 'timeline b)) + (define timeline (place-channel-get a)) + (place-channel-put handler timeline)) + (when (false? wid) + (log "WID = FALSE\n") + (place-channel-put handler (hash-ref completed-work job-id #f)))] ; Returns the current count of working workers. [(list 'count handler) (place-channel-put handler (hash-count busy-workers))] ; Retreive the improve results for results.json @@ -284,12 +305,18 @@ [job-info (run-job job-info)]) (loop seed))))) (define timeline (*timeline*)) + (define current-job-id #f) (for ([_ (in-naturals)]) (match (place-channel-get ch) [(list 'apply manager command job-id) (set! timeline (*timeline*)) + (set! current-job-id job-id) (log "[~a] working on [~a].\n" job-id (test-name (herbie-command-test command))) - (thread-send worker-thread (work manager worker-id job-id command))])))) + (thread-send worker-thread (work manager worker-id job-id command))] + [(list 'timeline handler) + (eprintf "[~a]TIMELINE: ~a\n" worker-id (unbox timeline)) + (eprintf "Timeline requested from worker[~a] for job ~a\n" worker-id current-job-id) + (place-channel-put handler timeline)])))) (struct work (manager worker-id job-id job)) From d563f3184d1e3b7ced7773dde25965deaedd39b2 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Tue, 13 Aug 2024 16:38:00 -0600 Subject: [PATCH 48/64] Actually call `get-timeline-for` --- src/api/demo.rkt | 4 +--- src/api/server.rkt | 11 +++++++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index d7f967b07..9024b1f1d 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -339,9 +339,7 @@ (url main))) (define (check-status req job-id) - (define r (get-results-for job-id)) - ;; TODO return the current status from the jobs timeline - (match r + (match (get-timeline-for job-id) [#f (response 202 #"Job in progress" diff --git a/src/api/server.rkt b/src/api/server.rkt index c4144899c..1d98513bb 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -17,6 +17,7 @@ "../utils/common.rkt" "../utils/errors.rkt" "../utils/float.rkt" + "../utils/timeline.rkt" (submod "../utils/timeline.rkt" debug)) (provide make-path @@ -32,7 +33,7 @@ start-job-server) ; verbose logging for debugging -(define verbose #f) ; Maybe change to log-level and use 'verbose? +(define verbose #t) ; Maybe change to log-level and use 'verbose? (define (log msg . args) (when verbose (apply eprintf msg args))) @@ -64,7 +65,7 @@ (define (get-timeline-for job-id) (define-values (a b) (place-channel)) (place-channel-put manager (list 'timeline job-id b)) - (log "Getting result for job: ~a.\n" job-id) + (log "Getting timeline for job: ~a.\n" job-id) (place-channel-get a)) (define (get-improve-table-data) @@ -245,8 +246,8 @@ (log "Worker[~a] working on ~a.\n" wid job-id) (define-values (a b) (place-channel)) (place-channel-put (hash-ref busy-workers wid) (list 'timeline b)) - (define timeline (place-channel-get a)) - (place-channel-put handler timeline)) + (define requested-timeline (place-channel-get a)) + (place-channel-put handler requested-timeline)) (when (false? wid) (log "WID = FALSE\n") (place-channel-put handler (hash-ref completed-work job-id #f)))] @@ -326,6 +327,8 @@ (define (run-job job-info) (match-define (work manager worker-id job-id command) job-info) (eprintf "run-job: ~a, ~a\n" worker-id job-id) + ; (timeline-event! 'start) + ; (eprintf "TIMELINE HERE: ~a\n" (unbox *timeline*)) (define herbie-result (wrapper-run-herbie command job-id)) (match-define (job-result kind test status time _ _ backend) herbie-result) (define out-result From 5c71d61d5373b5bed22c873fffdb7aeb7aa35dec Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Wed, 14 Aug 2024 13:02:23 -0600 Subject: [PATCH 49/64] Fix logging. --- src/api/server.rkt | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/api/server.rkt b/src/api/server.rkt index 1d98513bb..0dddecd18 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -33,7 +33,7 @@ start-job-server) ; verbose logging for debugging -(define verbose #t) ; Maybe change to log-level and use 'verbose? +(define verbose #f) ; Maybe change to log-level and use 'verbose? (define (log msg . args) (when verbose (apply eprintf msg args))) @@ -315,8 +315,7 @@ (log "[~a] working on [~a].\n" job-id (test-name (herbie-command-test command))) (thread-send worker-thread (work manager worker-id job-id command))] [(list 'timeline handler) - (eprintf "[~a]TIMELINE: ~a\n" worker-id (unbox timeline)) - (eprintf "Timeline requested from worker[~a] for job ~a\n" worker-id current-job-id) + (log "Timeline requested from worker[~a] for job ~a\n" worker-id current-job-id) (place-channel-put handler timeline)])))) (struct work (manager worker-id job-id job)) @@ -326,9 +325,7 @@ (define (run-job job-info) (match-define (work manager worker-id job-id command) job-info) - (eprintf "run-job: ~a, ~a\n" worker-id job-id) - ; (timeline-event! 'start) - ; (eprintf "TIMELINE HERE: ~a\n" (unbox *timeline*)) + (log "run-job: ~a, ~a\n" worker-id job-id) (define herbie-result (wrapper-run-herbie command job-id)) (match-define (job-result kind test status time _ _ backend) herbie-result) (define out-result From 573608b6a85f0368d3e777408c06c5121ea5b569 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Wed, 14 Aug 2024 13:21:38 -0600 Subject: [PATCH 50/64] Clean up for PR. --- src/api/demo.rkt | 7 ------- src/api/server.rkt | 4 ++-- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index 9024b1f1d..86bbdbf89 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -340,13 +340,6 @@ (define (check-status req job-id) (match (get-timeline-for job-id) - [#f - (response 202 - #"Job in progress" - (current-seconds) - #"text/plain" - (list (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count))))) - (λ (out) (display "Not done!" out)))] [(? box? timeline) (response 202 #"Job in progress" diff --git a/src/api/server.rkt b/src/api/server.rkt index 0dddecd18..bd7d68a3c 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -249,7 +249,7 @@ (define requested-timeline (place-channel-get a)) (place-channel-put handler requested-timeline)) (when (false? wid) - (log "WID = FALSE\n") + (log "Job complete, no timeline, send result.\n") (place-channel-put handler (hash-ref completed-work job-id #f)))] ; Returns the current count of working workers. [(list 'count handler) (place-channel-put handler (hash-count busy-workers))] @@ -319,7 +319,7 @@ (place-channel-put handler timeline)])))) (struct work (manager worker-id job-id job)) - +; Not sure if these are actually needed. (define *demo-output* (make-parameter false)) (define *demo?* (make-parameter false)) From f717ab76dbd0f11c87bc41d325e46bafbc15b177 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Fri, 16 Aug 2024 16:17:42 -0600 Subject: [PATCH 51/64] PR review clean up. --- src/api/server.rkt | 28 ++++++++++++---------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/src/api/server.rkt b/src/api/server.rkt index bd7d68a3c..67d4c79a7 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -242,15 +242,16 @@ [(list 'result job-id handler) (place-channel-put handler (hash-ref completed-work job-id #f))] [(list 'timeline job-id handler) (define wid (hash-ref current-jobs job-id #f)) - (when (not (false? wid)) - (log "Worker[~a] working on ~a.\n" wid job-id) - (define-values (a b) (place-channel)) - (place-channel-put (hash-ref busy-workers wid) (list 'timeline b)) - (define requested-timeline (place-channel-get a)) - (place-channel-put handler requested-timeline)) - (when (false? wid) - (log "Job complete, no timeline, send result.\n") - (place-channel-put handler (hash-ref completed-work job-id #f)))] + (cond + [(not (false? wid)) + (log "Worker[~a] working on ~a.\n" wid job-id) + (define-values (a b) (place-channel)) + (place-channel-put (hash-ref busy-workers wid) (list 'timeline b)) + (define requested-timeline (place-channel-get a)) + (place-channel-put handler requested-timeline)] + [(false? wid) + (log "Job complete, no timeline, send result.\n") + (place-channel-put handler (hash-ref completed-work job-id #f))])] ; Returns the current count of working workers. [(list 'count handler) (place-channel-put handler (hash-count busy-workers))] ; Retreive the improve results for results.json @@ -300,12 +301,10 @@ (*num-iterations* iterations) (*num-points* points) (*timeout* timeout) - (*demo-output* output) - (*reeval-pts* reeval) - (*demo?* demo?)] + (*reeval-pts* reeval)] [job-info (run-job job-info)]) (loop seed))))) - (define timeline (*timeline*)) + (define timeline #f) (define current-job-id #f) (for ([_ (in-naturals)]) (match (place-channel-get ch) @@ -319,9 +318,6 @@ (place-channel-put handler timeline)])))) (struct work (manager worker-id job-id job)) -; Not sure if these are actually needed. -(define *demo-output* (make-parameter false)) -(define *demo?* (make-parameter false)) (define (run-job job-info) (match-define (work manager worker-id job-id command) job-info) From 69949343ec5579a8fc6f19a01038140d6af71496 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Tue, 27 Aug 2024 11:11:24 -0600 Subject: [PATCH 52/64] PR review changes. --- src/api/demo.rkt | 24 ++++++++++++------------ src/api/server.rkt | 29 +++-------------------------- 2 files changed, 15 insertions(+), 38 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index 86bbdbf89..fbe901d60 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -340,17 +340,6 @@ (define (check-status req job-id) (match (get-timeline-for job-id) - [(? box? timeline) - (response 202 - #"Job in progress" - (current-seconds) - #"text/plain" - (list (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count))))) - (λ (out) - (display (apply string-append - (for/list ([entry (reverse (unbox timeline))]) - (format "Doing ~a\n" (hash-ref entry 'type)))) - out)))] [(? hash? result-hash) (response/full 201 #"Job complete" @@ -361,7 +350,18 @@ (add-prefix (format "~a.~a/graph.html" job-id *herbie-commit*)))) (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count)))) (header #"X-Herbie-Job-ID" (string->bytes/utf-8 job-id))) - '())])) + '())] + [timeline + (response 202 + #"Job in progress" + (current-seconds) + #"text/plain" + (list (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count))))) + (λ (out) + (display (apply string-append + (for/list ([entry timeline]) + (format "Doing ~a\n" (hash-ref entry 'type)))) + out)))])) (define (check-up req) (response/full (if (is-server-up) 200 500) diff --git a/src/api/server.rkt b/src/api/server.rkt index 67d4c79a7..72c27ebba 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -17,7 +17,6 @@ "../utils/common.rkt" "../utils/errors.rkt" "../utils/float.rkt" - "../utils/timeline.rkt" (submod "../utils/timeline.rkt" debug)) (provide make-path @@ -243,13 +242,13 @@ [(list 'timeline job-id handler) (define wid (hash-ref current-jobs job-id #f)) (cond - [(not (false? wid)) + [wid (log "Worker[~a] working on ~a.\n" wid job-id) (define-values (a b) (place-channel)) (place-channel-put (hash-ref busy-workers wid) (list 'timeline b)) (define requested-timeline (place-channel-get a)) (place-channel-put handler requested-timeline)] - [(false? wid) + [else (log "Job complete, no timeline, send result.\n") (place-channel-put handler (hash-ref completed-work job-id #f))])] ; Returns the current count of working workers. @@ -280,28 +279,6 @@ (thread (λ () (let loop ([seed #f]) (match (thread-receive) - [`(init rand - ,vec - flags - ,flag-table - num-iters - ,iterations - points - ,points - timeout - ,timeout - output-dir - ,output - reeval - ,reeval - demo? - ,demo?) - (set! seed vec) - (*flags* flag-table) - (*num-iterations* iterations) - (*num-points* points) - (*timeout* timeout) - (*reeval-pts* reeval)] [job-info (run-job job-info)]) (loop seed))))) (define timeline #f) @@ -315,7 +292,7 @@ (thread-send worker-thread (work manager worker-id job-id command))] [(list 'timeline handler) (log "Timeline requested from worker[~a] for job ~a\n" worker-id current-job-id) - (place-channel-put handler timeline)])))) + (place-channel-put handler (reverse (unbox timeline)))])))) (struct work (manager worker-id job-id job)) From 014a07d68a3af5d22ae48759c09ec12094769802 Mon Sep 17 00:00:00 2001 From: Brett Saiki Date: Tue, 27 Aug 2024 10:36:05 -0700 Subject: [PATCH 53/64] more syntax checking --- src/syntax/syntax.rkt | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/syntax/syntax.rkt b/src/syntax/syntax.rkt index 1ee7e434d..2640d3939 100644 --- a/src/syntax/syntax.rkt +++ b/src/syntax/syntax.rkt @@ -342,10 +342,20 @@ (cond [fpcore ; provided -> TODO: check free variables, props (match fpcore - [`(! ,props ... (,operator ,args ...)) + [`(! ,props ... (,op ,args ...)) (unless (even? (length props)) - (error 'register-operator-impl! "umatched property for ~a: ~a" name fpcore))] - [`(,operator ,args ...) (void)] + (error 'register-operator-impl! "~a: umatched property in ~a" name fpcore)) + (unless (symbol? op) + (error 'register-operator-impl! "~a: expected symbol `~a`" name op)) + (for ([arg (in-list args)]) + (unless (or (symbol? arg) (number? arg)) + (error 'register-operator-impl! "~a: expected terminal `~a`" name arg)))] + [`(,op ,args ...) + (unless (symbol? op) + (error 'register-operator-impl! "~a: expected symbol `~a`" name op)) + (for ([arg (in-list args)]) + (unless (or (symbol? arg) (number? arg)) + (error 'register-operator-impl! "~a: expected terminal `~a`" name arg)))] [_ (error 'register-operator-impl! "Invalid fpcore for ~a: ~a" name fpcore)]) fpcore] [else ; not provided => need to generate it From 7ac22ce3a1eeca1d7fb18edaebb8c5e2b9bff624 Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Tue, 27 Aug 2024 16:04:57 -0600 Subject: [PATCH 54/64] New batch abstractions --- src/core/batch.rkt | 318 ++++++++++++++++++------------------------ src/core/compiler.rkt | 4 +- src/core/localize.rkt | 2 +- src/core/taylor.rkt | 2 +- 4 files changed, 136 insertions(+), 190 deletions(-) diff --git a/src/core/batch.rkt b/src/core/batch.rkt index ee99c6963..2bc31f49e 100644 --- a/src/core/batch.rkt +++ b/src/core/batch.rkt @@ -6,203 +6,149 @@ (provide progs->batch batch->progs (struct-out batch) + batch-length batch-ref - expand-taylor) + batch-replace + expand-taylor + batch-remove-approx) -(struct batch ([nodes #:mutable] [roots #:mutable] vars [nodes-length #:mutable])) +;; This function defines the recursive structure of expressions + +(define (expr-recurse expr f) + (match expr + [(approx spec impl) (approx spec (f impl))] + [(list op args ...) (cons op (map f args))] + [_ expr])) + +;; Batches store these recursive structures, flattened + +(struct batch ([nodes #:mutable] [roots #:mutable] vars)) + +(define (batch-length b) + (cond + [(batch? b) + (vector-length (batch-nodes b))] + [(mutable-batch? b) + (hash-count (mutable-batch-index b))] + [else + (error 'batch-length "Invalid batch" b)])) + +(struct mutable-batch ([nodes #:mutable] [index #:mutable])) + +(define (make-mutable-batch) + (mutable-batch '() (make-hash))) + +(define (batch-push! b term) + (define hashcons (mutable-batch-index b)) + (hash-ref! hashcons + term + (lambda () + (let ([new-idx (hash-count hashcons)]) + (hash-set! hashcons term new-idx) + (set-mutable-batch-nodes! b (cons term (mutable-batch-nodes b))) + new-idx)))) + +(define (mutable-batch->immutable b) + (batch (list->vector (reverse (mutable-batch-nodes b))) + '() + '())) + +(struct batchref (batch idx)) + +(define (deref x) + (match-define (batchref b idx) x) + (expr-recurse (vector-ref (batch-nodes b) idx) + (lambda (ref) (batchref b ref)))) (define (progs->batch exprs #:timeline-push [timeline-push #f] - #:vars [vars '()] - #:ignore-approx [ignore-approx #t]) - (define icache (reverse vars)) - (define exprhash - (make-hash (for/list ([var vars] - [i (in-naturals)]) - (cons var i)))) - ; Counts - (define size 0) - (define exprc 0) - (define varc (length vars)) + #:vars [vars '()]) - ; Translates programs into an instruction sequence of operations - (define (munge-ignore-approx prog) - (set! size (+ 1 size)) - (match prog ; approx nodes are ignored - [(approx _ impl) (munge-ignore-approx impl)] - [_ - (define node ; This compiles to the register machine - (match prog - [(list op args ...) (cons op (map munge-ignore-approx args))] - [_ prog])) - (hash-ref! exprhash - node - (lambda () - (begin0 (+ exprc varc) ; store in cache, update exprs, exprc - (set! exprc (+ 1 exprc)) - (set! icache (cons node icache)))))])) - - ; Translates programs into an instruction sequence of operations - (define (munge-include-approx prog) + (define out (make-mutable-batch)) + (for ([var (in-list vars)]) + (batch-push! out var)) + + (define size 0) + (define (munge prog) (set! size (+ 1 size)) - (define node ; This compiles to the register machine - (match prog - [(approx spec impl) (approx spec (munge-include-approx impl))] - [(list op args ...) (cons op (map munge-include-approx args))] - [_ prog])) - (hash-ref! exprhash - node - (lambda () - (begin0 (+ exprc varc) ; store in cache, update exprs, exprc - (set! exprc (+ 1 exprc)) - (set! icache (cons node icache)))))) - - (define roots - (list->vector (map (if ignore-approx munge-ignore-approx munge-include-approx) exprs))) - (define nodes (list->vector (reverse icache))) - (define nodes-length (vector-length nodes)) + (batch-push! out (expr-recurse prog munge))) + (define roots (list->vector (map munge exprs))) + (define final (struct-copy batch (mutable-batch->immutable out) [roots roots])) (when timeline-push - (timeline-push! 'compiler (+ varc size) (+ exprc varc))) - (batch nodes roots vars nodes-length)) + (timeline-push! 'compiler size (batch-length final))) + final) -(define (batch->progs batch) - (define roots (batch-roots batch)) - (define nodes (batch-nodes batch)) +(define (batch->progs b) + (define exprs (make-vector (batch-length b))) + (for ([node (in-vector (batch-nodes b))] [idx (in-naturals)]) + (vector-set! exprs idx + (expr-recurse node (lambda (x) (vector-ref exprs x))))) + (for/list ([root (batch-roots b)]) + (vector-ref exprs root))) - (define (unmunge reg) - (define node (vector-ref nodes reg)) - (match node - [(approx spec impl) (approx spec (unmunge impl))] - [(list op regs ...) (cons op (map unmunge regs))] - [_ node])) +(define (batch-remove-approx batch) + (batch-replace batch + (lambda (node) + (match node + [(approx spec impl) impl] + [node node])))) - (define exprs - (for/list ([root (in-vector roots)]) - (unmunge root))) - exprs) +(define (batch-replace b f) + (define out (make-mutable-batch)) + (define mapping (make-vector (batch-length b) -1)) + (for ([node (in-vector (batch-nodes b))] [idx (in-naturals)]) + (define replacement (f (expr-recurse node (lambda (x) (batchref b x))))) + (define final-idx + (let loop ([expr replacement]) + (match expr + [(batchref b* idx) + (unless (eq? b* b) + (error 'batch-replace "Replacement ~a references the wrong batch ~a" replacement b*)) + (when (= -1 (vector-ref mapping idx)) + (error 'batch-replace "Replacement ~a references unknown index ~a" replacement idx)) + (vector-ref mapping idx)] + [_ + (batch-push! out (expr-recurse expr loop))]))) + (vector-set! mapping idx final-idx)) + (struct-copy batch (mutable-batch->immutable out) + [roots (vector-map (curry vector-ref mapping) (batch-roots b))] + [vars (batch-vars b)])) (define (expand-taylor input-batch) - (define vars (batch-vars input-batch)) - (define nodes (batch-nodes input-batch)) - (define roots (batch-roots input-batch)) - - ; Hash to avoid duplications - (define icache (reverse vars)) - (define exprhash - (make-hash (for/list ([var vars] - [i (in-naturals)]) - (cons var i)))) - (define exprc 0) - (define varc (length vars)) - - ; Mapping from nodes to nodes* - (define mappings (build-vector (batch-nodes-length input-batch) values)) - - ; Adding a node to hash - (define (append-node node) - (hash-ref! exprhash - node - (lambda () - (begin0 (+ exprc varc) ; store in cache, update exprs, exprc - (set! exprc (+ 1 exprc)) - (set! icache (cons node icache)))))) - - ; Sequential rewriting - (for ([node (in-vector nodes)] - [n (in-naturals)]) - (match node - [(list '- arg1 arg2) - (define neg-index (append-node `(neg ,(vector-ref mappings arg2)))) - (vector-set! mappings n (append-node `(+ ,(vector-ref mappings arg1) ,neg-index)))] - [(list 'pow base power) - #:when (equal? (vector-ref nodes power) 1/2) ; 1/2 is to be removed from exprhash - (vector-set! mappings n (append-node `(sqrt ,(vector-ref mappings base))))] - [(list 'pow base power) - #:when (equal? (vector-ref nodes power) 1/3) ; 1/3 is to be removed from exprhash - (vector-set! mappings n (append-node `(cbrt ,(vector-ref mappings base))))] - [(list 'pow base power) - #:when (equal? (vector-ref nodes power) 2/3) ; 2/3 is to be removed from exprhash - (define mult-index (append-node `(* ,(vector-ref mappings base) ,(vector-ref mappings base)))) - (vector-set! mappings n (append-node `(cbrt ,mult-index)))] - [(list 'pow base power) - #:when (exact-integer? (vector-ref nodes power)) - (vector-set! mappings - n - (append-node `(pow ,(vector-ref mappings base) ,(vector-ref mappings power))))] - [(list 'pow base power) - (define log-idx (append-node `(log ,(vector-ref mappings base)))) - (define mult-idx (append-node `(* ,(vector-ref mappings power) ,log-idx))) - (vector-set! mappings n (append-node `(exp ,mult-idx)))] - [(list 'tan args) - (define sin-idx (append-node `(sin ,(vector-ref mappings args)))) - (define cos-idx (append-node `(cos ,(vector-ref mappings args)))) - (vector-set! mappings n (append-node `(/ ,sin-idx ,cos-idx)))] - [(list 'cosh args) - (define exp-idx (append-node `(exp ,(vector-ref mappings args)))) - (define one-idx (append-node 1)) ; should it be 1 or literal 1 or smth? - (define inv-exp-idx (append-node `(/ ,one-idx ,exp-idx))) - (define add-idx (append-node `(+ ,exp-idx ,inv-exp-idx))) - (define half-idx (append-node 1/2)) - (vector-set! mappings n (append-node `(* ,half-idx ,add-idx)))] - [(list 'sinh args) - (define exp-idx (append-node `(exp ,(vector-ref mappings args)))) - (define one-idx (append-node 1)) - (define inv-exp-idx (append-node `(/ ,one-idx ,exp-idx))) - (define neg-idx (append-node `(neg ,inv-exp-idx))) - (define add-idx (append-node `(+ ,exp-idx ,neg-idx))) - (define half-idx (append-node 1/2)) - (vector-set! mappings n (append-node `(* ,half-idx ,add-idx)))] - [(list 'tanh args) - (define exp-idx (append-node `(exp ,(vector-ref mappings args)))) - (define one-idx (append-node 1)) - (define inv-exp-idx (append-node `(/ ,one-idx ,exp-idx))) - (define neg-idx (append-node `(neg ,inv-exp-idx))) - (define add-idx (append-node `(+ ,exp-idx ,inv-exp-idx))) - (define sub-idx (append-node `(+ ,exp-idx ,neg-idx))) - (vector-set! mappings n (append-node `(/ ,sub-idx ,add-idx)))] - [(list 'asinh args) - (define mult-idx (append-node `(* ,(vector-ref mappings args) ,(vector-ref mappings args)))) - (define one-idx (append-node 1)) - (define add-idx (append-node `(+ ,mult-idx ,one-idx))) - (define sqrt-idx (append-node `(sqrt ,add-idx))) - (define add2-idx (append-node `(+ ,(vector-ref mappings args) ,sqrt-idx))) - (vector-set! mappings n (append-node `(log ,add2-idx)))] - [(list 'acosh args) - (define mult-idx (append-node `(* ,(vector-ref mappings args) ,(vector-ref mappings args)))) - (define -one-idx (append-node -1)) - (define add-idx (append-node `(+ ,mult-idx ,-one-idx))) - (define sqrt-idx (append-node `(sqrt ,add-idx))) - (define add2-idx (append-node `(+ ,(vector-ref mappings args) ,sqrt-idx))) - (vector-set! mappings n (append-node `(log ,add2-idx)))] - [(list 'atanh args) - (define neg-idx (append-node `(neg ,(vector-ref mappings args)))) - (define one-idx (append-node 1)) - (define add-idx (append-node `(+ ,one-idx ,(vector-ref mappings args)))) - (define sub-idx (append-node `(+ ,one-idx ,neg-idx))) - (define div-idx (append-node `(/ ,add-idx ,sub-idx))) - (define log-idx (append-node `(log ,div-idx))) - (define half-idx (append-node 1/2)) - (vector-set! mappings n (append-node `(* ,half-idx ,log-idx)))] - [(list op args ...) - (vector-set! mappings n (append-node (cons op (map (curry vector-ref mappings) args))))] - [(approx spec impl) - (vector-set! mappings n (append-node (approx spec (vector-ref mappings impl))))] - [_ (vector-set! mappings n (append-node node))])) - - (define roots* (vector-map (curry vector-ref mappings) roots)) - (define nodes* (list->vector (reverse icache))) - - ; This may be too expensive to handle simple 1/2, 1/3 and 2/3 zombie nodes.. - #;(remove-zombie-nodes (batch nodes* roots* vars (vector-length nodes*))) - - (batch nodes* roots* vars (vector-length nodes*))) + (batch-replace + input-batch + (lambda (node) + (match node + [(list '- ref1 ref2) `(+ ,ref1 (neg ,ref2))] + [(list 'pow base (app deref 1/2)) `(sqrt ,base)] + [(list 'pow base (app deref 1/3)) `(cbrt ,base)] + [(list 'pow base (app deref 2/3)) `(cbrt (* ,base ,base))] + [(list 'pow base (and power (app deref (? exact-integer?)))) + (list 'pow base power)] + [(list 'pow base power) + `(exp (* ,power (log ,base)))] + [(list 'tan arg) + `(/ (sin ,arg) (cos ,arg))] + [(list 'cosh arg) + `(* 1/2 (+ (exp ,arg) (/ 1 (exp ,arg))))] + [(list 'sinh arg) + `(* 1/2 (+ (exp ,arg) (/ -1 (exp ,arg))))] + [(list 'tanh arg) + `(/ (+ (exp ,arg) (neg (/ 1 (exp ,arg)))) (+ (exp ,arg) (/ 1 (exp ,arg))))] + [(list 'asinh arg) + `(log (+ ,arg (sqrt (+ (* ,arg ,arg) 1))))] + [(list 'acosh arg) + `(log (+ ,arg (sqrt (+ (* ,arg ,arg) -1))))] + [(list 'atanh arg) + `(* 1/2 (log (/ (+ 1 ,arg) (+ 1 (neg ,arg)))))] + [_ node])))) ; The function removes any zombie nodes from batch (define (remove-zombie-nodes input-batch) (define nodes (batch-nodes input-batch)) (define roots (batch-roots input-batch)) - (define nodes-length (batch-nodes-length input-batch)) + (define nodes-length (batch-length input-batch)) (define zombie-mask (make-vector nodes-length #t)) (for ([root (in-vector roots)]) @@ -232,7 +178,7 @@ nodes*)))) (set! nodes* (list->vector (reverse nodes*))) (define roots* (vector-map (curry vector-ref mappings) roots)) - (batch nodes* roots* (batch-vars input-batch) (vector-length nodes*))) + (batch nodes* roots* (batch-vars input-batch))) (define (batch-ref batch reg) (define (unmunge reg) @@ -246,8 +192,9 @@ ; Tests for expand-taylor (module+ test (require rackunit) + (define (test-expand-taylor expr) - (define batch (progs->batch (list expr) #:ignore-approx #f)) + (define batch (progs->batch (list expr))) (define batch* (expand-taylor batch)) (car (batch->progs batch*))) @@ -256,7 +203,7 @@ (check-equal? '(log (+ x (sqrt (+ (* x x) 1)))) (test-expand-taylor '(asinh x))) (check-equal? '(/ (+ (exp x) (neg (/ 1 (exp x)))) (+ (exp x) (/ 1 (exp x)))) (test-expand-taylor '(tanh x))) - (check-equal? '(* 1/2 (+ (exp x) (neg (/ 1 (exp x))))) (test-expand-taylor '(sinh x))) + (check-equal? '(* 1/2 (+ (exp x) (/ -1 (exp x)))) (test-expand-taylor '(sinh x))) (check-equal? '(+ 1 (neg (+ 2 (neg 3)))) (test-expand-taylor '(- 1 (- 2 3)))) (check-equal? '(* 1/2 (+ (exp x) (/ 1 (exp x)))) (test-expand-taylor '(cosh x))) (check-equal? '(/ (sin x) (cos x)) (test-expand-taylor '(tan x))) @@ -275,8 +222,8 @@ ; Tests for progs->batch and batch->progs (module+ test (require rackunit) - (define (test-munge-unmunge expr [ignore-approx #t]) - (define batch (progs->batch (list expr) #:ignore-approx ignore-approx)) + (define (test-munge-unmunge expr) + (define batch (progs->batch (list expr))) (check-equal? (list expr) (batch->progs batch))) (test-munge-unmunge '(* 1/2 (+ (exp x) (neg (/ 1 (exp x)))))) @@ -285,14 +232,13 @@ (test-munge-unmunge '(cbrt x)) (test-munge-unmunge '(x)) (test-munge-unmunge - `(+ (sin ,(approx '(* 1/2 (+ (exp x) (neg (/ 1 (exp x))))) '(+ 3 (* 25 (sin 6))))) 4) - #f)) + `(+ (sin ,(approx '(* 1/2 (+ (exp x) (neg (/ 1 (exp x))))) '(+ 3 (* 25 (sin 6))))) 4))) ; Tests for remove-zombie-nodes (module+ test (require rackunit) (define (zombie-test #:nodes nodes #:roots roots) - (define in-batch (batch nodes roots '() (vector-length nodes))) + (define in-batch (batch nodes roots '())) (define out-batch (remove-zombie-nodes in-batch)) (batch-nodes out-batch)) diff --git a/src/core/compiler.rkt b/src/core/compiler.rkt index f3173efdc..626b4a9df 100644 --- a/src/core/compiler.rkt +++ b/src/core/compiler.rkt @@ -54,10 +54,10 @@ ;; Requires some hooks to complete the translation. (define (make-compiler exprs vars) (define num-vars (length vars)) - (define batch (progs->batch exprs #:timeline-push #t #:vars vars #:ignore-approx #t)) + (define batch (batch-remove-approx (progs->batch exprs #:timeline-push #t #:vars vars))) (define instructions - (for/vector #:length (- (batch-nodes-length batch) num-vars) + (for/vector #:length (- (batch-length batch) num-vars) ([node (in-vector (batch-nodes batch) num-vars)]) (match node [(literal value (app get-representation repr)) (list (const (real->repr value repr)))] diff --git a/src/core/localize.rkt b/src/core/localize.rkt index 46907ec4b..bcedf6bec 100644 --- a/src/core/localize.rkt +++ b/src/core/localize.rkt @@ -120,7 +120,7 @@ (for/list ([subexpr (in-list exprs-list)]) (struct-copy context ctx [repr (repr-of subexpr ctx)]))) - (define expr-batch (progs->batch exprs-list #:ignore-approx #f)) + (define expr-batch (progs->batch exprs-list)) (define nodes (batch-nodes expr-batch)) (define roots (batch-roots expr-batch)) diff --git a/src/core/taylor.rkt b/src/core/taylor.rkt index ffa5963c9..24be9b248 100644 --- a/src/core/taylor.rkt +++ b/src/core/taylor.rkt @@ -77,7 +77,7 @@ (define (taylor var expr-batch) "Return a pair (e, n), such that expr ~= e var^n" (define nodes (batch-nodes expr-batch)) - (define taylor-approxs (make-vector (batch-nodes-length expr-batch))) ; vector of approximations + (define taylor-approxs (make-vector (batch-length expr-batch))) ; vector of approximations (for ([node (in-vector nodes)] [n (in-naturals)]) From 3d5d48149797f13e515175d15bd7ac34cf15bec9 Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Tue, 27 Aug 2024 16:12:41 -0600 Subject: [PATCH 55/64] Formatting & vars in mutable batches --- src/core/batch.rkt | 74 ++++++++++++++++++---------------------------- 1 file changed, 29 insertions(+), 45 deletions(-) diff --git a/src/core/batch.rkt b/src/core/batch.rkt index 2bc31f49e..680aa47f7 100644 --- a/src/core/batch.rkt +++ b/src/core/batch.rkt @@ -26,17 +26,14 @@ (define (batch-length b) (cond - [(batch? b) - (vector-length (batch-nodes b))] - [(mutable-batch? b) - (hash-count (mutable-batch-index b))] - [else - (error 'batch-length "Invalid batch" b)])) + [(batch? b) (vector-length (batch-nodes b))] + [(mutable-batch? b) (hash-count (mutable-batch-index b))] + [else (error 'batch-length "Invalid batch" b)])) -(struct mutable-batch ([nodes #:mutable] [index #:mutable])) +(struct mutable-batch ([nodes #:mutable] [index #:mutable] [vars #:mutable])) (define (make-mutable-batch) - (mutable-batch '() (make-hash))) + (mutable-batch '() (make-hash) '())) (define (batch-push! b term) (define hashcons (mutable-batch-index b)) @@ -46,23 +43,20 @@ (let ([new-idx (hash-count hashcons)]) (hash-set! hashcons term new-idx) (set-mutable-batch-nodes! b (cons term (mutable-batch-nodes b))) + (when (symbol? term) + (set-mutable-batch-vars! b (cons term (mutable-batch-vars b)))) new-idx)))) -(define (mutable-batch->immutable b) - (batch (list->vector (reverse (mutable-batch-nodes b))) - '() - '())) +(define (mutable-batch->immutable b roots) + (batch (list->vector (reverse (mutable-batch-nodes b))) roots (reverse (mutable-batch-vars b)))) (struct batchref (batch idx)) (define (deref x) (match-define (batchref b idx) x) - (expr-recurse (vector-ref (batch-nodes b) idx) - (lambda (ref) (batchref b ref)))) + (expr-recurse (vector-ref (batch-nodes b) idx) (lambda (ref) (batchref b ref)))) -(define (progs->batch exprs - #:timeline-push [timeline-push #f] - #:vars [vars '()]) +(define (progs->batch exprs #:timeline-push [timeline-push #f] #:vars [vars '()]) (define out (make-mutable-batch)) (for ([var (in-list vars)]) @@ -74,16 +68,16 @@ (batch-push! out (expr-recurse prog munge))) (define roots (list->vector (map munge exprs))) - (define final (struct-copy batch (mutable-batch->immutable out) [roots roots])) + (define final (mutable-batch->immutable out roots)) (when timeline-push (timeline-push! 'compiler size (batch-length final))) final) (define (batch->progs b) (define exprs (make-vector (batch-length b))) - (for ([node (in-vector (batch-nodes b))] [idx (in-naturals)]) - (vector-set! exprs idx - (expr-recurse node (lambda (x) (vector-ref exprs x))))) + (for ([node (in-vector (batch-nodes b))] + [idx (in-naturals)]) + (vector-set! exprs idx (expr-recurse node (lambda (x) (vector-ref exprs x))))) (for/list ([root (batch-roots b)]) (vector-ref exprs root))) @@ -97,7 +91,8 @@ (define (batch-replace b f) (define out (make-mutable-batch)) (define mapping (make-vector (batch-length b) -1)) - (for ([node (in-vector (batch-nodes b))] [idx (in-naturals)]) + (for ([node (in-vector (batch-nodes b))] + [idx (in-naturals)]) (define replacement (f (expr-recurse node (lambda (x) (batchref b x))))) (define final-idx (let loop ([expr replacement]) @@ -108,12 +103,10 @@ (when (= -1 (vector-ref mapping idx)) (error 'batch-replace "Replacement ~a references unknown index ~a" replacement idx)) (vector-ref mapping idx)] - [_ - (batch-push! out (expr-recurse expr loop))]))) + [_ (batch-push! out (expr-recurse expr loop))]))) (vector-set! mapping idx final-idx)) - (struct-copy batch (mutable-batch->immutable out) - [roots (vector-map (curry vector-ref mapping) (batch-roots b))] - [vars (batch-vars b)])) + (define roots (vector-map (curry vector-ref mapping) (batch-roots b))) + (mutable-batch->immutable out roots)) (define (expand-taylor input-batch) (batch-replace @@ -124,24 +117,15 @@ [(list 'pow base (app deref 1/2)) `(sqrt ,base)] [(list 'pow base (app deref 1/3)) `(cbrt ,base)] [(list 'pow base (app deref 2/3)) `(cbrt (* ,base ,base))] - [(list 'pow base (and power (app deref (? exact-integer?)))) - (list 'pow base power)] - [(list 'pow base power) - `(exp (* ,power (log ,base)))] - [(list 'tan arg) - `(/ (sin ,arg) (cos ,arg))] - [(list 'cosh arg) - `(* 1/2 (+ (exp ,arg) (/ 1 (exp ,arg))))] - [(list 'sinh arg) - `(* 1/2 (+ (exp ,arg) (/ -1 (exp ,arg))))] - [(list 'tanh arg) - `(/ (+ (exp ,arg) (neg (/ 1 (exp ,arg)))) (+ (exp ,arg) (/ 1 (exp ,arg))))] - [(list 'asinh arg) - `(log (+ ,arg (sqrt (+ (* ,arg ,arg) 1))))] - [(list 'acosh arg) - `(log (+ ,arg (sqrt (+ (* ,arg ,arg) -1))))] - [(list 'atanh arg) - `(* 1/2 (log (/ (+ 1 ,arg) (+ 1 (neg ,arg)))))] + [(list 'pow base (and power (app deref (? exact-integer?)))) (list 'pow base power)] + [(list 'pow base power) `(exp (* ,power (log ,base)))] + [(list 'tan arg) `(/ (sin ,arg) (cos ,arg))] + [(list 'cosh arg) `(* 1/2 (+ (exp ,arg) (/ 1 (exp ,arg))))] + [(list 'sinh arg) `(* 1/2 (+ (exp ,arg) (/ -1 (exp ,arg))))] + [(list 'tanh arg) `(/ (+ (exp ,arg) (neg (/ 1 (exp ,arg)))) (+ (exp ,arg) (/ 1 (exp ,arg))))] + [(list 'asinh arg) `(log (+ ,arg (sqrt (+ (* ,arg ,arg) 1))))] + [(list 'acosh arg) `(log (+ ,arg (sqrt (+ (* ,arg ,arg) -1))))] + [(list 'atanh arg) `(* 1/2 (log (/ (+ 1 ,arg) (+ 1 (neg ,arg)))))] [_ node])))) ; The function removes any zombie nodes from batch From 6dba20043885c7827d8990b82e7bfd4104517ee8 Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Tue, 27 Aug 2024 16:27:43 -0600 Subject: [PATCH 56/64] Move batch-replace and batch-approx --- src/core/batch.rkt | 31 +------------------------------ src/core/compiler.rkt | 7 +++++++ src/core/taylor.rkt | 21 +++++++++++++++++++++ 3 files changed, 29 insertions(+), 30 deletions(-) diff --git a/src/core/batch.rkt b/src/core/batch.rkt index 680aa47f7..a64bc2b77 100644 --- a/src/core/batch.rkt +++ b/src/core/batch.rkt @@ -8,9 +8,7 @@ (struct-out batch) batch-length batch-ref - batch-replace - expand-taylor - batch-remove-approx) + batch-replace) ;; This function defines the recursive structure of expressions @@ -81,13 +79,6 @@ (for/list ([root (batch-roots b)]) (vector-ref exprs root))) -(define (batch-remove-approx batch) - (batch-replace batch - (lambda (node) - (match node - [(approx spec impl) impl] - [node node])))) - (define (batch-replace b f) (define out (make-mutable-batch)) (define mapping (make-vector (batch-length b) -1)) @@ -108,26 +99,6 @@ (define roots (vector-map (curry vector-ref mapping) (batch-roots b))) (mutable-batch->immutable out roots)) -(define (expand-taylor input-batch) - (batch-replace - input-batch - (lambda (node) - (match node - [(list '- ref1 ref2) `(+ ,ref1 (neg ,ref2))] - [(list 'pow base (app deref 1/2)) `(sqrt ,base)] - [(list 'pow base (app deref 1/3)) `(cbrt ,base)] - [(list 'pow base (app deref 2/3)) `(cbrt (* ,base ,base))] - [(list 'pow base (and power (app deref (? exact-integer?)))) (list 'pow base power)] - [(list 'pow base power) `(exp (* ,power (log ,base)))] - [(list 'tan arg) `(/ (sin ,arg) (cos ,arg))] - [(list 'cosh arg) `(* 1/2 (+ (exp ,arg) (/ 1 (exp ,arg))))] - [(list 'sinh arg) `(* 1/2 (+ (exp ,arg) (/ -1 (exp ,arg))))] - [(list 'tanh arg) `(/ (+ (exp ,arg) (neg (/ 1 (exp ,arg)))) (+ (exp ,arg) (/ 1 (exp ,arg))))] - [(list 'asinh arg) `(log (+ ,arg (sqrt (+ (* ,arg ,arg) 1))))] - [(list 'acosh arg) `(log (+ ,arg (sqrt (+ (* ,arg ,arg) -1))))] - [(list 'atanh arg) `(* 1/2 (log (/ (+ 1 ,arg) (+ 1 (neg ,arg)))))] - [_ node])))) - ; The function removes any zombie nodes from batch (define (remove-zombie-nodes input-batch) (define nodes (batch-nodes input-batch)) diff --git a/src/core/compiler.rkt b/src/core/compiler.rkt index 626b4a9df..6505cb18c 100644 --- a/src/core/compiler.rkt +++ b/src/core/compiler.rkt @@ -50,6 +50,13 @@ (define (if-proc c a b) (if c a b)) +(define (batch-remove-approx batch) + (batch-replace batch + (lambda (node) + (match node + [(approx spec impl) impl] + [node node])))) + ;; Translates a Herbie IR into an interpretable IR. ;; Requires some hooks to complete the translation. (define (make-compiler exprs vars) diff --git a/src/core/taylor.rkt b/src/core/taylor.rkt index 24be9b248..dd7e1ab32 100644 --- a/src/core/taylor.rkt +++ b/src/core/taylor.rkt @@ -34,6 +34,27 @@ (simplify (make-horner ((cdr tform) var) (reverse terms)))])) next)) +;; Our Taylor expander prefers sin, cos, exp, log, neg over trig, htrig, pow, and subtraction +(define (expand-taylor input-batch) + (batch-replace + input-batch + (lambda (node) + (match node + [(list '- ref1 ref2) `(+ ,ref1 (neg ,ref2))] + [(list 'pow base (app deref 1/2)) `(sqrt ,base)] + [(list 'pow base (app deref 1/3)) `(cbrt ,base)] + [(list 'pow base (app deref 2/3)) `(cbrt (* ,base ,base))] + [(list 'pow base (and power (app deref (? exact-integer?)))) `(pow base power)] + [(list 'pow base power) `(exp (* ,power (log ,base)))] + [(list 'tan arg) `(/ (sin ,arg) (cos ,arg))] + [(list 'cosh arg) `(* 1/2 (+ (exp ,arg) (/ 1 (exp ,arg))))] + [(list 'sinh arg) `(* 1/2 (+ (exp ,arg) (/ -1 (exp ,arg))))] + [(list 'tanh arg) `(/ (+ (exp ,arg) (neg (/ 1 (exp ,arg)))) (+ (exp ,arg) (/ 1 (exp ,arg))))] + [(list 'asinh arg) `(log (+ ,arg (sqrt (+ (* ,arg ,arg) 1))))] + [(list 'acosh arg) `(log (+ ,arg (sqrt (+ (* ,arg ,arg) -1))))] + [(list 'atanh arg) `(* 1/2 (log (/ (+ 1 ,arg) (+ 1 (neg ,arg)))))] + [_ node])))) + (define (make-horner var terms [start 0]) (match terms ['() 0] From 1ac8a8e3f69e04da8f9add1cad6d7b7fc3d8da5a Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Tue, 27 Aug 2024 16:33:48 -0600 Subject: [PATCH 57/64] Move expand-taylor tests --- src/core/batch.rkt | 30 +----------------------------- src/core/taylor.rkt | 30 ++++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 29 deletions(-) diff --git a/src/core/batch.rkt b/src/core/batch.rkt index a64bc2b77..e6c675e1b 100644 --- a/src/core/batch.rkt +++ b/src/core/batch.rkt @@ -8,6 +8,7 @@ (struct-out batch) batch-length batch-ref + deref batch-replace) ;; This function defines the recursive structure of expressions @@ -144,35 +145,6 @@ [_ node])) (unmunge reg)) -; Tests for expand-taylor -(module+ test - (require rackunit) - - (define (test-expand-taylor expr) - (define batch (progs->batch (list expr))) - (define batch* (expand-taylor batch)) - (car (batch->progs batch*))) - - (check-equal? '(* 1/2 (log (/ (+ 1 x) (+ 1 (neg x))))) (test-expand-taylor '(atanh x))) - (check-equal? '(log (+ x (sqrt (+ (* x x) -1)))) (test-expand-taylor '(acosh x))) - (check-equal? '(log (+ x (sqrt (+ (* x x) 1)))) (test-expand-taylor '(asinh x))) - (check-equal? '(/ (+ (exp x) (neg (/ 1 (exp x)))) (+ (exp x) (/ 1 (exp x)))) - (test-expand-taylor '(tanh x))) - (check-equal? '(* 1/2 (+ (exp x) (/ -1 (exp x)))) (test-expand-taylor '(sinh x))) - (check-equal? '(+ 1 (neg (+ 2 (neg 3)))) (test-expand-taylor '(- 1 (- 2 3)))) - (check-equal? '(* 1/2 (+ (exp x) (/ 1 (exp x)))) (test-expand-taylor '(cosh x))) - (check-equal? '(/ (sin x) (cos x)) (test-expand-taylor '(tan x))) - (check-equal? '(+ 1 (neg (* 1/2 (+ (exp (/ (sin 3) (cos 3))) (/ 1 (exp (/ (sin 3) (cos 3)))))))) - (test-expand-taylor '(- 1 (cosh (tan 3))))) - (check-equal? '(exp (* a (log x))) (test-expand-taylor '(pow x a))) - (check-equal? '(+ x (sin a)) (test-expand-taylor '(+ x (sin a)))) - (check-equal? '(cbrt x) (test-expand-taylor '(pow x 1/3))) - (check-equal? '(cbrt (* x x)) (test-expand-taylor '(pow x 2/3))) - (check-equal? '(+ 100 (cbrt x)) (test-expand-taylor '(+ 100 (pow x 1/3)))) - (check-equal? `(+ 100 (cbrt (* x ,(approx 2 3)))) - (test-expand-taylor `(+ 100 (pow (* x ,(approx 2 3)) 1/3)))) - (check-equal? `(+ ,(approx 2 3) (cbrt x)) (test-expand-taylor `(+ ,(approx 2 3) (pow x 1/3)))) - (check-equal? `(+ (cbrt x) ,(approx 2 1/3)) (test-expand-taylor `(+ (pow x 1/3) ,(approx 2 1/3))))) ; Tests for progs->batch and batch->progs (module+ test diff --git a/src/core/taylor.rkt b/src/core/taylor.rkt index dd7e1ab32..db76a25c4 100644 --- a/src/core/taylor.rkt +++ b/src/core/taylor.rkt @@ -55,6 +55,36 @@ [(list 'atanh arg) `(* 1/2 (log (/ (+ 1 ,arg) (+ 1 (neg ,arg)))))] [_ node])))) +; Tests for expand-taylor +(module+ test + (require rackunit) + + (define (test-expand-taylor expr) + (define batch (progs->batch (list expr))) + (define batch* (expand-taylor batch)) + (car (batch->progs batch*))) + + (check-equal? '(* 1/2 (log (/ (+ 1 x) (+ 1 (neg x))))) (test-expand-taylor '(atanh x))) + (check-equal? '(log (+ x (sqrt (+ (* x x) -1)))) (test-expand-taylor '(acosh x))) + (check-equal? '(log (+ x (sqrt (+ (* x x) 1)))) (test-expand-taylor '(asinh x))) + (check-equal? '(/ (+ (exp x) (neg (/ 1 (exp x)))) (+ (exp x) (/ 1 (exp x)))) + (test-expand-taylor '(tanh x))) + (check-equal? '(* 1/2 (+ (exp x) (/ -1 (exp x)))) (test-expand-taylor '(sinh x))) + (check-equal? '(+ 1 (neg (+ 2 (neg 3)))) (test-expand-taylor '(- 1 (- 2 3)))) + (check-equal? '(* 1/2 (+ (exp x) (/ 1 (exp x)))) (test-expand-taylor '(cosh x))) + (check-equal? '(/ (sin x) (cos x)) (test-expand-taylor '(tan x))) + (check-equal? '(+ 1 (neg (* 1/2 (+ (exp (/ (sin 3) (cos 3))) (/ 1 (exp (/ (sin 3) (cos 3)))))))) + (test-expand-taylor '(- 1 (cosh (tan 3))))) + (check-equal? '(exp (* a (log x))) (test-expand-taylor '(pow x a))) + (check-equal? '(+ x (sin a)) (test-expand-taylor '(+ x (sin a)))) + (check-equal? '(cbrt x) (test-expand-taylor '(pow x 1/3))) + (check-equal? '(cbrt (* x x)) (test-expand-taylor '(pow x 2/3))) + (check-equal? '(+ 100 (cbrt x)) (test-expand-taylor '(+ 100 (pow x 1/3)))) + (check-equal? `(+ 100 (cbrt (* x ,(approx 2 3)))) + (test-expand-taylor `(+ 100 (pow (* x ,(approx 2 3)) 1/3)))) + (check-equal? `(+ ,(approx 2 3) (cbrt x)) (test-expand-taylor `(+ ,(approx 2 3) (pow x 1/3)))) + (check-equal? `(+ (cbrt x) ,(approx 2 1/3)) (test-expand-taylor `(+ (pow x 1/3) ,(approx 2 1/3))))) + (define (make-horner var terms [start 0]) (match terms ['() 0] From 6797ad03e4ee7c5f5625fff6f324b9073d91e61a Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Tue, 27 Aug 2024 16:34:50 -0600 Subject: [PATCH 58/64] Woops --- src/core/batch.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core/batch.rkt b/src/core/batch.rkt index e6c675e1b..ac22d48e1 100644 --- a/src/core/batch.rkt +++ b/src/core/batch.rkt @@ -145,7 +145,6 @@ [_ node])) (unmunge reg)) - ; Tests for progs->batch and batch->progs (module+ test (require rackunit) From c4dc251eb2adf15f02c56719174cf8532bab7284 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Wed, 21 Aug 2024 14:17:29 -0600 Subject: [PATCH 59/64] Remove helper, break out pages. --- src/api/demo.rkt | 42 +++++++++++++++++++++++------------------- src/reports/pages.rkt | 42 ++++++++++++++++++++++++++---------------- 2 files changed, 49 insertions(+), 35 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index 3f8c7181f..5a009bb5d 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -48,9 +48,14 @@ (and (not (and (*demo-output*) ; If we've already saved to disk, skip this job (directory-exists? (build-path (*demo-output*) x)))) (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) + (eprintf "TOPx: ~a\n" x) + (eprintf "TOPm: ~a\n" m) (and m (get-results-for (second m)))))) (λ (x) - (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) (get-results-for (if m (second m) x))))) + (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) + (eprintf "BOTTOMx: ~a\n" x) + (eprintf "BOTTOMm: ~a\n" m) + (get-results-for (if m (second m) x))))) (define-bidi-match-expander hash-arg hash-arg/m hash-arg/m) @@ -75,6 +80,8 @@ [("results.json") generate-report])) (define (generate-page req result-hash page) + (eprintf "PAGE: ~a\n" page) + (eprintf "~a\n" req) (define path (first (string-split (url->string (request-uri req)) "/"))) (cond [(set-member? (all-pages result-hash) page) @@ -87,11 +94,21 @@ (λ (out) (with-handlers ([exn:fail? (page-error-handler result-hash page out)]) (make-page page out result-hash (*demo-output*) #f))))) - (update-report result-hash - path - (get-seed) - (build-path (*demo-output*) "results.json") - (build-path (*demo-output*) "index.html"))) + (define link (path-element->string (last (explode-path path)))) + (define data (get-table-data-from-hash result-hash link)) + (define data-file (build-path (*demo-output*) "results.json")) + (define html-file (build-path (*demo-output*) "index.html")) + (define info + (if (file-exists? data-file) + (let ([info (read-datafile data-file)]) + (struct-copy report-info info [tests (cons data (report-info-tests info))])) + (make-report-info (list data) + #:seed (get-seed) + #:note (if (*demo?*) "Web demo results" "")))) + (define tmp-file (build-path (*demo-output*) "results.tmp")) + (write-datafile tmp-file info) + (rename-file-or-directory tmp-file data-file #t) + (copy-file (web-resource "report.html") html-file #t)) (response 200 #"OK" (current-seconds) @@ -234,19 +251,6 @@ (a ([href "./index.html"]) " See what formulas other users submitted."))] [else `("all formulas submitted here are " (a ([href "./index.html"]) "logged") ".")]))))) -(define (update-report result-hash dir seed data-file html-file) - (define link (path-element->string (last (explode-path dir)))) - (define data (get-table-data-from-hash result-hash link)) - (define info - (if (file-exists? data-file) - (let ([info (read-datafile data-file)]) - (struct-copy report-info info [tests (cons data (report-info-tests info))])) - (make-report-info (list data) #:seed seed #:note (if (*demo?*) "Web demo results" "")))) - (define tmp-file (build-path (*demo-output*) "results.tmp")) - (write-datafile tmp-file info) - (rename-file-or-directory tmp-file data-file #t) - (copy-file (web-resource "report.html") html-file #t)) - (define (post-with-json-response fn) (lambda (req) (define post-body (request-post-data/raw req)) diff --git a/src/reports/pages.rkt b/src/reports/pages.rkt index 212a9f50a..30310a77b 100644 --- a/src/reports/pages.rkt +++ b/src/reports/pages.rkt @@ -31,20 +31,30 @@ (display "" out))) (define (make-page page out result-hash output? profile?) - (define test (hash-ref result-hash 'test)) - (define status (hash-ref result-hash 'status)) (match page - ["graph.html" - (match status - ['success - (define command (hash-ref result-hash 'command)) - (match command - ["improve" (make-graph result-hash out output? profile?)] - [else (dummy-graph command out)])] - ['timeout (make-traceback result-hash out)] - ['failure (make-traceback result-hash out)] - [_ (error 'make-page "unknown result type ~a" status)])] - ["timeline.html" - (make-timeline (test-name test) (hash-ref result-hash 'timeline) out #:path "..")] - ["timeline.json" (write-json (hash-ref result-hash 'timeline) out)] - ["points.json" (write-json (make-points-json result-hash) out)])) + ["graph.html" (make-graph-html out result-hash output? profile?)] + ["timeline.html" (make-timeline-html out result-hash)] + ["timeline.json" (make-timeline-json out result-hash)] + ["points.json" (make-points out result-hash)])) + +(define (make-graph-html out result-hash output? profile?) + (define status (hash-ref result-hash 'status)) + (match status + ['success + (define command (hash-ref result-hash 'command)) + (match command + ["improve" (make-graph result-hash out output? profile?)] + [else (dummy-graph command out)])] + ['timeout (make-traceback result-hash out)] + ['failure (make-traceback result-hash out)] + [_ (error 'make-page "unknown result type ~a" status)])) + +(define (make-points out result-hash) + (write-json (make-points-json result-hash) out)) + +(define (make-timeline-json out result-hash) + (write-json (hash-ref result-hash 'timeline) out)) + +(define (make-timeline-html out result-hash) + (define test (hash-ref result-hash 'test)) + (make-timeline (test-name test) (hash-ref result-hash 'timeline) out #:path "..")) From a67ec1a5b75c49f48f006775087228530773f20d Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Thu, 22 Aug 2024 10:34:20 -0600 Subject: [PATCH 60/64] Push up out. --- src/api/demo.rkt | 17 +-- src/reports/make-graph.rkt | 253 ++++++++++++++++++------------------- src/reports/pages.rkt | 32 +++-- src/reports/plot.rkt | 21 +-- src/reports/timeline.rkt | 26 ++-- src/reports/traceback.rkt | 76 ++++++----- 6 files changed, 201 insertions(+), 224 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index 5a009bb5d..b945c38a1 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -18,18 +18,14 @@ "../config.rkt" "../syntax/read.rkt" "../utils/errors.rkt") -(require "../syntax/types.rkt" +(require "../syntax/sugar.rkt" - "../utils/alternative.rkt" "../core/points.rkt" - "../api/sandbox.rkt" - "../utils/float.rkt") + "../api/sandbox.rkt") (require "datafile.rkt" "../reports/pages.rkt" "../reports/common.rkt" "../reports/core2mathjs.rkt" - "../reports/history.rkt" - "../reports/plot.rkt" "server.rkt") (provide run-demo) @@ -48,14 +44,9 @@ (and (not (and (*demo-output*) ; If we've already saved to disk, skip this job (directory-exists? (build-path (*demo-output*) x)))) (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) - (eprintf "TOPx: ~a\n" x) - (eprintf "TOPm: ~a\n" m) (and m (get-results-for (second m)))))) (λ (x) - (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) - (eprintf "BOTTOMx: ~a\n" x) - (eprintf "BOTTOMm: ~a\n" m) - (get-results-for (if m (second m) x))))) + (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) (get-results-for (if m (second m) x))))) (define-bidi-match-expander hash-arg hash-arg/m hash-arg/m) @@ -80,8 +71,6 @@ [("results.json") generate-report])) (define (generate-page req result-hash page) - (eprintf "PAGE: ~a\n" page) - (eprintf "~a\n" req) (define path (first (string-split (url->string (request-uri req)) "/"))) (cond [(set-member? (all-pages result-hash) page) diff --git a/src/reports/make-graph.rkt b/src/reports/make-graph.rkt index 3dcf1f373..66ccafda7 100644 --- a/src/reports/make-graph.rkt +++ b/src/reports/make-graph.rkt @@ -6,16 +6,12 @@ (require "../utils/common.rkt" "../core/points.rkt" "../utils/float.rkt" - "../core/programs.rkt" "../utils/alternative.rkt" "../syntax/types.rkt" "../syntax/read.rkt" "../core/bsearch.rkt" "../api/sandbox.rkt" - "common.rkt" - "history.rkt" - "../syntax/sugar.rkt" - "timeline.rkt") + "common.rkt") (provide make-graph dummy-graph) @@ -36,20 +32,18 @@ [(list op args ...) (ormap list? args)] [_ #f])) -(define (dummy-graph command out) - (write-html - `(html (head (meta ([charset "utf-8"])) - (title "Result page for the " ,(~a command) " command is not available right now.") - ,@js-tex-include - (script ([src "https://unpkg.com/mathjs@4.4.2/dist/math.min.js"])) - (script ([src "https://unpkg.com/d3@6.7.0/dist/d3.min.js"])) - (script ([src "https://unpkg.com/@observablehq/plot@0.4.3/dist/plot.umd.min.js"])) - (link ([rel "stylesheet"] [type "text/css"] [href "../report.css"])) - (script ([src "../report.js"]))) - (body (h2 "Result page for the " ,(~a command) " command is not available right now."))) - out)) - -(define (make-graph result-hash out output? profile?) +(define (dummy-graph command) + `(html (head (meta ([charset "utf-8"])) + (title "Result page for the " ,(~a command) " command is not available right now.") + ,@js-tex-include + (script ([src "https://unpkg.com/mathjs@4.4.2/dist/math.min.js"])) + (script ([src "https://unpkg.com/d3@6.7.0/dist/d3.min.js"])) + (script ([src "https://unpkg.com/@observablehq/plot@0.4.3/dist/plot.umd.min.js"])) + (link ([rel "stylesheet"] [type "text/css"] [href "../report.css"])) + (script ([src "../report.js"]))) + (body (h2 "Result page for the " ,(~a command) " command is not available right now.")))) + +(define (make-graph result-hash output? profile?) (define backend (hash-ref result-hash 'backend)) (define test (hash-ref result-hash 'test)) (define time (hash-ref result-hash 'time)) @@ -90,123 +84,120 @@ (define end-error (car end-errors)) - (write-html - `(html - (head (meta ([charset "utf-8"])) - (title "Result for " ,(~a (test-name test))) - ,@js-tex-include - (script ([src "https://unpkg.com/mathjs@4.4.2/dist/math.min.js"])) - (script ([src "https://unpkg.com/d3@6.7.0/dist/d3.min.js"])) - (script ([src "https://unpkg.com/@observablehq/plot@0.4.3/dist/plot.umd.min.js"])) - (link ([rel "stylesheet"] [type "text/css"] [href "../report.css"])) - (script ([src "../report.js"]))) - (body - ,(render-menu #:path ".." - (~a (test-name test)) - (if output? - (list '("Report" . "../index.html") '("Metrics" . "timeline.html")) - (list '("Metrics" . "timeline.html")))) - (div ([id "large"]) - ,(render-comparison - "Percentage Accurate" - (format-accuracy (errors-score start-error) repr-bits #:unit "%") - (format-accuracy (errors-score end-error) repr-bits #:unit "%") - #:title - (format "Minimum Accuracy: ~a → ~a" - (format-accuracy (apply max (map ulps->bits start-error)) repr-bits #:unit "%") - (format-accuracy (apply max (map ulps->bits end-error)) repr-bits #:unit "%"))) - ,(render-large "Time" (format-time time)) - ,(render-large "Alternatives" (~a (length end-exprs))) - ,(if (*pareto-mode*) - (render-large "Speedup" - (if speedup (~r speedup #:precision '(= 1)) "N/A") - "×" - #:title "Relative speed of fastest alternative that improves accuracy.") - "")) - ,(render-warnings warnings) - ,(render-specification test #:bogosity bogosity) - (figure ([id "graphs"]) - (h2 "Local Percentage Accuracy vs " - (span ([id "variables"])) - (a ((class "help-button float") [href ,(doc-url "report.html#graph")] + `(html + (head (meta ([charset "utf-8"])) + (title "Result for " ,(~a (test-name test))) + ,@js-tex-include + (script ([src "https://unpkg.com/mathjs@4.4.2/dist/math.min.js"])) + (script ([src "https://unpkg.com/d3@6.7.0/dist/d3.min.js"])) + (script ([src "https://unpkg.com/@observablehq/plot@0.4.3/dist/plot.umd.min.js"])) + (link ([rel "stylesheet"] [type "text/css"] [href "../report.css"])) + (script ([src "../report.js"]))) + (body + ,(render-menu #:path ".." + (~a (test-name test)) + (if output? + (list '("Report" . "../index.html") '("Metrics" . "timeline.html")) + (list '("Metrics" . "timeline.html")))) + (div ([id "large"]) + ,(render-comparison + "Percentage Accurate" + (format-accuracy (errors-score start-error) repr-bits #:unit "%") + (format-accuracy (errors-score end-error) repr-bits #:unit "%") + #:title + (format "Minimum Accuracy: ~a → ~a" + (format-accuracy (apply max (map ulps->bits start-error)) repr-bits #:unit "%") + (format-accuracy (apply max (map ulps->bits end-error)) repr-bits #:unit "%"))) + ,(render-large "Time" (format-time time)) + ,(render-large "Alternatives" (~a (length end-exprs))) + ,(if (*pareto-mode*) + (render-large "Speedup" + (if speedup (~r speedup #:precision '(= 1)) "N/A") + "×" + #:title "Relative speed of fastest alternative that improves accuracy.") + "")) + ,(render-warnings warnings) + ,(render-specification test #:bogosity bogosity) + (figure ([id "graphs"]) + (h2 "Local Percentage Accuracy vs " + (span ([id "variables"])) + (a ((class "help-button float") [href ,(doc-url "report.html#graph")] + [target "_blank"]) + "?")) + (svg) + (div ([id "functions"])) + (figcaption "The average percentage accuracy by input value. Horizontal axis shows " + "value of an input variable; the variable is choosen in the title. " + "Vertical axis is accuracy; higher is better. Red represent the original " + "program, while blue represents Herbie's suggestion. " + "These can be toggled with buttons below the plot. " + "The line is an average while dots represent individual samples.")) + (section ([id "cost-accuracy"] (class "section") [data-benchmark-name ,(~a (test-name test))]) + ; TODO : Show all Developer Target Accuracy + (h2 "Accuracy vs Speed" + (a ((class "help-button float") [href ,(doc-url "report.html#cost-accuracy")] [target "_blank"]) "?")) - (svg) - (div ([id "functions"])) - (figcaption "The average percentage accuracy by input value. Horizontal axis shows " - "value of an input variable; the variable is choosen in the title. " - "Vertical axis is accuracy; higher is better. Red represent the original " - "program, while blue represents Herbie's suggestion. " - "These can be toggled with buttons below the plot. " - "The line is an average while dots represent individual samples.")) - (section ([id "cost-accuracy"] (class "section") [data-benchmark-name ,(~a (test-name test))]) - ; TODO : Show all Developer Target Accuracy - (h2 "Accuracy vs Speed" - (a ((class "help-button float") [href ,(doc-url "report.html#cost-accuracy")] - [target "_blank"]) - "?")) - (div ((class "figure-row")) - (svg) - (div (p "Herbie found " ,(~a (length end-exprs)) " alternatives:") - (table (thead (tr (th "Alternative") - (th ((class "numeric")) "Accuracy") - (th ((class "numeric")) "Speedup"))) - (tbody)))) - (figcaption "The accuracy (vertical axis) and speed (horizontal axis) of each " - "alternatives. Up and to the right is better. The red square shows " - "the initial program, and each blue circle shows an alternative." - "The line shows the best available speed-accuracy tradeoffs.")) - ,(let-values ([(dropdown body) (render-program (alt-expr start-alt) ctx #:ident identifier)]) - `(section ([id "initial"] (class "programs")) - (h2 "Initial Program" + (div ((class "figure-row")) + (svg) + (div (p "Herbie found " ,(~a (length end-exprs)) " alternatives:") + (table (thead (tr (th "Alternative") + (th ((class "numeric")) "Accuracy") + (th ((class "numeric")) "Speedup"))) + (tbody)))) + (figcaption "The accuracy (vertical axis) and speed (horizontal axis) of each " + "alternatives. Up and to the right is better. The red square shows " + "the initial program, and each blue circle shows an alternative." + "The line shows the best available speed-accuracy tradeoffs.")) + ,(let-values ([(dropdown body) (render-program (alt-expr start-alt) ctx #:ident identifier)]) + `(section ([id "initial"] (class "programs")) + (h2 "Initial Program" + ": " + (span ((class "subhead")) + (data ,(format-accuracy (errors-score start-error) repr-bits #:unit "%")) + " accurate, " + (data "1.0×") + " speedup") + ,dropdown + ,(render-help "report.html#alternatives")) + ,body)) + ,@(for/list ([i (in-naturals 1)] + [expr end-exprs] + [errs end-errors] + [cost end-costs] + [history (hash-ref end 'end-histories)]) + (define-values (dropdown body) + (render-program expr ctx #:ident identifier #:instructions preprocessing)) + `(section ([id ,(format "alternative~a" i)] (class "programs")) + (h2 "Alternative " + ,(~a i) ": " (span ((class "subhead")) - (data ,(format-accuracy (errors-score start-error) repr-bits #:unit "%")) + (data ,(format-accuracy (errors-score errs) repr-bits #:unit "%")) " accurate, " - (data "1.0×") + (data ,(~r (/ (alt-cost start-alt repr) cost) #:precision '(= 1)) "×") " speedup") ,dropdown ,(render-help "report.html#alternatives")) - ,body)) - ,@(for/list ([i (in-naturals 1)] - [expr end-exprs] - [errs end-errors] - [cost end-costs] - [history (hash-ref end 'end-histories)]) - - (define-values (dropdown body) - (render-program expr ctx #:ident identifier #:instructions preprocessing)) - `(section ([id ,(format "alternative~a" i)] (class "programs")) - (h2 "Alternative " - ,(~a i) - ": " - (span ((class "subhead")) - (data ,(format-accuracy (errors-score errs) repr-bits #:unit "%")) - " accurate, " - (data ,(~r (/ (alt-cost start-alt repr) cost) #:precision '(= 1)) "×") - " speedup") - ,dropdown - ,(render-help "report.html#alternatives")) - ,body - (details (summary "Derivation") (ol ((class "history")) ,@history)))) - ,@(for/list ([i (in-naturals 1)] - [target (in-list targets)] - [target-error (in-list list-target-error)] - [target-cost (in-list list-target-cost)]) - (let-values ([(dropdown body) - (render-program (alt-expr (alt-analysis-alt target)) ctx #:ident identifier)]) - `(section - ([id ,(format "target~a" i)] (class "programs")) - (h2 "Developer Target " - ,(~a i) - ": " - (span ((class "subhead")) - (data ,(format-accuracy (errors-score target-error) repr-bits #:unit "%")) - " accurate, " - (data ,(~r (/ (alt-cost start-alt repr) target-cost) #:precision '(= 1)) "×") - " speedup") - ,dropdown - ,(render-help "report.html#target")) - ,body))) - ,(render-reproduction test))) - out)) + ,body + (details (summary "Derivation") (ol ((class "history")) ,@history)))) + ,@(for/list ([i (in-naturals 1)] + [target (in-list targets)] + [target-error (in-list list-target-error)] + [target-cost (in-list list-target-cost)]) + (let-values ([(dropdown body) + (render-program (alt-expr (alt-analysis-alt target)) ctx #:ident identifier)]) + `(section + ([id ,(format "target~a" i)] (class "programs")) + (h2 "Developer Target " + ,(~a i) + ": " + (span ((class "subhead")) + (data ,(format-accuracy (errors-score target-error) repr-bits #:unit "%")) + " accurate, " + (data ,(~r (/ (alt-cost start-alt repr) target-cost) #:precision '(= 1)) "×") + " speedup") + ,dropdown + ,(render-help "report.html#target")) + ,body))) + ,(render-reproduction test)))) diff --git a/src/reports/pages.rkt b/src/reports/pages.rkt index 30310a77b..3f9299b7d 100644 --- a/src/reports/pages.rkt +++ b/src/reports/pages.rkt @@ -5,7 +5,8 @@ "timeline.rkt" "plot.rkt" "make-graph.rkt" - "traceback.rkt") + "traceback.rkt" + "common.rkt") (provide all-pages make-page @@ -32,29 +33,26 @@ (define (make-page page out result-hash output? profile?) (match page - ["graph.html" (make-graph-html out result-hash output? profile?)] - ["timeline.html" (make-timeline-html out result-hash)] - ["timeline.json" (make-timeline-json out result-hash)] - ["points.json" (make-points out result-hash)])) + ["graph.html" (write-html (make-graph-html result-hash output? profile?) out)] + ["timeline.html" (write-html (make-timeline-html result-hash) out)] + ["timeline.json" (write-json (make-timeline-json result-hash) out)] + ["points.json" (write-json (make-points-json result-hash) out)])) -(define (make-graph-html out result-hash output? profile?) +(define (make-graph-html result-hash output? profile?) (define status (hash-ref result-hash 'status)) (match status ['success (define command (hash-ref result-hash 'command)) (match command - ["improve" (make-graph result-hash out output? profile?)] - [else (dummy-graph command out)])] - ['timeout (make-traceback result-hash out)] - ['failure (make-traceback result-hash out)] + ["improve" (make-graph result-hash output? profile?)] + [else (dummy-graph command)])] + ['timeout (make-traceback result-hash)] + ['failure (make-traceback result-hash)] [_ (error 'make-page "unknown result type ~a" status)])) -(define (make-points out result-hash) - (write-json (make-points-json result-hash) out)) +(define (make-timeline-json result-hash) + (hash-ref result-hash 'timeline)) -(define (make-timeline-json out result-hash) - (write-json (hash-ref result-hash 'timeline) out)) - -(define (make-timeline-html out result-hash) +(define (make-timeline-html result-hash) (define test (hash-ref result-hash 'test)) - (make-timeline (test-name test) (hash-ref result-hash 'timeline) out #:path "..")) + (make-timeline (test-name test) (hash-ref result-hash 'timeline) #:path "..")) diff --git a/src/reports/plot.rkt b/src/reports/plot.rkt index 928b809e9..f91bdb4fd 100644 --- a/src/reports/plot.rkt +++ b/src/reports/plot.rkt @@ -2,12 +2,11 @@ (require math/bigfloat math/flonum) -(require "../utils/common.rkt" +(require "../core/points.rkt" "../utils/float.rkt" "../core/programs.rkt" "../syntax/types.rkt" - "../syntax/syntax.rkt" "../syntax/read.rkt" "../utils/alternative.rkt" "../core/bsearch.rkt" @@ -105,12 +104,18 @@ ; bits of error for the output on each point ; ticks: array of size n where each entry is 13 or so tick values as [ordinal, string] pairs ; splitpoints: array with the ordinal splitpoints - `#hasheq((bits . ,bits) - (vars . ,(map symbol->string vars)) - (points . ,json-points) - (error . ,error-entries) - (ticks_by_varidx . ,ticks) - (splitpoints_by_varidx . ,splitpoints))) + (hasheq 'bits + bits + 'vars + (map symbol->string vars) + 'points + json-points + 'error + error-entries + 'ticks_by_varidx + ticks + 'splitpoints_by_varidx + splitpoints)) ;; Repr conversions diff --git a/src/reports/timeline.rkt b/src/reports/timeline.rkt index 63bc37b15..bf3cc3e27 100644 --- a/src/reports/timeline.rkt +++ b/src/reports/timeline.rkt @@ -15,20 +15,18 @@ ;; This first part handles timelines for a single Herbie run -(define (make-timeline name timeline out #:info [info #f] #:path [path "."]) - (write-html - `(html (head (meta ([charset "utf-8"])) - (title "Metrics for " ,(~a name)) - (link ([rel "stylesheet"] [type "text/css"] - [href ,(if info "report.css" "../report.css")])) - (script ([src ,(if info "report.js" "../report.js")]))) - (body ,(render-menu (~a name) - #:path path - (if info `(("Report" . "index.html")) `(("Details" . "graph.html")))) - ,(if info (render-about info) "") - ,(render-timeline timeline) - ,(render-profile))) - out)) +(define (make-timeline name timeline #:info [info #f] #:path [path "."]) + `(html (head (meta ([charset "utf-8"])) + (title "Metrics for " ,(~a name)) + (link ([rel "stylesheet"] [type "text/css"] + [href ,(if info "report.css" "../report.css")])) + (script ([src ,(if info "report.js" "../report.js")]))) + (body ,(render-menu (~a name) + #:path path + (if info `(("Report" . "index.html")) `(("Details" . "graph.html")))) + ,(if info (render-about info) "") + ,(render-timeline timeline) + ,(render-profile)))) (define/contract (render-timeline timeline) (-> timeline? xexpr?) diff --git a/src/reports/traceback.rkt b/src/reports/traceback.rkt index 17ccc2df5..90c174b06 100644 --- a/src/reports/traceback.rkt +++ b/src/reports/traceback.rkt @@ -7,13 +7,13 @@ (provide make-traceback) -(define (make-traceback result-hash out) +(define (make-traceback result-hash) (match (hash-ref result-hash 'status) - ['timeout (render-timeout result-hash out)] - ['failure (render-failure result-hash out)] + ['timeout (render-timeout result-hash)] + ['failure (render-failure result-hash)] [status (error 'make-traceback "unexpected status ~a" status)])) -(define (render-failure result-hash out) +(define (render-failure result-hash) (define test (hash-ref result-hash 'test)) (define warnings (hash-ref result-hash 'warnings)) (define backend (hash-ref result-hash 'backend)) @@ -21,27 +21,25 @@ ; unpack the exception (match-define (list 'exn type msg url extra traceback) backend) - (write-html - `(html - (head (meta ((charset "utf-8"))) - (title "Exception for " ,(~a (test-name test))) - (link ((rel "stylesheet") (type "text/css") (href "../report.css"))) - ,@js-tex-include - (script ([src "../report.js"]))) - (body ,(render-menu (~a (test-name test)) - (list '("Report" . "../index.html") '("Metrics" . "timeline.html"))) - ,(render-warnings warnings) - ,(render-specification test) - ,(if type - `(section ([id "user-error"] (class "error")) - (h2 ,(~a msg) " " (a ([href ,url]) "(more)")) - ,(if (eq? type 'syntax) (render-syntax-errors msg extra) "")) - "") - ,(if type - "" - `(,@(render-reproduction test #:bug? #t) - (section ([id "backtrace"]) (h2 "Backtrace") ,(render-traceback msg traceback)))))) - out)) + `(html + (head (meta ((charset "utf-8"))) + (title "Exception for " ,(~a (test-name test))) + (link ((rel "stylesheet") (type "text/css") (href "../report.css"))) + ,@js-tex-include + (script ([src "../report.js"]))) + (body ,(render-menu (~a (test-name test)) + (list '("Report" . "../index.html") '("Metrics" . "timeline.html"))) + ,(render-warnings warnings) + ,(render-specification test) + ,(if type + `(section ([id "user-error"] (class "error")) + (h2 ,(~a msg) " " (a ([href ,url]) "(more)")) + ,(if (eq? type 'syntax) (render-syntax-errors msg extra) "")) + "") + ,(if type + "" + `(,@(render-reproduction test #:bug? #t) + (section ([id "backtrace"]) (h2 "Backtrace") ,(render-traceback msg traceback))))))) (define (render-syntax-errors msg locations) `(table (thead (th ([colspan "2"]) ,msg) (th "L") (th "C")) @@ -63,22 +61,20 @@ `(tr (td ((class "procedure")) ,(~a name)) (td ,(~a file)) (td ,(~a line)) (td ,(~a col)))] [#f `(tr (td ((class "procedure")) ,(~a name)) (td ([colspan "3"]) "unknown"))]))))) -(define (render-timeout result-hash out) +(define (render-timeout result-hash) (define test (hash-ref result-hash 'test)) (define time (hash-ref result-hash 'time)) (define warnings (hash-ref result-hash 'warnings)) - (write-html - `(html (head (meta ((charset "utf-8"))) - (title "Exception for " ,(~a (test-name test))) - (link ((rel "stylesheet") (type "text/css") (href "../report.css"))) - ,@js-tex-include - (script ([src "../report.js"]))) - (body ,(render-menu (~a (test-name test)) - (list '("Report" . "../index.html") '("Metrics" . "timeline.html"))) - ,(render-warnings warnings) - ,(render-specification test) - (section ([id "user-error"] (class "error")) - (h2 "Timeout after " ,(format-time time)) - (p "Use the " (code "--timeout") " flag to change the timeout.")))) - out)) + `(html (head (meta ((charset "utf-8"))) + (title "Exception for " ,(~a (test-name test))) + (link ((rel "stylesheet") (type "text/css") (href "../report.css"))) + ,@js-tex-include + (script ([src "../report.js"]))) + (body ,(render-menu (~a (test-name test)) + (list '("Report" . "../index.html") '("Metrics" . "timeline.html"))) + ,(render-warnings warnings) + ,(render-specification test) + (section ([id "user-error"] (class "error")) + (h2 "Timeout after " ,(format-time time)) + (p "Use the " (code "--timeout") " flag to change the timeout."))))) From 5cc08c50a13c35871e75d1a34cc97c7d54cbf4ea Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Thu, 22 Aug 2024 11:14:19 -0600 Subject: [PATCH 61/64] Move generate-page to server.rkt --- src/api/demo.rkt | 41 +++------------------------------- src/api/server.rkt | 52 ++++++++++++++++++++++++++++++++++++++++++- src/reports/pages.rkt | 17 ++++++-------- src/reports/plot.rkt | 3 +-- 4 files changed, 62 insertions(+), 51 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index b945c38a1..406e562a1 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -18,8 +18,7 @@ "../config.rkt" "../syntax/read.rkt" "../utils/errors.rkt") -(require - "../syntax/sugar.rkt" +(require "../syntax/sugar.rkt" "../core/points.rkt" "../api/sandbox.rkt") (require "datafile.rkt" @@ -30,9 +29,7 @@ (provide run-demo) -(define *demo?* (make-parameter false)) (define *demo-prefix* (make-parameter "/")) -(define *demo-output* (make-parameter false)) (define *demo-log* (make-parameter false)) (define (add-prefix url) @@ -71,41 +68,9 @@ [("results.json") generate-report])) (define (generate-page req result-hash page) - (define path (first (string-split (url->string (request-uri req)) "/"))) + ; TODO pass in job-id instead of job-results (cond - [(set-member? (all-pages result-hash) page) - ;; Write page contents to disk - (when (*demo-output*) - (make-directory (build-path (*demo-output*) path)) - (for ([page (all-pages result-hash)]) - (call-with-output-file - (build-path (*demo-output*) path page) - (λ (out) - (with-handlers ([exn:fail? (page-error-handler result-hash page out)]) - (make-page page out result-hash (*demo-output*) #f))))) - (define link (path-element->string (last (explode-path path)))) - (define data (get-table-data-from-hash result-hash link)) - (define data-file (build-path (*demo-output*) "results.json")) - (define html-file (build-path (*demo-output*) "index.html")) - (define info - (if (file-exists? data-file) - (let ([info (read-datafile data-file)]) - (struct-copy report-info info [tests (cons data (report-info-tests info))])) - (make-report-info (list data) - #:seed (get-seed) - #:note (if (*demo?*) "Web demo results" "")))) - (define tmp-file (build-path (*demo-output*) "results.tmp")) - (write-datafile tmp-file info) - (rename-file-or-directory tmp-file data-file #t) - (copy-file (web-resource "report.html") html-file #t)) - (response 200 - #"OK" - (current-seconds) - #"text" - (list (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count))))) - (λ (out) - (with-handlers ([exn:fail? (page-error-handler result-hash page out)]) - (make-page page out result-hash (*demo-output*) #f))))] + [(check-and-send req page)] [else (next-dispatcher)])) (define (generate-report req) diff --git a/src/api/server.rkt b/src/api/server.rkt index b0d619c15..9fdea5e34 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -3,6 +3,8 @@ (require openssl/sha1) (require (only-in xml write-xexpr) json) +(require net/url) +(require web-server/http) (require "sandbox.rkt" "../core/points.rkt" @@ -17,6 +19,8 @@ "../utils/common.rkt" "../utils/errors.rkt" "../utils/float.rkt" + "../reports/pages.rkt" + "datafile.rkt" (submod "../utils/timeline.rkt" debug)) (provide make-path @@ -29,7 +33,13 @@ create-job start-job wait-for-job - start-job-server) + start-job-server + check-and-send + *demo?* + *demo-output*) + +(define *demo?* (make-parameter false)) +(define *demo-output* (make-parameter false)) ; verbose logging for debugging (define verbose #f) ; Maybe change to log-level and use 'verbose? @@ -50,6 +60,46 @@ #:timeline-disabled? [timeline-disabled? #f]) (herbie-command command test seed pcontext profile? timeline-disabled?)) +(define (check-and-send req page) + (define path (first (string-split (url->string (request-uri req)) "/"))) + (define job-id (first (string-split path "."))) + (define result-hash (get-results-for job-id)) + (cond + [(set-member? (all-pages result-hash) page) + ;; Write page contents to disk + (when (*demo-output*) + (write-results-to-disk result-hash path)) + (response 200 + #"OK" + (current-seconds) + #"text" + (list (header #"X-Job-Count" (string->bytes/utf-8 (~a (job-count))))) + (λ (out) + (with-handlers ([exn:fail? (page-error-handler result-hash page out)]) + (make-page page out result-hash (*demo-output*) #f))))] + [else #f])) + +(define (write-results-to-disk result-hash path) + (make-directory (build-path (*demo-output*) path)) + (for ([page (all-pages result-hash)]) + (call-with-output-file (build-path (*demo-output*) path page) + (λ (out) + (with-handlers ([exn:fail? (page-error-handler result-hash page out)]) + (make-page page out result-hash (*demo-output*) #f))))) + (define link (path-element->string (last (explode-path path)))) + (define data (get-table-data-from-hash result-hash link)) + (define data-file (build-path (*demo-output*) "results.json")) + (define html-file (build-path (*demo-output*) "index.html")) + (define info + (if (file-exists? data-file) + (let ([info (read-datafile data-file)]) + (struct-copy report-info info [tests (cons data (report-info-tests info))])) + (make-report-info (list data) #:seed (get-seed) #:note (if (*demo?*) "Web demo results" "")))) + (define tmp-file (build-path (*demo-output*) "results.tmp")) + (write-datafile tmp-file info) + (rename-file-or-directory tmp-file data-file #t) + (copy-file (web-resource "report.html") html-file #t)) + ; computes the path used for server URLs (define (make-path id) (format "~a.~a" id *herbie-commit*)) diff --git a/src/reports/pages.rkt b/src/reports/pages.rkt index 3f9299b7d..5939b5bbe 100644 --- a/src/reports/pages.rkt +++ b/src/reports/pages.rkt @@ -34,8 +34,12 @@ (define (make-page page out result-hash output? profile?) (match page ["graph.html" (write-html (make-graph-html result-hash output? profile?) out)] - ["timeline.html" (write-html (make-timeline-html result-hash) out)] - ["timeline.json" (write-json (make-timeline-json result-hash) out)] + ["timeline.html" + (write-html (make-timeline (test-name (hash-ref result-hash 'test)) + (hash-ref result-hash 'timeline) + #:path "..") + out)] + ["timeline.json" (write-json (hash-ref result-hash 'timeline) out)] ["points.json" (write-json (make-points-json result-hash) out)])) (define (make-graph-html result-hash output? profile?) @@ -48,11 +52,4 @@ [else (dummy-graph command)])] ['timeout (make-traceback result-hash)] ['failure (make-traceback result-hash)] - [_ (error 'make-page "unknown result type ~a" status)])) - -(define (make-timeline-json result-hash) - (hash-ref result-hash 'timeline)) - -(define (make-timeline-html result-hash) - (define test (hash-ref result-hash 'test)) - (make-timeline (test-name test) (hash-ref result-hash 'timeline) #:path "..")) + [_ (error 'make-graph-html "unknown result type ~a" status)])) diff --git a/src/reports/plot.rkt b/src/reports/plot.rkt index f91bdb4fd..5488e88f5 100644 --- a/src/reports/plot.rkt +++ b/src/reports/plot.rkt @@ -2,8 +2,7 @@ (require math/bigfloat math/flonum) -(require - "../core/points.rkt" +(require "../core/points.rkt" "../utils/float.rkt" "../core/programs.rkt" "../syntax/types.rkt" From f7673ddec05928c52aa929a3be17c9dd47b5d131 Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Thu, 22 Aug 2024 11:26:07 -0600 Subject: [PATCH 62/64] Add server-check-on function. --- src/api/demo.rkt | 10 +++++----- src/api/server.rkt | 15 ++++++++++++--- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/src/api/demo.rkt b/src/api/demo.rkt index 406e562a1..4b39079e3 100644 --- a/src/api/demo.rkt +++ b/src/api/demo.rkt @@ -41,9 +41,9 @@ (and (not (and (*demo-output*) ; If we've already saved to disk, skip this job (directory-exists? (build-path (*demo-output*) x)))) (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) - (and m (get-results-for (second m)))))) + (and m (server-check-on (second m)))))) (λ (x) - (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) (get-results-for (if m (second m) x))))) + (let ([m (regexp-match #rx"^([0-9a-f]+)\\.[0-9a-f.]+" x)]) (server-check-on (if m (second m) x))))) (define-bidi-match-expander hash-arg hash-arg/m hash-arg/m) @@ -67,10 +67,10 @@ [((hash-arg) (string-arg)) generate-page] [("results.json") generate-report])) -(define (generate-page req result-hash page) - ; TODO pass in job-id instead of job-results +(define (generate-page req job-id page) + (define path (first (string-split (url->string (request-uri req)) "/"))) (cond - [(check-and-send req page)] + [(check-and-send path job-id page)] [else (next-dispatcher)])) (define (generate-report req) diff --git a/src/api/server.rkt b/src/api/server.rkt index 9fdea5e34..ead92475b 100644 --- a/src/api/server.rkt +++ b/src/api/server.rkt @@ -26,6 +26,7 @@ (provide make-path get-improve-table-data make-improve-result + server-check-on get-results-for get-timeline-for job-count @@ -60,9 +61,8 @@ #:timeline-disabled? [timeline-disabled? #f]) (herbie-command command test seed pcontext profile? timeline-disabled?)) -(define (check-and-send req page) - (define path (first (string-split (url->string (request-uri req)) "/"))) - (define job-id (first (string-split path "."))) +;; TODO move these side worker/manager +(define (check-and-send path job-id page) (define result-hash (get-results-for job-id)) (cond [(set-member? (all-pages result-hash) page) @@ -117,6 +117,13 @@ (log "Getting timeline for job: ~a.\n" job-id) (place-channel-get a)) +; Returns #f if there is no job returns the job-id if there is a completed job. +(define (server-check-on job-id) + (define-values (a b) (place-channel)) + (place-channel-put manager (list 'check job-id b)) + (log "Checking on: ~a.\n" job-id) + (place-channel-get a)) + (define (get-improve-table-data) (define-values (a b) (place-channel)) (place-channel-put manager (list 'improve b)) @@ -301,6 +308,8 @@ [else (log "Job complete, no timeline, send result.\n") (place-channel-put handler (hash-ref completed-work job-id #f))])] + [(list 'check job-id handler) + (place-channel-put handler (if (hash-has-key? completed-work job-id) job-id #f))] ; Returns the current count of working workers. [(list 'count handler) (place-channel-put handler (hash-count busy-workers))] ; Retreive the improve results for results.json From a5290d669d995517ffc8dbb243f619be40d869ca Mon Sep 17 00:00:00 2001 From: zane <39070793+zaneenders@users.noreply.github.com> Date: Tue, 27 Aug 2024 10:25:16 -0600 Subject: [PATCH 63/64] Fix make-timeline call sites. --- infra/merge.rkt | 6 ++++-- src/api/run.rkt | 10 ++++++---- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/infra/merge.rkt b/infra/merge.rkt index 9498e58cb..c68d93a8c 100644 --- a/infra/merge.rkt +++ b/infra/merge.rkt @@ -5,7 +5,8 @@ "../src/utils/profile.rkt" "../src/api/datafile.rkt" "../src/reports/timeline.rkt" - "../src/syntax/load-plugin.rkt") + "../src/syntax/load-plugin.rkt" + "../src/reports/common.rkt") (define (merge-timelines outdir . dirs) (define tls @@ -21,7 +22,8 @@ (curry write-json joint-tl)) (call-with-output-file (build-path outdir "timeline.html") #:exists 'replace - (λ (out) (make-timeline "Herbie run" joint-tl out #:info info)))) + (λ (out) + (write-html (make-timeline "Herbie run" joint-tl #:info info) out)))) (define (merge-profiles outdir . dirs) (define pfs diff --git a/src/api/run.rkt b/src/api/run.rkt index 7d9b6f4a0..25a0f8190 100644 --- a/src/api/run.rkt +++ b/src/api/run.rkt @@ -11,7 +11,8 @@ "../core/sampling.rkt" "../reports/pages.rkt" "thread-pool.rkt" - "../reports/timeline.rkt") + "../reports/timeline.rkt" + "../reports/common.rkt") (provide make-report rerun-report @@ -84,9 +85,10 @@ (define profile (merge-profile-jsons (read-json-files info dir "profile.json"))) (call-with-output-file (build-path dir "profile.json") (curry write-json profile) #:exists 'replace) - (call-with-output-file (build-path dir "timeline.html") - #:exists 'replace - (λ (out) (make-timeline "Herbie run" timeline out #:info info #:path "."))) + (call-with-output-file + (build-path dir "timeline.html") + #:exists 'replace + (λ (out) (write-html (make-timeline "Herbie run" timeline #:info info #:path ".") out))) ; Delete old files (let* ([expected-dirs (map string->path From b8ef411b72d90f7d1676b15f8e818444b8c7b4d6 Mon Sep 17 00:00:00 2001 From: Pavel Panchekha Date: Tue, 27 Aug 2024 22:37:45 -0600 Subject: [PATCH 64/64] Fix bug in exact powers --- src/core/taylor.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core/taylor.rkt b/src/core/taylor.rkt index db76a25c4..8c3138ad3 100644 --- a/src/core/taylor.rkt +++ b/src/core/taylor.rkt @@ -44,7 +44,9 @@ [(list 'pow base (app deref 1/2)) `(sqrt ,base)] [(list 'pow base (app deref 1/3)) `(cbrt ,base)] [(list 'pow base (app deref 2/3)) `(cbrt (* ,base ,base))] - [(list 'pow base (and power (app deref (? exact-integer?)))) `(pow base power)] + [(list 'pow base power) + #:when (exact-integer? (deref power)) + `(pow ,base ,power)] [(list 'pow base power) `(exp (* ,power (log ,base)))] [(list 'tan arg) `(/ (sin ,arg) (cos ,arg))] [(list 'cosh arg) `(* 1/2 (+ (exp ,arg) (/ 1 (exp ,arg))))]