From 04dd72be9bea2624476923a7b4cb6310c6550f30 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 9 Aug 2022 17:35:35 -0700 Subject: [PATCH 001/338] Rewrite boolean forms in terms of Qi to reduce core forms This also makes the elementary boolean combinators AND and OR return truthy and falsy values instead of just true and false. --- qi-lib/flow/compiler.rkt | 14 +++++------ qi-test/tests/flow.rkt | 51 +++++++++++++++++++++------------------- 2 files changed, 33 insertions(+), 32 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 823452eb4..9c7d1c0ab 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -48,21 +48,19 @@ ;;; Special words [((~datum one-of?) v:expr ...) - #'(compose - ->boolean - (curryr member (list v ...)))] + #'(qi0->racket (~> (member (list v ...)) ->boolean))] [((~datum all) onex:clause) - #`(give (curry andmap (qi0->racket onex)))] + #`(qi0->racket (~> (>< onex) AND))] [((~datum any) onex:clause) - #'(give (curry ormap (qi0->racket onex)))] + #'(qi0->racket (~> (>< onex) OR))] [((~datum none) onex:clause) #'(qi0->racket (not (any onex)))] [((~datum and) onex:clause ...) - #'(conjoin (qi0->racket onex) ...)] + #'(qi0->racket (~> (-< onex ...) AND))] [((~datum or) onex:clause ...) - #'(disjoin (qi0->racket onex) ...)] + #'(qi0->racket (~> (-< onex ...) OR))] [((~datum not) onex:clause) - #'(negate (qi0->racket onex))] + #'(qi0->racket (~> onex NOT))] [((~datum gen) ex:expr ...) #'(λ _ (values ex ...))] [(~or* (~datum NOT) (~datum !)) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index d61280422..c611096a6 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -76,8 +76,11 @@ (check-true ((☯ (and (> 5) (< 10))) 6)) (check-false ((☯ (and (> 5) (< 10))) 4)) (check-false ((☯ (and (> 5) (< 10))) 14)) - (check-false ((☯ (and number? positive?)) "abc") - "short-circuiting")) + ;; TODO: this doesn't short-circuit anymore + ;; review shortcircuiting on all boolean forms + ;; (check-false ((☯ (and number? positive?)) "abc") + ;; "short-circuiting") + ) (test-suite "or (disjoin)" (check-true ((☯ (or positive? odd?)) 6)) @@ -183,19 +186,19 @@ (test-suite "all?" (check-true ((☯ all?)) "design: should this produce no values instead?") - (check-true ((☯ all?) 3)) - (check-false ((☯ all?) #f)) - (check-true ((☯ all?) 3 5 7)) - (check-false ((☯ all?) 3 #f 5))) + (check-equal? ((☯ all?) 3) 3) + (check-equal? ((☯ all?) #f) #f) + (check-equal? ((☯ all?) 3 5 7) 7) + (check-equal? ((☯ all?) 3 #f 5) #f)) (test-suite "any?" (check-false ((☯ any?)) "design: should this produce no values instead?") - (check-true ((☯ any?) 3)) - (check-false ((☯ any?) #f)) - (check-true ((☯ any?) 3 5 7)) - (check-true ((☯ any?) 3 #f 5)) - (check-true ((☯ any?) #f #f 5)) - (check-false ((☯ any?) #f #f #f))) + (check-equal? ((☯ any?) 3) 3) + (check-equal? ((☯ any?) #f) #f) + (check-equal? ((☯ any?) 3 5 7) 3) + (check-equal? ((☯ any?) 3 #f 5) 3) + (check-equal? ((☯ any?) #f #f 5) 5) + (check-equal? ((☯ any?) #f #f #f) #f)) (test-suite "none?" (check-false ((☯ none?) 3)) @@ -261,20 +264,20 @@ "elementary boolean gates" (test-suite "AND" - (check-false ((☯ AND) #f)) - (check-true ((☯ AND) 3)) - (check-true ((☯ AND) 3 5 7)) - (check-false ((☯ AND) 3 #f 5)) - (check-false ((☯ AND) #f #f 5)) - (check-false ((☯ AND) #f #f #f))) + (check-equal? ((☯ AND) #f) #f) + (check-equal? ((☯ AND) 3) 3) + (check-equal? ((☯ AND) 3 5 7) 7) + (check-equal? ((☯ AND) 3 #f 5) #f) + (check-equal? ((☯ AND) #f #f 5) #f) + (check-equal? ((☯ AND) #f #f #f) #f)) (test-suite "OR" - (check-false ((☯ OR) #f)) - (check-true ((☯ OR) 3)) - (check-true ((☯ OR) 3 5 7)) - (check-true ((☯ OR) 3 #f 5)) - (check-true ((☯ OR) #f #f 5)) - (check-false ((☯ OR) #f #f #f))) + (check-equal? ((☯ OR) #f) #f) + (check-equal? ((☯ OR) 3) 3) + (check-equal? ((☯ OR) 3 5 7) 3) + (check-equal? ((☯ OR) 3 #f 5) 3) + (check-equal? ((☯ OR) #f #f 5) 5) + (check-equal? ((☯ OR) #f #f #f) #f)) (test-suite "NOT" (check-false ((☯ NOT) 3)) From 0d729eaa421dce8ada65952f35596a60cffc6f57 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 16:39:18 -0700 Subject: [PATCH 002/338] reduce more boolean forms --- qi-lib/flow/compiler.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 9c7d1c0ab..dcb432334 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -79,9 +79,9 @@ #'(qi0->racket (~> XOR NOT))] [e:and%-form (and%-parser #'e)] [e:or%-form (or%-parser #'e)] - [(~datum any?) #'any?] - [(~datum all?) #'all?] - [(~datum none?) #'none?] + [(~datum any?) #'(qi0->racket OR)] + [(~datum all?) #'(qi0->racket AND)] + [(~datum none?) #'(qi0->racket (~> any? NOT))] [(~or* (~datum ▽) (~datum collect)) #'list] [e:sep-form (sep-parser #'e)] From 6587f290a3d4604a9874e0ad4acbe6f3953fb736 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 16:41:13 -0700 Subject: [PATCH 003/338] reduce `pass` --- qi-lib/flow/compiler.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index dcb432334..78adece5a 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -558,9 +558,10 @@ the DSL. (define (pass-parser stx) (syntax-parse stx [_:id - #'filter-values] + #'(qi0->racket (~> (group 1 (clos (if _ ⏚)) _) + ><))] [(_ onex:clause) - #'(curry filter-values (qi0->racket onex))])) + #'(qi0->racket (>< (if onex _ ⏚)))])) (define (fold-left-parser stx) (syntax-parse stx From 80c7ce5ea47ea39528d8e88458843f4f04921b7d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 17:38:13 -0700 Subject: [PATCH 004/338] reduce partition to sieve (restore original implementation) --- qi-lib/flow/compiler.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 78adece5a..3be316a44 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -424,9 +424,8 @@ the DSL. #'(qi0->racket ground)] [(_ [cond:clause body:clause]) #'(qi0->racket (~> (pass cond) body))] - [(_ [cond:clause body:clause] ...+) - #:with c+bs #'(list (cons (qi0->racket cond) (qi0->racket body)) ...) - #'(qi0->racket (~>> (partition-values c+bs)))])) + [(_ [cond:clause body:clause] [conds:clause bodies:clause] ...+) + #'(qi0->racket (sieve cond body (partition [conds bodies] ...)))])) (define (try-parser stx) (syntax-parse stx From e9099e1238b5a5bf7a2ae9af7a37d8ba14653bc3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 17:53:25 -0700 Subject: [PATCH 005/338] reduce `live?` to `count` --- qi-lib/flow/compiler.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 3be316a44..678a121bd 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -145,7 +145,7 @@ [(~datum count) #'(λ args (length args))] [(~datum live?) - #'(λ args (not (null? args)))] + #'(qi0->racket (~> count (> 0)))] [((~datum rectify) v:expr ...) #'(qi0->racket (if live? _ (gen v ...)))] From 9187531c34060be356f1229a9be791f2a2dac95e Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 19:10:46 -0700 Subject: [PATCH 006/338] Support naive "fanout" behavior in `-<` when used as an identifier --- qi-lib/flow/compiler.rkt | 22 ++++++++++++++-------- qi-lib/flow/syntax.rkt | 7 +++++++ qi-test/tests/flow.rkt | 3 +++ 3 files changed, 24 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 678a121bd..70a885191 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -100,14 +100,9 @@ [((~or* (~datum ==) (~datum relay)) onex:clause ...) #'(relay (qi0->racket onex) ...)] [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) - (with-syntax ([len #`#,(length (syntax->list #'(onex ...)))]) - #'(qi0->racket (group len (== onex ...) rest-onex) ))] - [((~or* (~datum -<) (~datum tee)) onex:clause ...) - #'(λ args - (apply values - (append (values->list - (apply (qi0->racket onex) args)) - ...)))] + #:with len #`#,(length (syntax->list #'(onex ...))) + #'(qi0->racket (group len (== onex ...) rest-onex) )] + [e:tee-form (tee-parser #'e)] [e:select-form (select-parser #'e)] [e:block-form (block-parser #'e)] [((~datum bundle) (n:number ...) @@ -541,6 +536,17 @@ the DSL. #'(qi0->racket (-< (~> sidex ⏚) _))])) + (define (tee-parser stx) + (syntax-parse stx + [((~or* (~datum -<) (~datum tee)) onex:clause ...) + #'(λ args + (apply values + (append (values->list + (apply (qi0->racket onex) args)) + ...)))] + [(~or* (~datum -<) (~datum tee)) + #'repeat-values])) + (define (amp-parser stx) (syntax-parse stx [_:id diff --git a/qi-lib/flow/syntax.rkt b/qi-lib/flow/syntax.rkt index d8edb92d9..ea4ce6baa 100644 --- a/qi-lib/flow/syntax.rkt +++ b/qi-lib/flow/syntax.rkt @@ -12,6 +12,7 @@ feedback-form side-effect-form amp-form + tee-form input-alias if-form pass-form @@ -115,6 +116,12 @@ See comments in flow.rkt for more details. (pattern ((~or* (~datum ><) (~datum amp)) arg ...))) +(define-syntax-class tee-form + (pattern + (~or* (~datum -<) (~datum tee))) + (pattern + ((~or* (~datum -<) (~datum tee)) arg ...))) + (define-syntax-class pass-form (pattern (~datum pass)) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index c611096a6..0fb2ef655 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -431,6 +431,9 @@ "a")) (test-suite "-<" + (check-equal? ((☯ (~> -< ▽)) + 3 1 2) + (list 1 2 1 2 1 2)) (check-equal? ((☯ (~> (-< sqr add1) ▽)) 5) (list 25 6)) From d15e2cd235e559444489d09bf41af27e0256195a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 19:12:24 -0700 Subject: [PATCH 007/338] reduce `fanout` to `-<` --- qi-lib/flow/compiler.rkt | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 70a885191..ddfefd30d 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -479,18 +479,14 @@ the DSL. (define (fanout-parser stx) (syntax-parse stx - [_:id #'repeat-values] + [_:id #'(qi0->racket -<)] [(_ n:number) ;; a slightly more efficient compile-time implementation ;; for literally indicated N - #`(λ args - (apply values - (append #,@(make-list (syntax->datum #'n) 'args))) )] + #:with list-of-n-blanks #`#,(make-list (syntax->datum #'n) #'_) + #`(qi0->racket (-< . list-of-n-blanks))] [(_ n:expr) - #'(lambda args - (apply values - (apply append - (make-list n args))))])) + #'(qi0->racket (~> (-< (gen n) _) -<))])) (define (feedback-parser stx) (syntax-parse stx From 520931602f427ffd34144987d34232a5f91fc4f0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 19:57:25 -0700 Subject: [PATCH 008/338] support `amp` behavior when relay is used in identifier form --- qi-lib/flow/compiler.rkt | 10 ++++++++-- qi-lib/flow/syntax.rkt | 7 +++++++ 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index ddfefd30d..9da1ab86e 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -97,8 +97,7 @@ [e:right-threading-form (right-threading-parser #'e)] [(~or* (~datum X) (~datum crossover)) #'(qi0->racket (~> ▽ reverse △))] - [((~or* (~datum ==) (~datum relay)) onex:clause ...) - #'(relay (qi0->racket onex) ...)] + [e:relay-form (relay-parser #'e)] [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) #:with len #`#,(length (syntax->list #'(onex ...))) #'(qi0->racket (group len (== onex ...) rest-onex) )] @@ -543,6 +542,13 @@ the DSL. [(~or* (~datum -<) (~datum tee)) #'repeat-values])) + (define (relay-parser stx) + (syntax-parse stx + [((~or* (~datum ==) (~datum relay)) onex:clause ...) + #'(relay (qi0->racket onex) ...)] + [(~or* (~datum ==) (~datum relay)) + #'map-values])) + (define (amp-parser stx) (syntax-parse stx [_:id diff --git a/qi-lib/flow/syntax.rkt b/qi-lib/flow/syntax.rkt index ea4ce6baa..9d188db93 100644 --- a/qi-lib/flow/syntax.rkt +++ b/qi-lib/flow/syntax.rkt @@ -12,6 +12,7 @@ feedback-form side-effect-form amp-form + relay-form tee-form input-alias if-form @@ -116,6 +117,12 @@ See comments in flow.rkt for more details. (pattern ((~or* (~datum ><) (~datum amp)) arg ...))) +(define-syntax-class relay-form + (pattern + (~or* (~datum ==) (~datum relay))) + (pattern + ((~or* (~datum ==) (~datum relay)) arg ...))) + (define-syntax-class tee-form (pattern (~or* (~datum -<) (~datum tee))) From 9ba29c1d1b61da0ce7c94bf423aaaf8de0b1385a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 10 Aug 2022 19:59:02 -0700 Subject: [PATCH 009/338] reduce `amp` to `relay` --- qi-lib/flow/compiler.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 9da1ab86e..6d8390f53 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -552,9 +552,9 @@ the DSL. (define (amp-parser stx) (syntax-parse stx [_:id - #'map-values] + #'(qi0->racket ==)] [(_ onex:clause) - #'(curry map-values (qi0->racket onex))] + #'(qi0->racket (~> (-< (gen (qi0->racket onex)) _) ==))] [(_ onex0:clause onex:clause ...) (report-syntax-error 'amp From 20c12156f1d215f33c3022655bcf5565769392d4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 11 Aug 2022 18:12:28 -0700 Subject: [PATCH 010/338] comment out another test for short-circuiting --- qi-test/tests/flow.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 0fb2ef655..6118e00c1 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -94,8 +94,11 @@ equal? (~> (>< string->number) =))) "5" "6")) - (check-true ((☯ (or string? positive?)) "abc") - "short-circuiting")) + ;; TODO: this doesn't short-circuit anymore + ;; review shortcircuiting on all boolean forms + ;; (check-true ((☯ (or string? positive?)) "abc") + ;; "short-circuiting") + ) (test-suite "not (predicate negation)" (check-true ((☯ (not positive?)) -5)) From 007b98e00d2e8ca6d519e0c4a65cee04ad9d5455 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 11 Aug 2022 18:41:53 -0700 Subject: [PATCH 011/338] restore `and` and `or` as (short-circuiting) core forms --- qi-lib/flow/compiler.rkt | 4 ++-- qi-test/tests/flow.rkt | 14 ++++---------- 2 files changed, 6 insertions(+), 12 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 6d8390f53..16b49a100 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -56,9 +56,9 @@ [((~datum none) onex:clause) #'(qi0->racket (not (any onex)))] [((~datum and) onex:clause ...) - #'(qi0->racket (~> (-< onex ...) AND))] + #'(conjoin (qi0->racket onex) ...)] [((~datum or) onex:clause ...) - #'(qi0->racket (~> (-< onex ...) OR))] + #'(disjoin (qi0->racket onex) ...)] [((~datum not) onex:clause) #'(qi0->racket (~> onex NOT))] [((~datum gen) ex:expr ...) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 6118e00c1..472711540 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -76,11 +76,8 @@ (check-true ((☯ (and (> 5) (< 10))) 6)) (check-false ((☯ (and (> 5) (< 10))) 4)) (check-false ((☯ (and (> 5) (< 10))) 14)) - ;; TODO: this doesn't short-circuit anymore - ;; review shortcircuiting on all boolean forms - ;; (check-false ((☯ (and number? positive?)) "abc") - ;; "short-circuiting") - ) + (check-false ((☯ (and number? positive?)) "abc") + "short-circuiting")) (test-suite "or (disjoin)" (check-true ((☯ (or positive? odd?)) 6)) @@ -94,11 +91,8 @@ equal? (~> (>< string->number) =))) "5" "6")) - ;; TODO: this doesn't short-circuit anymore - ;; review shortcircuiting on all boolean forms - ;; (check-true ((☯ (or string? positive?)) "abc") - ;; "short-circuiting") - ) + (check-true ((☯ (or string? positive?)) "abc") + "short-circuiting")) (test-suite "not (predicate negation)" (check-true ((☯ (not positive?)) -5)) From 8e4338f2b009db5efe19fb4b9816c8f852f880bf Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 12 Aug 2022 16:36:56 -0700 Subject: [PATCH 012/338] reduce AND and OR to folds --- qi-lib/flow/compiler.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 16b49a100..4c35ee464 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -66,9 +66,9 @@ [(~or* (~datum NOT) (~datum !)) #'not] [(~or* (~datum AND) (~datum &)) - #'all?] + #'(qi0->racket (>> (and 2> 1>) #t))] [(~or* (~datum OR) (~datum ∥)) - #'any?] + #'(qi0->racket (<< (or 1> 2>) #f))] [(~datum NOR) #'(qi0->racket (~> OR NOT))] [(~datum NAND) From e9857dfad93c205b9ccff88c46232b42a9d6aac4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 18 Aug 2022 16:38:11 -0700 Subject: [PATCH 013/338] Add an example optimization This adds a "restorative" optimization for `all`. The optimization isn't equivalent to the original expression and it's only meant to serve as a proof of concept, for now, to complete the compilation cycle. --- qi-lib/flow/compiler.rkt | 14 +++++++++++--- qi-lib/flow/expander.rkt | 9 ++++++++- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 4c35ee464..8752a250e 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -27,7 +27,15 @@ #`(qi0->racket #,(optimize-flow stx))) (define (optimize-flow stx) - stx)) + (syntax-parse stx + ;; "restorative" optimization for the original + ;; implementation of `all`. Note that the optimized + ;; version is _not_ equivalent to the original expression + ;; in the presence of side-effects. For now, this is just + ;; here as a proof-of-concept optimization + [((~datum ~>) ((~datum ><) onex) (~datum AND)) + #`(esc (give (curry andmap #,(compile-flow #'onex))))] + [_ stx]))) (define-syntax (qi0->racket stx) (syntax-parse (cadr (syntax->list stx)) @@ -49,8 +57,8 @@ ;;; Special words [((~datum one-of?) v:expr ...) #'(qi0->racket (~> (member (list v ...)) ->boolean))] - [((~datum all) onex:clause) - #`(qi0->racket (~> (>< onex) AND))] + ;; [((~datum all) onex:clause) + ;; #`(qi0->racket (~> (>< onex) AND))] [((~datum any) onex:clause) #'(qi0->racket (~> (>< onex) OR))] [((~datum none) onex:clause) diff --git a/qi-lib/flow/expander.rkt b/qi-lib/flow/expander.rkt index e6a2d7966..719d63a1e 100644 --- a/qi-lib/flow/expander.rkt +++ b/qi-lib/flow/expander.rkt @@ -2,5 +2,12 @@ (provide expand-flow) +(require syntax/parse + (for-template "impl.rkt" racket/base) + "aux-syntax.rkt") + (define (expand-flow stx) - stx) + (syntax-parse stx + [((~datum all) onex:clause) + #'(~> (>< onex) AND)] + [_ stx])) From fe3305f7ad1040e372a86ea697119c9708125aac Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 23 Aug 2022 19:15:26 -0700 Subject: [PATCH 014/338] revert the `all` optimization for now --- qi-lib/flow/compiler.rkt | 14 +++----------- qi-lib/flow/expander.rkt | 9 +-------- 2 files changed, 4 insertions(+), 19 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 8752a250e..4c35ee464 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -27,15 +27,7 @@ #`(qi0->racket #,(optimize-flow stx))) (define (optimize-flow stx) - (syntax-parse stx - ;; "restorative" optimization for the original - ;; implementation of `all`. Note that the optimized - ;; version is _not_ equivalent to the original expression - ;; in the presence of side-effects. For now, this is just - ;; here as a proof-of-concept optimization - [((~datum ~>) ((~datum ><) onex) (~datum AND)) - #`(esc (give (curry andmap #,(compile-flow #'onex))))] - [_ stx]))) + stx)) (define-syntax (qi0->racket stx) (syntax-parse (cadr (syntax->list stx)) @@ -57,8 +49,8 @@ ;;; Special words [((~datum one-of?) v:expr ...) #'(qi0->racket (~> (member (list v ...)) ->boolean))] - ;; [((~datum all) onex:clause) - ;; #`(qi0->racket (~> (>< onex) AND))] + [((~datum all) onex:clause) + #`(qi0->racket (~> (>< onex) AND))] [((~datum any) onex:clause) #'(qi0->racket (~> (>< onex) OR))] [((~datum none) onex:clause) diff --git a/qi-lib/flow/expander.rkt b/qi-lib/flow/expander.rkt index 719d63a1e..e6a2d7966 100644 --- a/qi-lib/flow/expander.rkt +++ b/qi-lib/flow/expander.rkt @@ -2,12 +2,5 @@ (provide expand-flow) -(require syntax/parse - (for-template "impl.rkt" racket/base) - "aux-syntax.rkt") - (define (expand-flow stx) - (syntax-parse stx - [((~datum all) onex:clause) - #'(~> (>< onex) AND)] - [_ stx])) + stx) From 7b019937bb278086f0de5afcd77e3af6a7cf8fec Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 23 Aug 2022 19:26:07 -0700 Subject: [PATCH 015/338] reduce `count` (restore its original implementation) --- qi-lib/flow/compiler.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 4c35ee464..ea8ede01f 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -137,7 +137,7 @@ ;; common utilities [(~datum count) - #'(λ args (length args))] + #'(qi0->racket (~> (>< 1) +))] [(~datum live?) #'(qi0->racket (~> count (> 0)))] [((~datum rectify) v:expr ...) From 9b10763f5a7aefacdf99910cd43d1c391aec9b1c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 23 Aug 2022 20:28:25 -0700 Subject: [PATCH 016/338] Separate core and non-core forms --- qi-lib/flow/compiler.rkt | 126 +++++++++++++++++++++------------------ 1 file changed, 69 insertions(+), 57 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index ea8ede01f..664517147 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -46,7 +46,72 @@ #'stx) #'(qi0->racket expanded)] + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; Core language forms ;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + [((~datum gen) ex:expr ...) + #'(λ _ (values ex ...))] + ;; pass-through (identity flow) + [(~datum _) #'values] + ;; routing + [((~or* (~datum ~>) (~datum thread)) onex:clause ...) + #`(compose . #,(reverse + (syntax->list + #'((qi0->racket onex) ...))))] + [e:relay-form (relay-parser #'e)] + [e:tee-form (tee-parser #'e)] + ;; prisms + [e:sep-form (sep-parser #'e)] + [(~or* (~datum ▽) (~datum collect)) + #'list] + ;; boolean algebra + [(~or* (~datum NOT) (~datum !)) + #'not] + [(~datum XOR) + #'parity-xor] + [((~datum and) onex:clause ...) + #'(conjoin (qi0->racket onex) ...)] + [((~datum or) onex:clause ...) + #'(disjoin (qi0->racket onex) ...)] + ;; selection + [e:select-form (select-parser #'e)] + [e:block-form (block-parser #'e)] + [e:group-form (group-parser #'e)] + ;; conditionals + [e:if-form (if-parser #'e)] + [e:sieve-form (sieve-parser #'e)] + ;; exceptions + [e:try-form (try-parser #'e)] + ;; folds + [e:fold-left-form (fold-left-parser #'e)] + [e:fold-right-form (fold-right-parser #'e)] + ;; looping + [e:feedback-form (feedback-parser #'e)] + [e:loop-form (loop-parser #'e)] + [((~datum loop2) pred:clause mapex:clause combex:clause) + #'(letrec ([loop2 (qi0->racket (if pred + (~> (== (-< cdr + (~> car mapex)) _) + (group 1 _ combex) + loop2) + 2>))]) + loop2)] + ;; towards universality + [(~datum apply) + #'call] + [e:clos-form (clos-parser #'e)] + ;; escape hatch for racket expressions or anything + ;; to be "passed through" + [((~datum esc) ex:expr) + #'ex] + + ;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; Non-core forms ;;;; + ;;;;;;;;;;;;;;;;;;;;;;;; + ;;; Special words + [((~datum one-of?) v:expr ...) #'(qi0->racket (~> (member (list v ...)) ->boolean))] [((~datum all) onex:clause) @@ -55,16 +120,8 @@ #'(qi0->racket (~> (>< onex) OR))] [((~datum none) onex:clause) #'(qi0->racket (not (any onex)))] - [((~datum and) onex:clause ...) - #'(conjoin (qi0->racket onex) ...)] - [((~datum or) onex:clause ...) - #'(disjoin (qi0->racket onex) ...)] [((~datum not) onex:clause) #'(qi0->racket (~> onex NOT))] - [((~datum gen) ex:expr ...) - #'(λ _ (values ex ...))] - [(~or* (~datum NOT) (~datum !)) - #'not] [(~or* (~datum AND) (~datum &)) #'(qi0->racket (>> (and 2> 1>) #t))] [(~or* (~datum OR) (~datum ∥)) @@ -73,8 +130,6 @@ #'(qi0->racket (~> OR NOT))] [(~datum NAND) #'(qi0->racket (~> AND NOT))] - [(~datum XOR) - #'parity-xor] [(~datum XNOR) #'(qi0->racket (~> XOR NOT))] [e:and%-form (and%-parser #'e)] @@ -82,38 +137,25 @@ [(~datum any?) #'(qi0->racket OR)] [(~datum all?) #'(qi0->racket AND)] [(~datum none?) #'(qi0->racket (~> any? NOT))] - [(~or* (~datum ▽) (~datum collect)) - #'list] - [e:sep-form (sep-parser #'e)] - ;;; Core routing elements + ;;; Routing [(~or* (~datum ⏚) (~datum ground)) #'(qi0->racket (select))] - [((~or* (~datum ~>) (~datum thread)) onex:clause ...) - #`(compose . #,(reverse - (syntax->list - #'((qi0->racket onex) ...))))] [e:right-threading-form (right-threading-parser #'e)] [(~or* (~datum X) (~datum crossover)) #'(qi0->racket (~> ▽ reverse △))] - [e:relay-form (relay-parser #'e)] [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) #:with len #`#,(length (syntax->list #'(onex ...))) #'(qi0->racket (group len (== onex ...) rest-onex) )] - [e:tee-form (tee-parser #'e)] - [e:select-form (select-parser #'e)] - [e:block-form (block-parser #'e)] [((~datum bundle) (n:number ...) selection-onex:clause remainder-onex:clause) #'(qi0->racket (-< (~> (select n ...) selection-onex) (~> (block n ...) remainder-onex)))] - [e:group-form (group-parser #'e)] ;;; Conditionals - [e:if-form (if-parser #'e)] [((~datum when) condition:clause consequent:clause) #'(qi0->racket (if condition consequent ⏚))] @@ -121,15 +163,10 @@ alternative:clause) #'(qi0->racket (if condition ⏚ alternative))] [e:switch-form (switch-parser #'e)] - [e:sieve-form (sieve-parser #'e)] [e:partition-form (partition-parser #'e)] [((~datum gate) onex:clause) #'(qi0->racket (if onex _ ⏚))] - ;;; Exceptions - - [e:try-form (try-parser #'e)] - ;;; High level circuit elements ;; aliases for inputs @@ -145,42 +182,18 @@ ;; high level routing [e:fanout-form (fanout-parser #'e)] - [e:feedback-form (feedback-parser #'e)] [(~datum inverter) #'(qi0->racket (>< NOT))] [e:side-effect-form (side-effect-parser #'e)] ;;; Higher-order flows - ;; map, filter, and fold + ;; map and filter [e:amp-form (amp-parser #'e)] [e:pass-form (pass-parser #'e)] - [e:fold-left-form (fold-left-parser #'e)] - [e:fold-right-form (fold-right-parser #'e)] - - ;; looping - [e:loop-form (loop-parser #'e)] - [((~datum loop2) pred:clause mapex:clause combex:clause) - #'(letrec ([loop2 (qi0->racket (if pred - (~> (== (-< cdr - (~> car mapex)) _) - (group 1 _ combex) - loop2) - 2>))]) - loop2)] - - ;; towards universality - [(~datum apply) - #'call] - [e:clos-form (clos-parser #'e)] ;;; Miscellaneous - ;; escape hatch for racket expressions or anything - ;; to be "passed through" - [((~datum esc) ex:expr) - #'ex] - ;; backwards compat macro extensibility via Racket macros [((~var ext-form (starts-with "qi:")) expr ...) #'(ext-form expr ...)] @@ -214,9 +227,6 @@ #'(curry natex prarg ...) #'(curryr natex prarg ...))] - ;; pass-through (identity flow) - [(~datum _) #'values] - ;; literally indicated function identifier [natex:expr #'natex])) @@ -403,6 +413,8 @@ the DSL. #'(qi0->racket (-< (~> (pass condition) sonex) (~> (pass (not condition)) ronex)))] [_:id + ;; sieve can be a core form once bindings + ;; are introduced into the language #'(λ (condition sonex ronex . args) (apply (qi0->racket (-< (~> (pass condition) sonex) (~> (pass (not condition)) ronex))) From 506bea3b9a91788232b292b8e52c1d020eb22597 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 24 Aug 2022 18:21:17 -0700 Subject: [PATCH 017/338] support identifier-only form of `loop` --- qi-lib/flow/compiler.rkt | 7 +++++-- qi-lib/flow/syntax.rkt | 2 ++ qi-test/tests/flow.rkt | 11 ++++++++++- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 664517147..5b7ea65b1 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -610,7 +610,7 @@ the DSL. (syntax-parse stx [(_ pred:clause mapex:clause combex:clause retex:clause) #'(letrec ([loop (qi0->racket (if pred - (~> (group 1 mapex loop) + (~> (group 1 mapex (esc loop)) combex) retex))]) loop)] @@ -619,7 +619,10 @@ the DSL. [(_ pred:clause mapex:clause) #'(qi0->racket (loop pred mapex _ ⏚))] [(_ mapex:clause) - #'(qi0->racket (loop #t mapex _ ⏚))])) + #'(qi0->racket (loop #t mapex _ ⏚))] + [_:id #'(λ (predf mapf combf retf . args) + (apply (qi0->racket (loop predf mapf combf retf)) + args))])) (define (clos-parser stx) (syntax-parse stx diff --git a/qi-lib/flow/syntax.rkt b/qi-lib/flow/syntax.rkt index 9d188db93..297398cc2 100644 --- a/qi-lib/flow/syntax.rkt +++ b/qi-lib/flow/syntax.rkt @@ -148,6 +148,8 @@ See comments in flow.rkt for more details. ((~datum <<) arg ...))) (define-syntax-class loop-form + (pattern + (~datum loop)) (pattern ((~datum loop) arg ...))) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 472711540..d99079301 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1267,7 +1267,16 @@ (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) sqr +))) 1 2 3) - 14)) + 14) + (check-equal? ((☯ (~> (-< (gen (☯ (~> ▽ (not null?))) + sqr + + + (☯ 0)) + _) + loop)) + 1 2 3) + 14 + "identifier form of loop")) (test-suite "loop2" (check-equal? ((☯ (~> (loop2 (~> 1> (not null?)) From aa569e5c96a8ee439e922c67721172a8f4cfd42b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 24 Aug 2022 18:22:45 -0700 Subject: [PATCH 018/338] reduce `amp` to `loop` instead of to `relay` --- qi-lib/flow/compiler.rkt | 12 ++++++++++-- qi-test/tests/flow.rkt | 3 +++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 5b7ea65b1..94e59ca9d 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -559,14 +559,22 @@ the DSL. [((~or* (~datum ==) (~datum relay)) onex:clause ...) #'(relay (qi0->racket onex) ...)] [(~or* (~datum ==) (~datum relay)) + ;; review this – this "map" behavior may not be natural + ;; for relay. And map-values should probably end up being + ;; used in a compiler optimization #'map-values])) (define (amp-parser stx) (syntax-parse stx [_:id - #'(qi0->racket ==)] + #'(qi0->racket (~> (==* (-< (gen (qi0->racket #t)) + _ + (gen (qi0->racket _) + (qi0->racket _))) + _) + loop))] [(_ onex:clause) - #'(qi0->racket (~> (-< (gen (qi0->racket onex)) _) ==))] + #'(qi0->racket (loop onex))] [(_ onex0:clause onex:clause ...) (report-syntax-error 'amp diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index d99079301..68c33fafb 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -491,6 +491,9 @@ (thunk ((☯ (~> (== ⏚ add1) ▽)) 5 7 8)) "relay elements must be in one-to-one correspondence with input") + (check-equal? ((☯ (~> (gen sqr 1 2 3) == ▽))) + (list 1 4 9) + "relay when used as an identifier") ; TODO: review this (check-equal? ((☯ (~> (relay sqr add1) ▽)) 5 7) (list 25 8) From ba62e2281876bc29232f1bbd3876605462858f18 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 24 Aug 2022 19:55:24 -0700 Subject: [PATCH 019/338] comment - category name --- qi-lib/flow/compiler.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 94e59ca9d..4b568af4d 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -65,7 +65,7 @@ [e:sep-form (sep-parser #'e)] [(~or* (~datum ▽) (~datum collect)) #'list] - ;; boolean algebra + ;; predicates [(~or* (~datum NOT) (~datum !)) #'not] [(~datum XOR) @@ -110,7 +110,7 @@ ;;;; Non-core forms ;;;; ;;;;;;;;;;;;;;;;;;;;;;;; - ;;; Special words + ;;; Predicates [((~datum one-of?) v:expr ...) #'(qi0->racket (~> (member (list v ...)) ->boolean))] From 36c39b6e461d50f7329313f3da92aa3580db46e8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 24 Aug 2022 20:06:58 -0700 Subject: [PATCH 020/338] provisional docs for the identifier forms of `loop` and `relay` --- qi-doc/scribblings/forms.scrbl | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/qi-doc/scribblings/forms.scrbl b/qi-doc/scribblings/forms.scrbl index d59a9968a..cd5ef1f4c 100644 --- a/qi-doc/scribblings/forms.scrbl +++ b/qi-doc/scribblings/forms.scrbl @@ -346,11 +346,15 @@ Note that the symbol form uses Unicode @code{0x2225} corresponding to LaTeX's @c @deftogether[( @defform[(== flo ...)] @defform[(relay flo ...)] +@defidform[#:link-target? #f ==] +@defidform[#:link-target? #f relay] )]{ Compose flows in parallel, so that inputs are passed through the corresponding @racket[flo]'s individually. The number of @racket[flo]s must be the same as the number of runtime inputs. In the common case of @code{1 × 1} @racket[flo]s (i.e. where the flows each accept one input and produce one output), the number of outputs will be the same as the number of inputs, but as @seclink["What_is_a_Flow_"]{flows can be nonlinear}, this is not necessarily the case in general. + When used in identifier form simply as @racket[==], it behaves identically to @racket[><]. + See also the field guide entry on the @seclink["Bindings_are_an_Alternative_to_Nonlinearity"]{relationship between bindings and nonlinearity}. @examples[ @@ -568,11 +572,14 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each (loop condition-flo map-flo)] @defform[#:link-target? #f (loop map-flo)] + @defidform[#:link-target? #f loop] )]{ A simple loop for structural recursion on the input values, this applies @racket[map-flo] to the first input on each successive iteration and recurses on the remaining inputs, combining these using @racket[combine-flo] to yield the result as long as the inputs satisfy @racket[condition-flo]. When the inputs do not satisfy @racket[condition-flo], @racket[return-flo] is applied to the inputs to yield the result at that terminating step. If the condition is satisfied and there are no further values, the loop terminates naturally. If unspecified, @racket[condition-flo] defaults to @racket[#t], @racket[combine-flo] defaults to @racket[_], and @racket[return-flo] defaults to @racket[⏚]. + When used in identifier form simply as @racket[loop], this behaves the same as the fully qualified version, except that the flows parametrizing the loop are expected as the initial four inputs (in the same order), and the data inputs being acted upon are expected to follow. + @examples[ #:eval eval-for-docs ((☯ (loop (* 2))) 1 2 3) From 1da76cfd216ae18bf5b04c918a24c3cd959b1c22 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 13:20:16 -0700 Subject: [PATCH 021/338] extract one non-core form as a qi macro --- qi-lib/flow/compiler.rkt | 2 -- qi-lib/flow/std.rkt | 15 +++++++++++++++ qi-lib/main.rkt | 6 ++++-- 3 files changed, 19 insertions(+), 4 deletions(-) create mode 100644 qi-lib/flow/std.rkt diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index 4b568af4d..e0c7dafca 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -112,8 +112,6 @@ ;;; Predicates - [((~datum one-of?) v:expr ...) - #'(qi0->racket (~> (member (list v ...)) ->boolean))] [((~datum all) onex:clause) #`(qi0->racket (~> (>< onex) AND))] [((~datum any) onex:clause) diff --git a/qi-lib/flow/std.rkt b/qi-lib/flow/std.rkt new file mode 100644 index 000000000..357f72f24 --- /dev/null +++ b/qi-lib/flow/std.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +(provide (for-space qi + one-of?)) + +(require (for-syntax racket/base + syntax/parse + "aux-syntax.rkt") + "../macro.rkt" + "impl.rkt") + +;;; Predicates + +(define-qi-syntax-rule (one-of? v:expr ...) + (~> (member (list v ...)) ->boolean)) diff --git a/qi-lib/main.rkt b/qi-lib/main.rkt index 4e38131dc..60687c359 100644 --- a/qi-lib/main.rkt +++ b/qi-lib/main.rkt @@ -5,7 +5,8 @@ qi/macro qi/on qi/switch - qi/threading)) + qi/threading + qi/flow/std)) (require qi/flow (except-in qi/macro @@ -13,4 +14,5 @@ qi-macro?) qi/on qi/switch - qi/threading) + qi/threading + qi/flow/std) From d93e02c27cab0d918cf95c29ac6d64d56a641bc6 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 13:26:06 -0700 Subject: [PATCH 022/338] extract a few more non-core forms as macros --- qi-lib/flow/compiler.rkt | 6 ------ qi-lib/flow/std.rkt | 14 +++++++++++++- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt index e0c7dafca..fd36f00ad 100644 --- a/qi-lib/flow/compiler.rkt +++ b/qi-lib/flow/compiler.rkt @@ -112,12 +112,6 @@ ;;; Predicates - [((~datum all) onex:clause) - #`(qi0->racket (~> (>< onex) AND))] - [((~datum any) onex:clause) - #'(qi0->racket (~> (>< onex) OR))] - [((~datum none) onex:clause) - #'(qi0->racket (not (any onex)))] [((~datum not) onex:clause) #'(qi0->racket (~> onex NOT))] [(~or* (~datum AND) (~datum &)) diff --git a/qi-lib/flow/std.rkt b/qi-lib/flow/std.rkt index 357f72f24..7436903ef 100644 --- a/qi-lib/flow/std.rkt +++ b/qi-lib/flow/std.rkt @@ -1,7 +1,10 @@ #lang racket/base (provide (for-space qi - one-of?)) + one-of? + all + any + none)) (require (for-syntax racket/base syntax/parse @@ -13,3 +16,12 @@ (define-qi-syntax-rule (one-of? v:expr ...) (~> (member (list v ...)) ->boolean)) + +(define-qi-syntax-rule (all onex:clause) + (~> (>< onex) AND)) + +(define-qi-syntax-rule (any onex:clause) + (~> (>< onex) OR)) + +(define-qi-syntax-rule (none onex:clause) + (not (any onex))) From 6697094a5779b54394d627d6565db9be06f56bba Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 14:42:45 -0700 Subject: [PATCH 023/338] reorganize/rename modules to distinguish core from non-core --- qi-lib/flow/{ => core}/compiler.rkt | 0 qi-lib/flow/{ => core}/impl.rkt | 0 qi-lib/flow/{ => core}/syntax.rkt | 0 qi-lib/flow/{ => extended}/expander.rkt | 0 qi-lib/flow/{std.rkt => extended/forms.rkt} | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename qi-lib/flow/{ => core}/compiler.rkt (100%) rename qi-lib/flow/{ => core}/impl.rkt (100%) rename qi-lib/flow/{ => core}/syntax.rkt (100%) rename qi-lib/flow/{ => extended}/expander.rkt (100%) rename qi-lib/flow/{std.rkt => extended/forms.rkt} (100%) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/core/compiler.rkt similarity index 100% rename from qi-lib/flow/compiler.rkt rename to qi-lib/flow/core/compiler.rkt diff --git a/qi-lib/flow/impl.rkt b/qi-lib/flow/core/impl.rkt similarity index 100% rename from qi-lib/flow/impl.rkt rename to qi-lib/flow/core/impl.rkt diff --git a/qi-lib/flow/syntax.rkt b/qi-lib/flow/core/syntax.rkt similarity index 100% rename from qi-lib/flow/syntax.rkt rename to qi-lib/flow/core/syntax.rkt diff --git a/qi-lib/flow/expander.rkt b/qi-lib/flow/extended/expander.rkt similarity index 100% rename from qi-lib/flow/expander.rkt rename to qi-lib/flow/extended/expander.rkt diff --git a/qi-lib/flow/std.rkt b/qi-lib/flow/extended/forms.rkt similarity index 100% rename from qi-lib/flow/std.rkt rename to qi-lib/flow/extended/forms.rkt From 5aee433a4bc38ded7574eb03c9f0e2c8b7524eed Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 16:00:25 -0700 Subject: [PATCH 024/338] fix import paths post-refactor --- qi-lib/flow.rkt | 4 ++-- qi-lib/flow/core/compiler.rkt | 6 +++--- qi-lib/flow/core/impl.rkt | 3 --- qi-lib/flow/extended/forms.rkt | 6 +++--- qi-lib/flow/extended/util.rkt | 5 +++++ qi-lib/main.rkt | 4 ++-- 6 files changed, 15 insertions(+), 13 deletions(-) create mode 100644 qi-lib/flow/extended/util.rkt diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index af6f067ac..ea2ffb14e 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -12,8 +12,8 @@ syntax/parse (only-in "private/util.rkt" report-syntax-error) - "flow/expander.rkt") - "flow/compiler.rkt" + "flow/extended/expander.rkt") + "flow/core/compiler.rkt" (only-in "private/util.rkt" define-alias)) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index fd36f00ad..59b3f2b1b 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -8,10 +8,10 @@ (only-in racket/list make-list) "syntax.rkt" - "aux-syntax.rkt" - (only-in "../private/util.rkt" + "../aux-syntax.rkt" + (only-in "../../private/util.rkt" report-syntax-error)) - (only-in "../macro.rkt" + (only-in "../../macro.rkt" qi-macro? qi-macro-transformer) "impl.rkt" diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 679b64649..8c8ae69a9 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -1,7 +1,6 @@ #lang racket/base (provide give - ->boolean true. false. any? @@ -167,10 +166,8 @@ (call-with-values (λ () (apply b args)) list))) (apply values (apply append results))) -(define (->boolean v) (and v #t)) (define true. (thunk* #t)) (define false. (thunk* #f)) - (define exists ormap) (define for-all andmap) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 7436903ef..2549d43d4 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -8,9 +8,9 @@ (require (for-syntax racket/base syntax/parse - "aux-syntax.rkt") - "../macro.rkt" - "impl.rkt") + "../aux-syntax.rkt") + "../../macro.rkt" + "util.rkt") ;;; Predicates diff --git a/qi-lib/flow/extended/util.rkt b/qi-lib/flow/extended/util.rkt new file mode 100644 index 000000000..ba9eb7ffa --- /dev/null +++ b/qi-lib/flow/extended/util.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(provide ->boolean) + +(define (->boolean v) (and v #t)) diff --git a/qi-lib/main.rkt b/qi-lib/main.rkt index 60687c359..c0209af81 100644 --- a/qi-lib/main.rkt +++ b/qi-lib/main.rkt @@ -6,7 +6,7 @@ qi/on qi/switch qi/threading - qi/flow/std)) + qi/flow/extended/forms)) (require qi/flow (except-in qi/macro @@ -15,4 +15,4 @@ qi/on qi/switch qi/threading - qi/flow/std) + qi/flow/extended/forms) From c3ca55cdb7a79089d9cfb95cde439449886b7010 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 16:43:52 -0700 Subject: [PATCH 025/338] promote `AND` and `OR` to core for convenience --- qi-lib/flow/core/compiler.rkt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 59b3f2b1b..bf1f88df8 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -66,6 +66,10 @@ [(~or* (~datum ▽) (~datum collect)) #'list] ;; predicates + [(~or* (~datum AND) (~datum &)) ; NOTE: technically not core + #'(qi0->racket (>> (and 2> 1>) #t))] + [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core + #'(qi0->racket (<< (or 1> 2>) #f))] [(~or* (~datum NOT) (~datum !)) #'not] [(~datum XOR) From c4244bc740252a0b4d80b2bbddfc85f598724491 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 16:44:57 -0700 Subject: [PATCH 026/338] extract more non-core forms as macros --- qi-lib/flow/core/compiler.rkt | 15 +-------------- qi-lib/flow/extended/forms.rkt | 31 ++++++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 15 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index bf1f88df8..e263fd412 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -116,23 +116,10 @@ ;;; Predicates - [((~datum not) onex:clause) + [((~datum not) onex:clause) ;; TODO #'(qi0->racket (~> onex NOT))] - [(~or* (~datum AND) (~datum &)) - #'(qi0->racket (>> (and 2> 1>) #t))] - [(~or* (~datum OR) (~datum ∥)) - #'(qi0->racket (<< (or 1> 2>) #f))] - [(~datum NOR) - #'(qi0->racket (~> OR NOT))] - [(~datum NAND) - #'(qi0->racket (~> AND NOT))] - [(~datum XNOR) - #'(qi0->racket (~> XOR NOT))] [e:and%-form (and%-parser #'e)] [e:or%-form (or%-parser #'e)] - [(~datum any?) #'(qi0->racket OR)] - [(~datum all?) #'(qi0->racket AND)] - [(~datum none?) #'(qi0->racket (~> any? NOT))] ;;; Routing diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 2549d43d4..41e038433 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -4,7 +4,15 @@ one-of? all any - none)) + none + ;; not + NOR + NAND + XNOR + any? + all? + none? + )) (require (for-syntax racket/base syntax/parse @@ -25,3 +33,24 @@ (define-qi-syntax-rule (none onex:clause) (not (any onex))) + +;; (define-qi-syntax-rule (not onex:clause) +;; (~> onex NOT)) + +(define-qi-syntax-parser NOR + [_:id #'(~> OR NOT)]) + +(define-qi-syntax-parser NAND + [_:id #'(~> AND NOT)]) + +(define-qi-syntax-parser XNOR + [_:id #'(~> XOR NOT)]) + +(define-qi-syntax-parser any? + [_:id #'OR]) + +(define-qi-syntax-parser all? + [_:id #'AND]) + +(define-qi-syntax-parser none? + [_:id #'(~> any? NOT)]) From 826c34eed2a64488b1805a48da6fb8d71191ba26 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 16:56:39 -0700 Subject: [PATCH 027/338] rename util -> impl for symmetry --- qi-lib/flow/extended/{util.rkt => impl.rkt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename qi-lib/flow/extended/{util.rkt => impl.rkt} (100%) diff --git a/qi-lib/flow/extended/util.rkt b/qi-lib/flow/extended/impl.rkt similarity index 100% rename from qi-lib/flow/extended/util.rkt rename to qi-lib/flow/extended/impl.rkt From c46ce27e3e8af3f2ac7cffdc71842b82ffafa214 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 17:22:01 -0700 Subject: [PATCH 028/338] extract more non-core forms --- qi-lib/flow/core/compiler.rkt | 31 ------------------------------- qi-lib/flow/core/impl.rkt | 7 ++----- qi-lib/flow/core/syntax.rkt | 10 ---------- qi-lib/flow/extended/forms.rkt | 14 ++++++++++++-- qi-lib/flow/extended/impl.rkt | 15 ++++++++++++++- qi-lib/flow/extended/syntax.rkt | 26 ++++++++++++++++++++++++++ 6 files changed, 54 insertions(+), 49 deletions(-) create mode 100644 qi-lib/flow/extended/syntax.rkt diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index e263fd412..6ac375ae2 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -118,8 +118,6 @@ [((~datum not) onex:clause) ;; TODO #'(qi0->racket (~> onex NOT))] - [e:and%-form (and%-parser #'e)] - [e:or%-form (or%-parser #'e)] ;;; Routing @@ -233,35 +231,6 @@ the DSL. |# (begin-for-syntax - (define-syntax-class disjux-clause ; "juxtaposed" disjoin - #:attributes (parsed) - (pattern - (~datum _) - #:with parsed #'false.) - (pattern - onex:clause - #:with parsed #'onex)) - - (define-syntax-class conjux-clause ; "juxtaposed" conjoin - #:attributes (parsed) - (pattern - (~datum _) - #:with parsed #'true.) - (pattern - onex:clause - #:with parsed #'onex)) - - (define (and%-parser stx) - (syntax-parse stx - [(_ onex:conjux-clause ...) - #'(qi0->racket (~> (== onex.parsed ...) - all?))])) - - (define (or%-parser stx) - (syntax-parse stx - [(_ onex:disjux-clause ...) - #'(qi0->racket (~> (== onex.parsed ...) - any?))])) (define (make-right-chiral stx) (syntax-property stx 'chirality 'right)) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 8c8ae69a9..58aca04b6 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -1,8 +1,6 @@ #lang racket/base (provide give - true. - false. any? all? none? @@ -166,9 +164,8 @@ (call-with-values (λ () (apply b args)) list))) (apply values (apply append results))) -(define true. (thunk* #t)) -(define false. (thunk* #f)) -(define exists ormap) +(define exists ormap) + (define for-all andmap) (define (zip-with op . seqs) diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 297398cc2..3d702627e 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -21,8 +21,6 @@ fold-right-form loop-form blanket-template-form - and%-form - or%-form right-threading-form clos-form) @@ -158,14 +156,6 @@ See comments in flow.rkt for more details. (pattern (natex prarg-pre ... (~datum __) prarg-post ...))) -(define-syntax-class and%-form - (pattern - ((~datum and%) arg ...))) - -(define-syntax-class or%-form - (pattern - ((~datum or%) arg ...))) - (define-syntax-class right-threading-form (pattern ((~or* (~datum ~>>) (~datum thread-right)) arg ...))) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 41e038433..b921178e2 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -12,13 +12,15 @@ any? all? none? - )) + and% + or%)) (require (for-syntax racket/base syntax/parse + "syntax.rkt" "../aux-syntax.rkt") "../../macro.rkt" - "util.rkt") + "impl.rkt") ;;; Predicates @@ -54,3 +56,11 @@ (define-qi-syntax-parser none? [_:id #'(~> any? NOT)]) + +(define-qi-syntax-rule (and% onex:conjux-clause ...) + (~> (== onex.parsed ...) + all?)) + +(define-qi-syntax-rule (or% onex:disjux-clause ...) + (~> (== onex.parsed ...) + any?)) diff --git a/qi-lib/flow/extended/impl.rkt b/qi-lib/flow/extended/impl.rkt index ba9eb7ffa..1ea6f566a 100644 --- a/qi-lib/flow/extended/impl.rkt +++ b/qi-lib/flow/extended/impl.rkt @@ -1,5 +1,18 @@ #lang racket/base -(provide ->boolean) +(require (only-in racket/function + const)) + +(provide ->boolean + true. + false.) (define (->boolean v) (and v #t)) + +(define true. + (procedure-rename (const #t) + 'true.)) + +(define false. + (procedure-rename (const #f) + 'false.)) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt new file mode 100644 index 000000000..aeb4e5a28 --- /dev/null +++ b/qi-lib/flow/extended/syntax.rkt @@ -0,0 +1,26 @@ +#lang racket/base + +(provide conjux-clause + disjux-clause) + +(require syntax/parse + "../aux-syntax.rkt" + (for-template "impl.rkt")) + +(define-syntax-class conjux-clause ; "juxtaposed" conjoin + #:attributes (parsed) + (pattern + (~datum _) + #:with parsed #'true.) + (pattern + onex:clause + #:with parsed #'onex)) + +(define-syntax-class disjux-clause ; "juxtaposed" disjoin + #:attributes (parsed) + (pattern + (~datum _) + #:with parsed #'false.) + (pattern + onex:clause + #:with parsed #'onex)) From e340502551a2fa86c36f5a2e3822c83716dde206 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 17:39:23 -0700 Subject: [PATCH 029/338] promote `ground` to core for convenience --- qi-lib/flow/core/compiler.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 6ac375ae2..bbf5aff26 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -55,6 +55,8 @@ ;; pass-through (identity flow) [(~datum _) #'values] ;; routing + [(~or* (~datum ⏚) (~datum ground)) ; NOTE: technically not core + #'(qi0->racket (select))] [((~or* (~datum ~>) (~datum thread)) onex:clause ...) #`(compose . #,(reverse (syntax->list @@ -121,8 +123,6 @@ ;;; Routing - [(~or* (~datum ⏚) (~datum ground)) - #'(qi0->racket (select))] [e:right-threading-form (right-threading-parser #'e)] [(~or* (~datum X) (~datum crossover)) #'(qi0->racket (~> ▽ reverse △))] From 3dddcbf305299429f7a0e90b899a448b5898c95b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 17:40:47 -0700 Subject: [PATCH 030/338] extract right-threading as a macro --- qi-lib/flow/core/compiler.rkt | 17 ----------------- qi-lib/flow/core/syntax.rkt | 5 ----- qi-lib/flow/extended/forms.rkt | 14 +++++++++++++- qi-lib/flow/extended/syntax.rkt | 11 ++++++++++- 4 files changed, 23 insertions(+), 24 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index bbf5aff26..93680618b 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -123,7 +123,6 @@ ;;; Routing - [e:right-threading-form (right-threading-parser #'e)] [(~or* (~datum X) (~datum crossover)) #'(qi0->racket (~> ▽ reverse △))] [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) @@ -232,22 +231,6 @@ the DSL. (begin-for-syntax - (define (make-right-chiral stx) - (syntax-property stx 'chirality 'right)) - - (define-syntax-class right-threading-clause - (pattern - onex:clause - #:with chiral (make-right-chiral #'onex))) - - (define (right-threading-parser stx) - ;; right-threading is just normal threading - ;; but with a syntax property attached to - ;; the components indicating the chirality - (syntax-parse stx - [(_ onex:right-threading-clause ...) - #'(qi0->racket (~> onex.chiral ...))])) - (define (sep-parser stx) (syntax-parse stx [_:id diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 3d702627e..219cd146c 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -21,7 +21,6 @@ fold-right-form loop-form blanket-template-form - right-threading-form clos-form) (require syntax/parse) @@ -156,10 +155,6 @@ See comments in flow.rkt for more details. (pattern (natex prarg-pre ... (~datum __) prarg-post ...))) -(define-syntax-class right-threading-form - (pattern - ((~or* (~datum ~>>) (~datum thread-right)) arg ...))) - (define-syntax-class clos-form (pattern (~datum clos)) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index b921178e2..ca2d370a2 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -13,7 +13,9 @@ all? none? and% - or%)) + or% + thread-right + ~>>)) (require (for-syntax racket/base syntax/parse @@ -64,3 +66,13 @@ (define-qi-syntax-rule (or% onex:disjux-clause ...) (~> (== onex.parsed ...) any?)) + +;;; Routing + +;; Right-threading is just normal threading but with a syntax +;; property attached to the components indicating the chirality +(define-qi-syntax-rule (thread-right onex:right-threading-clause ...) + (~> onex.chiral ...)) + +(define-qi-syntax-rule (~>> arg ...) + (thread-right arg ...)) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index aeb4e5a28..084ae1053 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -1,7 +1,8 @@ #lang racket/base (provide conjux-clause - disjux-clause) + disjux-clause + right-threading-clause) (require syntax/parse "../aux-syntax.rkt" @@ -24,3 +25,11 @@ (pattern onex:clause #:with parsed #'onex)) + +(define (make-right-chiral stx) + (syntax-property stx 'chirality 'right)) + +(define-syntax-class right-threading-clause + (pattern + onex:clause + #:with chiral (make-right-chiral #'onex))) From 41ca79250f2da6bfb87b0d513289277e7a821dbf Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 18:05:21 -0700 Subject: [PATCH 031/338] attempt to define qi aliases (not working atm) --- qi-lib/flow/extended/forms.rkt | 3 +++ qi-lib/macro.rkt | 6 ++++++ 2 files changed, 9 insertions(+) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index ca2d370a2..bcf586318 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -74,5 +74,8 @@ (define-qi-syntax-rule (thread-right onex:right-threading-clause ...) (~> onex.chiral ...)) +;; TODO: do it as an alias? +;; (define-qi-alias ~>> thread-right) + (define-qi-syntax-rule (~>> arg ...) (thread-right arg ...)) diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index df1a70032..a90e02ade 100644 --- a/qi-lib/macro.rkt +++ b/qi-lib/macro.rkt @@ -3,6 +3,7 @@ (provide define-qi-syntax define-qi-syntax-rule define-qi-syntax-parser + define-qi-alias define-qi-foreign-syntaxes (for-syntax qi-macro? qi-macro-transformer @@ -94,6 +95,11 @@ #`(define-syntax #,((make-interned-syntax-introducer 'qi) #'name) transformer)])) +;; TODO: get this to work +(define-syntax define-qi-alias + (syntax-parser + [(_ alias:id name:id) #'(define-qi-syntax alias (make-rename-transformer #'name))])) + (define-syntax define-qi-syntax-rule (syntax-parser [(_ (name . pat) template) From 3216f6c9c98f72f6e403e362d6f0ff1ee03b01fe Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 18:34:19 -0700 Subject: [PATCH 032/338] extract `crossover` as a macro --- qi-lib/flow/core/compiler.rkt | 2 -- qi-lib/flow/extended/forms.rkt | 11 ++++++++++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 93680618b..4b3882249 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -123,8 +123,6 @@ ;;; Routing - [(~or* (~datum X) (~datum crossover)) - #'(qi0->racket (~> ▽ reverse △))] [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) #:with len #`#,(length (syntax->list #'(onex ...))) #'(qi0->racket (group len (== onex ...) rest-onex) )] diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index bcf586318..a3febcb69 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -15,7 +15,9 @@ and% or% thread-right - ~>>)) + ~>> + crossover + X)) (require (for-syntax racket/base syntax/parse @@ -79,3 +81,10 @@ (define-qi-syntax-rule (~>> arg ...) (thread-right arg ...)) + +(define-qi-syntax-parser crossover + [_:id #'(~> ▽ reverse △)]) + +;; TODO: alias +(define-qi-syntax-parser X + [_:id #'crossover]) From ef0c8a7da7783f3302b40b2a8dc9d755eb3023c9 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 18:39:42 -0700 Subject: [PATCH 033/338] Promote `amp` to core for convenience This also reverts to reducing it to `relay` for now, since as a core form it must rely only on other core forms. --- qi-lib/flow/core/compiler.rkt | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 4b3882249..9fe6b60c3 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -63,6 +63,7 @@ #'((qi0->racket onex) ...))))] [e:relay-form (relay-parser #'e)] [e:tee-form (tee-parser #'e)] + [e:amp-form (amp-parser #'e)] ; NOTE: technically not core ;; prisms [e:sep-form (sep-parser #'e)] [(~or* (~datum ▽) (~datum collect)) @@ -167,7 +168,6 @@ ;;; Higher-order flows ;; map and filter - [e:amp-form (amp-parser #'e)] [e:pass-form (pass-parser #'e)] ;;; Miscellaneous @@ -500,12 +500,7 @@ the DSL. (define (amp-parser stx) (syntax-parse stx [_:id - #'(qi0->racket (~> (==* (-< (gen (qi0->racket #t)) - _ - (gen (qi0->racket _) - (qi0->racket _))) - _) - loop))] + #'(qi0->racket ==)] [(_ onex:clause) #'(qi0->racket (loop onex))] [(_ onex0:clause onex:clause ...) From ef17a2107d95322bf5c89413dd9925509c24f0f0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 18:50:13 -0700 Subject: [PATCH 034/338] extract `relay*` and `bundle` --- qi-lib/flow/core/compiler.rkt | 11 ----------- qi-lib/flow/extended/forms.rkt | 23 +++++++++++++++++++++-- 2 files changed, 21 insertions(+), 13 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 9fe6b60c3..9bd64724e 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -122,17 +122,6 @@ [((~datum not) onex:clause) ;; TODO #'(qi0->racket (~> onex NOT))] - ;;; Routing - - [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) - #:with len #`#,(length (syntax->list #'(onex ...))) - #'(qi0->racket (group len (== onex ...) rest-onex) )] - [((~datum bundle) (n:number ...) - selection-onex:clause - remainder-onex:clause) - #'(qi0->racket (-< (~> (select n ...) selection-onex) - (~> (block n ...) remainder-onex)))] - ;;; Conditionals [((~datum when) condition:clause diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index a3febcb69..fa33e5141 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -17,12 +17,16 @@ thread-right ~>> crossover - X)) + X + relay* + ==* + bundle)) (require (for-syntax racket/base syntax/parse "syntax.rkt" - "../aux-syntax.rkt") + "../aux-syntax.rkt" + "../../private/util.rkt") "../../macro.rkt" "impl.rkt") @@ -88,3 +92,18 @@ ;; TODO: alias (define-qi-syntax-parser X [_:id #'crossover]) + +(define-qi-syntax-parser relay* + [(_ onex:clause ... rest-onex:clause) + #:with len #`#,(length (syntax->list #'(onex ...))) + #'(group len (== onex ...) rest-onex)]) + +;; TODO: alias +(define-qi-syntax-rule (==* onex ...) + (relay* onex ...)) + +(define-qi-syntax-rule (bundle (n:number ...) + selection-onex:clause + remainder-onex:clause) + (-< (~> (select n ...) selection-onex) + (~> (block n ...) remainder-onex))) From e1286a9b8bd07197859e3238243acc2e719ca022 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 18:54:30 -0700 Subject: [PATCH 035/338] extract `when` and `unless` --- qi-lib/flow/core/compiler.rkt | 6 ------ qi-lib/flow/extended/forms.rkt | 14 +++++++++++++- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 9bd64724e..f7c527e58 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -124,12 +124,6 @@ ;;; Conditionals - [((~datum when) condition:clause - consequent:clause) - #'(qi0->racket (if condition consequent ⏚))] - [((~datum unless) condition:clause - alternative:clause) - #'(qi0->racket (if condition ⏚ alternative))] [e:switch-form (switch-parser #'e)] [e:partition-form (partition-parser #'e)] [((~datum gate) onex:clause) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index fa33e5141..22c117278 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -20,7 +20,9 @@ X relay* ==* - bundle)) + bundle + when + unless)) (require (for-syntax racket/base syntax/parse @@ -107,3 +109,13 @@ remainder-onex:clause) (-< (~> (select n ...) selection-onex) (~> (block n ...) remainder-onex))) + +;;; Conditionals + +(define-qi-syntax-rule (when condition:clause + consequent:clause) + (if condition consequent ⏚)) + +(define-qi-syntax-rule (unless condition:clause + alternative:clause) + (if condition ⏚ alternative)) From 6b5b959abbcf6d7bed2958a9d9de414ad50925c8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 19:00:04 -0700 Subject: [PATCH 036/338] extract `switch` --- qi-lib/flow/core/compiler.rkt | 64 --------------------------------- qi-lib/flow/core/syntax.rkt | 5 --- qi-lib/flow/extended/forms.rkt | 65 +++++++++++++++++++++++++++++++++- 3 files changed, 64 insertions(+), 70 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index f7c527e58..470e923f2 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -124,7 +124,6 @@ ;;; Conditionals - [e:switch-form (switch-parser #'e)] [e:partition-form (partition-parser #'e)] [((~datum gate) onex:clause) #'(qi0->racket (if onex _ ⏚))] @@ -258,69 +257,6 @@ the DSL. (syntax->datum #'(arg ...)) "(group racket> racket>)")])) - (define (switch-parser stx) - (syntax-parse stx - [(_) #'(qi0->racket _)] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause)) - #'(qi0->racket consequent-gate)] - [(_ [(~datum else) alternative:clause]) - #'(qi0->racket alternative)] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [(~datum else) alternative:clause]) - #'(qi0->racket (~> consequent-gate alternative))] - [(_ [condition0:clause ((~datum =>) consequent0:clause ...)] - [condition:clause consequent:clause] - ...) - ;; we split the flow ahead of time to avoid evaluating - ;; the condition more than once - #'(qi0->racket (~> (-< condition0 _) - (if 1> - (~> consequent0 ...) - (group 1 ⏚ - (switch [condition consequent] - ...)))))] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [condition0:clause ((~datum =>) consequent0:clause ...)] - [condition:clause consequent:clause] - ...) - ;; both divert as well as => clauses. Here, the divert clause - ;; operates on the original inputs, not including the result - ;; of the condition flow. - ;; as before, we split the flow ahead of time to avoid evaluating - ;; the condition more than once - #'(qi0->racket (~> (-< (~> condition-gate condition0) _) - (if 1> - (~> (group 1 _ consequent-gate) - consequent0 ...) - (group 1 ⏚ - (switch (divert condition-gate consequent-gate) - [condition consequent] - ...)))))] - [(_ [condition0:clause consequent0:clause] - [condition:clause consequent:clause] - ...) - #'(qi0->racket (if condition0 - consequent0 - (switch [condition consequent] - ...)))] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [condition0:clause consequent0:clause] - [condition:clause consequent:clause] - ...) - #'(qi0->racket (if (~> condition-gate condition0) - (~> consequent-gate consequent0) - (switch (divert condition-gate consequent-gate) - [condition consequent] - ...)))])) - (define (sieve-parser stx) (syntax-parse stx [(_ condition:clause diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 219cd146c..2505af4aa 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -4,7 +4,6 @@ select-form block-form group-form - switch-form sieve-form partition-form try-form @@ -58,10 +57,6 @@ See comments in flow.rkt for more details. (pattern ((~datum group) arg ...))) -(define-syntax-class switch-form - (pattern - ((~datum switch) arg ...))) - (define-syntax-class sieve-form (pattern (~datum sieve)) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 22c117278..be9185d65 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -22,7 +22,8 @@ ==* bundle when - unless)) + unless + switch)) (require (for-syntax racket/base syntax/parse @@ -119,3 +120,65 @@ (define-qi-syntax-rule (unless condition:clause alternative:clause) (if condition ⏚ alternative)) + +(define-qi-syntax-parser switch + [(_) #'_] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause)) + #'consequent-gate] + [(_ [(~datum else) alternative:clause]) + #'alternative] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [(~datum else) alternative:clause]) + #'(~> consequent-gate alternative)] + [(_ [condition0:clause ((~datum =>) consequent0:clause ...)] + [condition:clause consequent:clause] + ...) + ;; we split the flow ahead of time to avoid evaluating + ;; the condition more than once + #'(~> (-< condition0 _) + (if 1> + (~> consequent0 ...) + (group 1 ⏚ + (switch [condition consequent] + ...))))] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [condition0:clause ((~datum =>) consequent0:clause ...)] + [condition:clause consequent:clause] + ...) + ;; both divert as well as => clauses. Here, the divert clause + ;; operates on the original inputs, not including the result + ;; of the condition flow. + ;; as before, we split the flow ahead of time to avoid evaluating + ;; the condition more than once + #'(~> (-< (~> condition-gate condition0) _) + (if 1> + (~> (group 1 _ consequent-gate) + consequent0 ...) + (group 1 ⏚ + (switch (divert condition-gate consequent-gate) + [condition consequent] + ...))))] + [(_ [condition0:clause consequent0:clause] + [condition:clause consequent:clause] + ...) + #'(if condition0 + consequent0 + (switch [condition consequent] + ...))] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [condition0:clause consequent0:clause] + [condition:clause consequent:clause] + ...) + #'(if (~> condition-gate condition0) + (~> consequent-gate consequent0) + (switch (divert condition-gate consequent-gate) + [condition consequent] + ...))]) From 5efed0b1d680f26d902f9bbe14d89dd93bdaa2b4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 19:12:41 -0700 Subject: [PATCH 037/338] extract `partition` and `gate` --- qi-lib/flow/core/compiler.rkt | 15 --------------- qi-lib/flow/core/syntax.rkt | 5 ----- qi-lib/flow/extended/forms.rkt | 15 ++++++++++++++- 3 files changed, 14 insertions(+), 21 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 470e923f2..ae4111b60 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -122,12 +122,6 @@ [((~datum not) onex:clause) ;; TODO #'(qi0->racket (~> onex NOT))] - ;;; Conditionals - - [e:partition-form (partition-parser #'e)] - [((~datum gate) onex:clause) - #'(qi0->racket (if onex _ ⏚))] - ;;; High level circuit elements ;; aliases for inputs @@ -276,15 +270,6 @@ the DSL. (syntax->datum #'(arg ...)) "(sieve racket> racket> racket>)")])) - (define (partition-parser stx) - (syntax-parse stx - [(_:id) - #'(qi0->racket ground)] - [(_ [cond:clause body:clause]) - #'(qi0->racket (~> (pass cond) body))] - [(_ [cond:clause body:clause] [conds:clause bodies:clause] ...+) - #'(qi0->racket (sieve cond body (partition [conds bodies] ...)))])) - (define (try-parser stx) (syntax-parse stx [(_ flo diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 2505af4aa..e26a6241d 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -5,7 +5,6 @@ block-form group-form sieve-form - partition-form try-form fanout-form feedback-form @@ -63,10 +62,6 @@ See comments in flow.rkt for more details. (pattern ((~datum sieve) arg ...))) -(define-syntax-class partition-form - (pattern - ({~datum partition} arg ...))) - (define-syntax-class try-form (pattern ((~datum try) arg ...))) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index be9185d65..2311e2f1a 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -23,7 +23,9 @@ bundle when unless - switch)) + switch + partition + gate)) (require (for-syntax racket/base syntax/parse @@ -182,3 +184,14 @@ (switch (divert condition-gate consequent-gate) [condition consequent] ...))]) + +(define-qi-syntax-parser partition + [(_:id) + #'ground] + [(_ [cond:clause body:clause]) + #'(~> (pass cond) body)] + [(_ [cond:clause body:clause] [conds:clause bodies:clause] ...+) + #'(sieve cond body (partition [conds bodies] ...))]) + +(define-qi-syntax-rule (gate onex:clause) + (if onex _ ⏚)) From a9387cc1c7a56908671eb4386b353c6b016500e0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 19:24:42 -0700 Subject: [PATCH 038/338] promote `not` and `pass` to core for convenience --- qi-lib/flow/core/compiler.rkt | 11 ++++------- qi-lib/flow/extended/forms.rkt | 4 ---- 2 files changed, 4 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index ae4111b60..301d69d15 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -63,7 +63,9 @@ #'((qi0->racket onex) ...))))] [e:relay-form (relay-parser #'e)] [e:tee-form (tee-parser #'e)] + ;; map and filter [e:amp-form (amp-parser #'e)] ; NOTE: technically not core + [e:pass-form (pass-parser #'e)] ; NOTE: technically not core ;; prisms [e:sep-form (sep-parser #'e)] [(~or* (~datum ▽) (~datum collect)) @@ -81,6 +83,8 @@ #'(conjoin (qi0->racket onex) ...)] [((~datum or) onex:clause ...) #'(disjoin (qi0->racket onex) ...)] + [((~datum not) onex:clause) ; NOTE: technically not core + #'(qi0->racket (~> onex NOT))] ;; selection [e:select-form (select-parser #'e)] [e:block-form (block-parser #'e)] @@ -117,11 +121,6 @@ ;;;; Non-core forms ;;;; ;;;;;;;;;;;;;;;;;;;;;;;; - ;;; Predicates - - [((~datum not) onex:clause) ;; TODO - #'(qi0->racket (~> onex NOT))] - ;;; High level circuit elements ;; aliases for inputs @@ -143,8 +142,6 @@ ;;; Higher-order flows - ;; map and filter - [e:pass-form (pass-parser #'e)] ;;; Miscellaneous diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 2311e2f1a..9805b025a 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -5,7 +5,6 @@ all any none - ;; not NOR NAND XNOR @@ -49,9 +48,6 @@ (define-qi-syntax-rule (none onex:clause) (not (any onex))) -;; (define-qi-syntax-rule (not onex:clause) -;; (~> onex NOT)) - (define-qi-syntax-parser NOR [_:id #'(~> OR NOT)]) From 52b761fd3c6c6b34db639f615bc880ce88acb7f2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 19:35:27 -0700 Subject: [PATCH 039/338] extract input aliases out of core --- qi-lib/flow/core/compiler.rkt | 32 +++----------------------------- qi-lib/flow/core/syntax.rkt | 13 ------------- qi-lib/flow/extended/forms.rkt | 33 ++++++++++++++++++++++++++++++++- 3 files changed, 35 insertions(+), 43 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 301d69d15..17ca51052 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -72,9 +72,9 @@ #'list] ;; predicates [(~or* (~datum AND) (~datum &)) ; NOTE: technically not core - #'(qi0->racket (>> (and 2> 1>) #t))] + #'(qi0->racket (>> (and (select 2) (select 1)) #t))] [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core - #'(qi0->racket (<< (or 1> 2>) #f))] + #'(qi0->racket (<< (or (select 1) (select 2)) #f))] [(~or* (~datum NOT) (~datum !)) #'not] [(~datum XOR) @@ -106,7 +106,7 @@ (~> car mapex)) _) (group 1 _ combex) loop2) - 2>))]) + (select 2)))]) loop2)] ;; towards universality [(~datum apply) @@ -121,11 +121,6 @@ ;;;; Non-core forms ;;;; ;;;;;;;;;;;;;;;;;;;;;;;; - ;;; High level circuit elements - - ;; aliases for inputs - [e:input-alias (input-alias-parser #'e)] - ;; common utilities [(~datum count) #'(qi0->racket (~> (>< 1) +))] @@ -285,27 +280,6 @@ the DSL. (syntax->datum #'(arg ...)) "(try [error-predicate-flo error-handler-flo] ...)")])) - (define (input-alias-parser stx) - (syntax-parse stx - [(~datum 1>) - #'(qi0->racket (select 1))] - [(~datum 2>) - #'(qi0->racket (select 2))] - [(~datum 3>) - #'(qi0->racket (select 3))] - [(~datum 4>) - #'(qi0->racket (select 4))] - [(~datum 5>) - #'(qi0->racket (select 5))] - [(~datum 6>) - #'(qi0->racket (select 6))] - [(~datum 7>) - #'(qi0->racket (select 7))] - [(~datum 8>) - #'(qi0->racket (select 8))] - [(~datum 9>) - #'(qi0->racket (select 9))])) - (define (if-parser stx) (syntax-parse stx [(_ consequent:clause diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index e26a6241d..2767ac748 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -12,7 +12,6 @@ amp-form relay-form tee-form - input-alias if-form pass-form fold-left-form @@ -66,18 +65,6 @@ See comments in flow.rkt for more details. (pattern ((~datum try) arg ...))) -(define-syntax-class input-alias - (pattern - (~or* (~datum 1>) - (~datum 2>) - (~datum 3>) - (~datum 4>) - (~datum 5>) - (~datum 6>) - (~datum 7>) - (~datum 8>) - (~datum 9>)))) - (define-syntax-class if-form (pattern ((~datum if) arg ...))) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 9805b025a..5bdd8fa5a 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -24,7 +24,16 @@ unless switch partition - gate)) + gate + 1> + 2> + 3> + 4> + 5> + 6> + 7> + 8> + 9>)) (require (for-syntax racket/base syntax/parse @@ -191,3 +200,25 @@ (define-qi-syntax-rule (gate onex:clause) (if onex _ ⏚)) + +;;; High level circuit elements + +;; aliases for inputs +(define-qi-syntax-parser 1> + [_:id #'(select 1)]) +(define-qi-syntax-parser 2> + [_:id #'(select 2)]) +(define-qi-syntax-parser 3> + [_:id #'(select 3)]) +(define-qi-syntax-parser 4> + [_:id #'(select 4)]) +(define-qi-syntax-parser 5> + [_:id #'(select 5)]) +(define-qi-syntax-parser 6> + [_:id #'(select 6)]) +(define-qi-syntax-parser 7> + [_:id #'(select 7)]) +(define-qi-syntax-parser 8> + [_:id #'(select 8)]) +(define-qi-syntax-parser 9> + [_:id #'(select 9)]) From d3ca5a53dc1713621c6c24695f6c62b8f488e7de Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 19:39:14 -0700 Subject: [PATCH 040/338] extract `count`, `live?` and `rectify` --- qi-lib/flow/core/compiler.rkt | 11 ----------- qi-lib/flow/extended/forms.rkt | 13 +++++++++++++ 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 17ca51052..514c10433 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -121,23 +121,12 @@ ;;;; Non-core forms ;;;; ;;;;;;;;;;;;;;;;;;;;;;;; - ;; common utilities - [(~datum count) - #'(qi0->racket (~> (>< 1) +))] - [(~datum live?) - #'(qi0->racket (~> count (> 0)))] - [((~datum rectify) v:expr ...) - #'(qi0->racket (if live? _ (gen v ...)))] - ;; high level routing [e:fanout-form (fanout-parser #'e)] [(~datum inverter) #'(qi0->racket (>< NOT))] [e:side-effect-form (side-effect-parser #'e)] - ;;; Higher-order flows - - ;;; Miscellaneous ;; backwards compat macro extensibility via Racket macros diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 5bdd8fa5a..03ab0013b 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -25,6 +25,9 @@ switch partition gate + count + live? + rectify 1> 2> 3> @@ -201,6 +204,16 @@ (define-qi-syntax-rule (gate onex:clause) (if onex _ ⏚)) +;;; Common utilities +(define-qi-syntax-parser count + [_:id #'(~> (>< 1) +)]) + +(define-qi-syntax-parser live? + [_:id #'(~> count (> 0))]) + +(define-qi-syntax-rule (rectify v:expr ...) + (if live? _ (gen v ...))) + ;;; High level circuit elements ;; aliases for inputs From c4456b2d876000ea00e0ca87784e5342e9396676 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 20:12:57 -0700 Subject: [PATCH 041/338] extract `fanout`, `inverter` and `effect` --- qi-lib/flow/core/compiler.rkt | 26 -------------------------- qi-lib/flow/core/syntax.rkt | 12 ------------ qi-lib/flow/extended/forms.rkt | 34 +++++++++++++++++++++++++++++++++- 3 files changed, 33 insertions(+), 39 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 514c10433..fcd0b2baa 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -121,12 +121,6 @@ ;;;; Non-core forms ;;;; ;;;;;;;;;;;;;;;;;;;;;;;; - ;; high level routing - [e:fanout-form (fanout-parser #'e)] - [(~datum inverter) - #'(qi0->racket (>< NOT))] - [e:side-effect-form (side-effect-parser #'e)] - ;;; Miscellaneous ;; backwards compat macro extensibility via Racket macros @@ -285,17 +279,6 @@ the DSL. (apply (qi0->racket consequent) args) (apply (qi0->racket alternative) args)))])) - (define (fanout-parser stx) - (syntax-parse stx - [_:id #'(qi0->racket -<)] - [(_ n:number) - ;; a slightly more efficient compile-time implementation - ;; for literally indicated N - #:with list-of-n-blanks #`#,(make-list (syntax->datum #'n) #'_) - #`(qi0->racket (-< . list-of-n-blanks))] - [(_ n:expr) - #'(qi0->racket (~> (-< (gen n) _) -<))])) - (define (feedback-parser stx) (syntax-parse stx [(_ ((~datum while) tilex:clause) @@ -331,15 +314,6 @@ the DSL. (apply (qi0->racket (feedback n flo)) args))])) - (define (side-effect-parser stx) - (syntax-parse stx - [(_ sidex:clause onex:clause) - #'(qi0->racket (-< (~> sidex ⏚) - onex))] - [(_ sidex:clause) - #'(qi0->racket (-< (~> sidex ⏚) - _))])) - (define (tee-parser stx) (syntax-parse stx [((~or* (~datum -<) (~datum tee)) onex:clause ...) diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 2767ac748..0901b862d 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -6,9 +6,7 @@ group-form sieve-form try-form - fanout-form feedback-form - side-effect-form amp-form relay-form tee-form @@ -69,22 +67,12 @@ See comments in flow.rkt for more details. (pattern ((~datum if) arg ...))) -(define-syntax-class fanout-form - (pattern - (~datum fanout)) - (pattern - ((~datum fanout) arg ...))) - (define-syntax-class feedback-form (pattern (~datum feedback)) (pattern ((~datum feedback) arg ...))) -(define-syntax-class side-effect-form - (pattern - ((~or* (~datum ε) (~datum effect)) arg ...))) - (define-syntax-class amp-form (pattern (~or* (~datum ><) (~datum amp))) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 03ab0013b..6bb66b107 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -25,6 +25,7 @@ switch partition gate + fanout count live? rectify @@ -36,10 +37,14 @@ 6> 7> 8> - 9>)) + 9> + inverter + effect + ε)) (require (for-syntax racket/base syntax/parse + (only-in racket/list make-list) "syntax.rkt" "../aux-syntax.rkt" "../../private/util.rkt") @@ -235,3 +240,30 @@ [_:id #'(select 8)]) (define-qi-syntax-parser 9> [_:id #'(select 9)]) + +;; high level routing +(define-qi-syntax-parser fanout + [_:id #'-<] + [(_ n:number) + ;; a slightly more efficient compile-time implementation + ;; for literally indicated N + ;; TODO: move this to a compiler optimization + #:with list-of-n-blanks #`#,(make-list (syntax->datum #'n) #'_) + #'(-< . list-of-n-blanks)] + [(_ n:expr) + #'(~> (-< (gen n) _) -<)]) + +(define-qi-syntax-parser inverter + [_:id #'(>< NOT)]) + +(define-qi-syntax-parser effect + [(_ sidex:clause onex:clause) + #'(-< (~> sidex ⏚) + onex)] + [(_ sidex:clause) + #'(-< (~> sidex ⏚) + _)]) + +;; TODO: alias +(define-qi-syntax-rule (ε arg ...) + (effect arg ...)) From a7b25de5f853e002af753bf61bf85e85200d574c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 25 Aug 2022 20:36:02 -0700 Subject: [PATCH 042/338] remove unused imports; a comment --- qi-lib/flow/core/compiler.rkt | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index fcd0b2baa..9ca71361f 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -5,8 +5,6 @@ (require (for-syntax racket/base syntax/parse racket/match - (only-in racket/list - make-list) "syntax.rkt" "../aux-syntax.rkt" (only-in "../../private/util.rkt" @@ -16,9 +14,7 @@ qi-macro-transformer) "impl.rkt" racket/function - (prefix-in fancy: fancy-app) - (only-in racket/list - make-list)) + (prefix-in fancy: fancy-app)) (begin-for-syntax ;; note: this does not return compiled code but instead, @@ -128,7 +124,7 @@ #'(ext-form expr ...)] ;; a literal is interpreted as a flow generating it - [e:literal (literal-parser #'e)] + [e:literal (literal-parser #'e)] ; TODO: how would we write this as a macro? ;; Partial application with syntactically pre-supplied arguments ;; in a blanket template From 21a875087ffef6ef3e239d4314ad10a344f69fdc Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 26 Aug 2022 20:39:06 -0700 Subject: [PATCH 043/338] Bindingspec pair-programming from this week's compiler meetup See https://github.com/countvajhula/qi/wiki/Qi-Compiler-Sync-Aug-26-2022 for detailed notes from the meetup. --- qi-lib/flow.rkt | 7 +- qi-lib/flow/core/compiler.rkt | 283 ++++++++++++++---------------- qi-lib/flow/core/syntax.rkt | 6 - qi-lib/flow/extended/expander.rkt | 165 ++++++++++++++++- qi-lib/flow/extended/forms.rkt | 4 + qi-lib/flow/extended/syntax.rkt | 28 ++- qi-lib/macro.rkt | 7 +- qi-lib/main.rkt | 3 +- qi-lib/threading.rkt | 24 ++- qi-test/tests/flow.rkt | 15 +- 10 files changed, 360 insertions(+), 182 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index ea2ffb14e..284b00716 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -1,7 +1,8 @@ #lang racket/base (provide flow - ☯) + ☯ + (all-from-out "flow/extended/expander.rkt")) (require syntax/parse/define (prefix-in fancy: fancy-app) @@ -11,8 +12,8 @@ (for-syntax racket/base syntax/parse (only-in "private/util.rkt" - report-syntax-error) - "flow/extended/expander.rkt") + report-syntax-error)) + "flow/extended/expander.rkt" "flow/core/compiler.rkt" (only-in "private/util.rkt" define-alias)) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 9ca71361f..e93b82a35 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -8,10 +8,8 @@ "syntax.rkt" "../aux-syntax.rkt" (only-in "../../private/util.rkt" - report-syntax-error)) - (only-in "../../macro.rkt" - qi-macro? - qi-macro-transformer) + report-syntax-error) + racket/format) "impl.rkt" racket/function (prefix-in fancy: fancy-app)) @@ -26,134 +24,112 @@ stx)) (define-syntax (qi0->racket stx) - (syntax-parse (cadr (syntax->list stx)) - ;; Check first whether the form is a macro. If it is, expand it. - ;; This is prioritized over other forms so that extensions may - ;; override built-in Qi forms. - [stx - #:with (~or* (m:id expr ...) m:id) #'stx - #:do [(define space-m ((make-interned-syntax-introducer 'qi) #'m))] - #:when (qi-macro? (syntax-local-value space-m (λ () #f))) - #:with expanded (syntax-local-apply-transformer - (qi-macro-transformer (syntax-local-value space-m)) - space-m - 'expression - #f - #'stx) - #'(qi0->racket expanded)] - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;; Core language forms ;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - [((~datum gen) ex:expr ...) - #'(λ _ (values ex ...))] - ;; pass-through (identity flow) - [(~datum _) #'values] - ;; routing - [(~or* (~datum ⏚) (~datum ground)) ; NOTE: technically not core - #'(qi0->racket (select))] - [((~or* (~datum ~>) (~datum thread)) onex:clause ...) - #`(compose . #,(reverse - (syntax->list - #'((qi0->racket onex) ...))))] - [e:relay-form (relay-parser #'e)] - [e:tee-form (tee-parser #'e)] - ;; map and filter - [e:amp-form (amp-parser #'e)] ; NOTE: technically not core - [e:pass-form (pass-parser #'e)] ; NOTE: technically not core - ;; prisms - [e:sep-form (sep-parser #'e)] - [(~or* (~datum ▽) (~datum collect)) - #'list] - ;; predicates - [(~or* (~datum AND) (~datum &)) ; NOTE: technically not core - #'(qi0->racket (>> (and (select 2) (select 1)) #t))] - [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core - #'(qi0->racket (<< (or (select 1) (select 2)) #f))] - [(~or* (~datum NOT) (~datum !)) - #'not] - [(~datum XOR) - #'parity-xor] - [((~datum and) onex:clause ...) - #'(conjoin (qi0->racket onex) ...)] - [((~datum or) onex:clause ...) - #'(disjoin (qi0->racket onex) ...)] - [((~datum not) onex:clause) ; NOTE: technically not core - #'(qi0->racket (~> onex NOT))] - ;; selection - [e:select-form (select-parser #'e)] - [e:block-form (block-parser #'e)] - [e:group-form (group-parser #'e)] - ;; conditionals - [e:if-form (if-parser #'e)] - [e:sieve-form (sieve-parser #'e)] - ;; exceptions - [e:try-form (try-parser #'e)] - ;; folds - [e:fold-left-form (fold-left-parser #'e)] - [e:fold-right-form (fold-right-parser #'e)] - ;; looping - [e:feedback-form (feedback-parser #'e)] - [e:loop-form (loop-parser #'e)] - [((~datum loop2) pred:clause mapex:clause combex:clause) - #'(letrec ([loop2 (qi0->racket (if pred - (~> (== (-< cdr - (~> car mapex)) _) - (group 1 _ combex) - loop2) - (select 2)))]) - loop2)] - ;; towards universality - [(~datum apply) - #'call] - [e:clos-form (clos-parser #'e)] - ;; escape hatch for racket expressions or anything - ;; to be "passed through" - [((~datum esc) ex:expr) - #'ex] - - ;;;;;;;;;;;;;;;;;;;;;;;; - ;;;; Non-core forms ;;;; - ;;;;;;;;;;;;;;;;;;;;;;;; - - ;;; Miscellaneous - - ;; backwards compat macro extensibility via Racket macros - [((~var ext-form (starts-with "qi:")) expr ...) - #'(ext-form expr ...)] - - ;; a literal is interpreted as a flow generating it - [e:literal (literal-parser #'e)] ; TODO: how would we write this as a macro? - - ;; Partial application with syntactically pre-supplied arguments - ;; in a blanket template - [e:blanket-template-form (blanket-template-form-parser #'e)] - - ;; Fine-grained template-based application - ;; This handles templates that indicate a specific number of template - ;; variables (i.e. expected arguments). The semantics of template-based - ;; application here is fulfilled by the fancy-app module. In order to use - ;; it, we simply use the #%app macro provided by fancy-app instead of the - ;; implicit one used for function application in racket/base. - ;; "prarg" = "pre-supplied argument" - [(prarg-pre ... (~datum _) prarg-post ...) - #'(fancy:#%app prarg-pre ... _ prarg-post ...)] - - ;; Pre-supplied arguments without a template - [(natex prarg ...+) - ;; we use currying instead of templates when a template hasn't - ;; explicitly been indicated since in such cases, we cannot - ;; always infer the appropriate arity for a template (e.g. it - ;; may change under composition within the form), while a - ;; curried function will accept any number of arguments - #:do [(define chirality (syntax-property this-syntax 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(curry natex prarg ...) - #'(curryr natex prarg ...))] - - ;; literally indicated function identifier - [natex:expr #'natex])) + (let ([result (syntax-parse (cadr (syntax->list stx)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; Core language forms ;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + [((~datum gen) ex:expr ...) + #'(λ _ (values ex ...))] + ;; pass-through (identity flow) + [(~datum _) #'values] + ;; routing + [(~or* (~datum ⏚) (~datum ground)) ; NOTE: technically not core + #'(qi0->racket (select))] + [((~or* (~datum ~>) (~datum thread)) onex:clause ...) + #`(compose . #,(reverse + (syntax->list + #'((qi0->racket onex) ...))))] + [e:relay-form (relay-parser #'e)] + [e:tee-form (tee-parser #'e)] + ;; map and filter + [e:amp-form (amp-parser #'e)] ; NOTE: technically not core + [e:pass-form (pass-parser #'e)] ; NOTE: technically not core + ;; prisms + [e:sep-form (sep-parser #'e)] + [(~or* (~datum ▽) (~datum collect)) + #'list] + ;; predicates + [(~or* (~datum AND) (~datum &)) ; NOTE: technically not core + #'(qi0->racket (>> (and (select 2) (select 1)) (gen #t)))] + [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core + #'(qi0->racket (<< (or (select 1) (select 2)) (gen #f)))] + [(~or* (~datum NOT) (~datum !)) + #'not] + [(~datum XOR) + #'parity-xor] + [((~datum and) onex:clause ...) + #'(conjoin (qi0->racket onex) ...)] + [((~datum or) onex:clause ...) + #'(disjoin (qi0->racket onex) ...)] + [((~datum not) onex:clause) ; NOTE: technically not core + #'(qi0->racket (~> onex NOT))] + ;; selection + [e:select-form (select-parser #'e)] + [e:block-form (block-parser #'e)] + [e:group-form (group-parser #'e)] + ;; conditionals + [e:if-form (if-parser #'e)] + [e:sieve-form (sieve-parser #'e)] + ;; exceptions + [e:try-form (try-parser #'e)] + ;; folds + [e:fold-left-form (fold-left-parser #'e)] + [e:fold-right-form (fold-right-parser #'e)] + ;; looping + [e:feedback-form (feedback-parser #'e)] + [e:loop-form (loop-parser #'e)] + [((~datum loop2) pred:clause mapex:clause combex:clause) + #'(letrec ([loop2 (qi0->racket (if pred + (~> (== (-< (esc cdr) + (~> (esc car) mapex)) _) + (group 1 _ combex) + (esc loop2)) + (select 2)))]) + loop2)] + ;; towards universality + [(~datum appleye) + #'call] + [e:clos-form (clos-parser #'e)] + ;; escape hatch for racket expressions or anything + ;; to be "passed through" + [((~datum esc) ex:expr) + #'ex] + + ;;; Miscellaneous + + ;; Partial application with syntactically pre-supplied arguments + ;; in a blanket template + ;; Note: at this point it's already been parsed/validated + ;; and we don't need to worry about checking at the compiler + ;; level + [((~datum #%blanket-template) e) + (blanket-template-form-parser this-syntax)] + + ;; Fine-grained template-based application + ;; This handles templates that indicate a specific number of template + ;; variables (i.e. expected arguments). The semantics of template-based + ;; application here is fulfilled by the fancy-app module. In order to use + ;; it, we simply use the #%app macro provided by fancy-app instead of the + ;; implicit one used for function application in racket/base. + ;; "prarg" = "pre-supplied argument" + [((~datum #%fine-template) (prarg-pre ... (~datum _) prarg-post ...)) + #'(fancy:#%app prarg-pre ... _ prarg-post ...)] + + ;; Pre-supplied arguments without a template + [((~datum #%partial-application) (natex prarg ...+)) + ;; we use currying instead of templates when a template hasn't + ;; explicitly been indicated since in such cases, we cannot + ;; always infer the appropriate arity for a template (e.g. it + ;; may change under composition within the form), while a + ;; curried function will accept any number of arguments + #:do [(define chirality (syntax-property this-syntax 'chirality))] + (if (and chirality (eq? chirality 'right)) + #'(curry natex prarg ...) + #'(curryr natex prarg ...))])]) + (displayln (~a "qi0->racket output" result)) + result)) ;; The form-specific parsers, which are delegated to from ;; the qi0->racket macro: @@ -179,14 +155,14 @@ the DSL. (define (sep-parser stx) (syntax-parse stx [_:id - #'(qi0->racket (if list? - (apply values _) - (raise-argument-error '△ - "list?" - _)))] + #'(qi0->racket (if (esc list?) + (#%fine-template (apply values _)) + (#%fine-template (raise-argument-error '△ + "list?" + _))))] [(_ onex:clause) #'(λ (v . vs) - ((qi0->racket (~> △ (>< (apply (qi0->racket onex) _ vs)))) v))])) + ((qi0->racket (~> △ (>< (#%fine-template (apply (qi0->racket onex) _ vs))))) v))])) (define (select-parser stx) (syntax-parse stx @@ -216,7 +192,9 @@ the DSL. n)] [_:id #'(λ (n selection-flo remainder-flo . vs) - (apply (qi0->racket (group n selection-flo remainder-flo)) vs))] + (apply (qi0->racket (group n + (esc selection-flo) + (esc remainder-flo))) vs))] [(_ arg ...) ; error handling catch-all (report-syntax-error 'group (syntax->datum #'(arg ...)) @@ -233,8 +211,8 @@ the DSL. ;; sieve can be a core form once bindings ;; are introduced into the language #'(λ (condition sonex ronex . args) - (apply (qi0->racket (-< (~> (pass condition) sonex) - (~> (pass (not condition)) ronex))) + (apply (qi0->racket (-< (~> (pass (esc condition)) (esc sonex)) + (~> (pass (not (esc condition))) (esc ronex)))) args))] [(_ arg ...) ; error handling catch-all (report-syntax-error 'sieve @@ -286,7 +264,7 @@ the DSL. [(_ ((~datum while) tilex:clause) ((~datum then) thenex:clause)) #'(λ (f . args) - (apply (qi0->racket (feedback (while tilex) (then thenex) f)) + (apply (qi0->racket (feedback (while tilex) (then thenex) (esc f))) args))] [(_ ((~datum while) tilex:clause) onex:clause) #'(qi0->racket (feedback (while tilex) (then _) onex))] @@ -299,7 +277,7 @@ the DSL. [(_ n:expr ((~datum then) thenex:clause)) #'(λ (f . args) - (apply (qi0->racket (feedback n (then thenex) f)) args))] + (apply (qi0->racket (feedback n (then thenex) (esc f))) args))] [(_ n:expr onex:clause) #'(qi0->racket (feedback n (then _) onex))] [(_ onex:clause) @@ -307,7 +285,7 @@ the DSL. (apply (qi0->racket (feedback n onex)) args))] [_:id #'(λ (n flo . args) - (apply (qi0->racket (feedback n flo)) + (apply (qi0->racket (feedback n (esc flo))) args))])) (define (tee-parser stx) @@ -389,9 +367,12 @@ the DSL. [(_ pred:clause mapex:clause) #'(qi0->racket (loop pred mapex _ ⏚))] [(_ mapex:clause) - #'(qi0->racket (loop #t mapex _ ⏚))] + #'(qi0->racket (loop (gen #t) mapex _ ⏚))] [_:id #'(λ (predf mapf combf retf . args) - (apply (qi0->racket (loop predf mapf combf retf)) + (apply (qi0->racket (loop (esc predf) + (esc mapf) + (esc combf) + (esc retf))) args))])) (define (clos-parser stx) @@ -418,13 +399,15 @@ the DSL. (define (blanket-template-form-parser stx) (syntax-parse stx ;; "prarg" = "pre-supplied argument" - [(natex prarg-pre ...+ (~datum __) prarg-post ...+) + [((~datum #%blanket-template) + (natex prarg-pre ...+ (~datum __) prarg-post ...+)) #'(curry (curryr natex prarg-post ...) prarg-pre ...)] - [(natex prarg-pre ...+ (~datum __)) + [((~datum #%blanket-template) (natex prarg-pre ...+ (~datum __))) #'(curry natex prarg-pre ...)] - [(natex (~datum __) prarg-post ...+) + [((~datum #%blanket-template) + (natex (~datum __) prarg-post ...+)) #'(curryr natex prarg-post ...)] - [(natex (~datum __)) + [((~datum #%blanket-template) (natex (~datum __))) #'natex]))) diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 0901b862d..8fead4de9 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -15,7 +15,6 @@ fold-left-form fold-right-form loop-form - blanket-template-form clos-form) (require syntax/parse) @@ -115,11 +114,6 @@ See comments in flow.rkt for more details. (pattern ((~datum loop) arg ...))) -(define-syntax-class blanket-template-form - ;; "prarg" = "pre-supplied argument" - (pattern - (natex prarg-pre ... (~datum __) prarg-post ...))) - (define-syntax-class clos-form (pattern (~datum clos)) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index e6a2d7966..aeead30be 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -1,6 +1,165 @@ #lang racket/base -(provide expand-flow) +(provide (for-syntax expand-flow + qi-macro) + (for-space qi + (all-defined-out) + (rename-out [ground ⏚] + [thread ~>] + [relay ==] + [tee -<] + [amp ><] + [sep △] + [collect ▽]))) -(define (expand-flow stx) - stx) +(require bindingspec + (for-syntax "../aux-syntax.rkt" + "syntax.rkt" + racket/base + syntax/parse + "../../private/util.rkt" + racket/format)) + +(define-hosted-syntaxes + (extension-class qi-macro + #:binding-space qi) + (nonterminal floe + ;; Check first whether the form is a macro. If it is, expand it. + ;; This is prioritized over other forms so that extensions may + ;; override built-in Qi forms. + #:allow-extension qi-macro + #:binding-space qi + (gen e:expr ...) + ;; hack to allow _ to be used ... + (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) + _ + ground + (thread f:floe ...) + (relay f:floe ...) + relay + (tee f:floe ...) + tee + amp + (amp f:floe) + (~>/form (amp f0:clause f:clause ...) + ;; potentially pull out as a phase 1 function + ;; just a stopgap until better error messages + (report-syntax-error + 'amp + (syntax->datum #'(f0 f ...)) + "(>< flo)" + "amp expects a single flow specification, but it received many.")) + pass + (pass f:floe) + sep + (sep f:floe) + collect + AND + OR + NOT + XOR + (and f:floe ...) + (or f:floe ...) + (not f:floe) + (select e:expr ...) + (~>/form (select arg ...) + (report-syntax-error 'select + (syntax->datum #'(arg ...)) + "(select ...)")) + (block e:expr ...) + (~>/form (block arg ...) + (report-syntax-error 'block + (syntax->datum #'(arg ...)) + "(block ...)")) + (group n:expr e1:floe e2:floe) + group + (~>/form (group arg ...) + (report-syntax-error 'group + (syntax->datum #'(arg ...)) + "(group )")) + (if consequent:floe + alternative:floe) + (if condition:floe + consequent:floe + alternative:floe) + (sieve condition:floe + sonex:floe + ronex:floe) + sieve + (~>/form (sieve arg ...) + (report-syntax-error 'sieve + (syntax->datum #'(arg ...)) + "(sieve )")) + (try flo:floe + [error-condition-flo:floe error-handler-flo:floe] + ...+) + (~>/form (try arg ...) + (report-syntax-error 'try + (syntax->datum #'(arg ...)) + "(try [error-predicate-flo error-handler-flo] ...)")) + >> + (>> fn:floe init:floe) + (>> fn:floe) + << + (<< fn:floe init:floe) + (<< fn:floe) + (feedback ((~datum while) tilex:floe) + ((~datum then) thenex:floe) + onex:floe) + (feedback ((~datum while) tilex:floe) + ((~datum then) thenex:floe)) + (feedback ((~datum while) tilex:floe) onex:floe) + (feedback ((~datum while) tilex:floe)) + (feedback n:expr + ((~datum then) thenex:floe) + onex:floe) + (feedback n:expr + ((~datum then) thenex:floe)) + (feedback n:expr onex:floe) + (feedback onex:floe) + feedback + (loop pred:floe mapex:floe combex:floe retex:floe) + (loop pred:floe mapex:floe combex:floe) + (loop pred:floe mapex:floe) + (loop mapex:floe) + loop + (loop2 pred:floe mapex:floe combex:floe) + appleye + (~> (~literal apply) #'appleye) + clos + (clos onex:floe) + (esc ex:expr) + ;; backwards compat macro extensibility via Racket macros + (~> ((~var ext-form (starts-with "qi:")) expr ...) + #'(esc (ext-form expr ...))) + ;; a literal is interpreted as a flow generating it + (~> val:literal + #'(gen val)) + (~> f:blanket-template-form + #'(#%blanket-template f)) + (#%blanket-template (arg:any-stx ...)) + ;; (~> v:expr (begin (displayln "hello!") (error 'bye))) + (~> f:fine-template-form + #'(#%fine-template f)) + (#%fine-template (arg:any-stx ...)) + (#%partial-application (arg:any-stx ...)) + (~> f:partial-application-form + #'(#%partial-application f)) + ;; literally indicated function identifier + ;; TODO: make this id rather than expr once + ;; everything else is stable + (~> f:expr #'(esc f)))) + +;; 1. extension class +;; 2. nonterminal +(begin-for-syntax + (define (expand-flow stx) + (displayln (~a "input: " stx)) + (syntax-parse stx + [(a:id . _) (displayln (~a "syntax info: " + (syntax-debug-info + ((make-interned-syntax-introducer 'qi) #'a))))] + [_ (void)]) + (let ([result ((nonterminal-expander floe) stx)]) + (displayln (~a "output: " result)) + result))) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 6bb66b107..fca7cf1af 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -38,6 +38,9 @@ 7> 8> 9> + ;; try rename-out instead of + ;; duplicate macros below, as + ;; an alternative to define-qi-alias inverter effect ε)) @@ -48,6 +51,7 @@ "syntax.rkt" "../aux-syntax.rkt" "../../private/util.rkt") + "expander.rkt" "../../macro.rkt" "impl.rkt") diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index 084ae1053..0d151e43e 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -2,7 +2,11 @@ (provide conjux-clause disjux-clause - right-threading-clause) + right-threading-clause + blanket-template-form + fine-template-form + partial-application-form + any-stx) (require syntax/parse "../aux-syntax.rkt" @@ -33,3 +37,25 @@ (pattern onex:clause #:with chiral (make-right-chiral #'onex))) + +(define-syntax-class blanket-template-form + ;; "prarg" = "pre-supplied argument" + (pattern + (natex prarg-pre ... (~datum __) prarg-post ...))) + +(define-syntax-class fine-template-form + ;; "prarg" = "pre-supplied argument" + (pattern + ;; note these are used in the expander instead of in the compiler + ;; that's why they don't need the tag + (prarg-pre ... (~datum _) prarg-post ...))) + +(define-syntax-class partial-application-form + ;; "prarg" = "pre-supplied argument" + (pattern + ;; note these are used in the expander instead of in the compiler + ;; that's why they don't need the tag + (natex prarg ...+))) + +(define-syntax-class any-stx + (pattern _)) diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index a90e02ade..08bbccdbe 100644 --- a/qi-lib/macro.rkt +++ b/qi-lib/macro.rkt @@ -5,21 +5,20 @@ define-qi-syntax-parser define-qi-alias define-qi-foreign-syntaxes - (for-syntax qi-macro? - qi-macro-transformer - qi-macro)) + (for-syntax qi-macro)) (require (for-syntax racket/base syntax/parse racket/format racket/match racket/list) + (only-in "flow/extended/expander.rkt" + qi-macro) racket/format syntax/parse/define syntax/parse) (begin-for-syntax - (struct qi-macro [transformer]) (define (foreign-template-arg-indices tmpl) ;; return a list of indices corresponding to diff --git a/qi-lib/main.rkt b/qi-lib/main.rkt index c0209af81..9d2ddb6fb 100644 --- a/qi-lib/main.rkt +++ b/qi-lib/main.rkt @@ -10,8 +10,7 @@ (require qi/flow (except-in qi/macro - qi-macro-transformer - qi-macro?) + qi-macro) qi/on qi/switch qi/threading diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 7c20effe7..3e4020c4b 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -1,16 +1,17 @@ #lang racket/base -(provide ~> - ~>>) +(provide (rename-out [R~> ~>] + [R~>> ~>>])) (require syntax/parse/define (for-syntax racket/base (only-in "private/util.rkt" report-syntax-error) "flow/aux-syntax.rkt") + "flow.rkt" "on.rkt") -(define-syntax-parser ~> +(define-syntax-parser R~> [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error '~> @@ -20,9 +21,14 @@ "Note that the inputs to ~> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) - #'(on ags (~> clause ...))]) + #'(on ags (~> clause ...)) + ;; tweak report-syntax-error to give srcloc + ;; (raise-syntax-error #f "Error!" this-syntax) + ]) -(define-syntax-parser ~>> +;; (raise-syntax-error #f "Error!" this-syntax) + +(define-syntax-parser R~>> [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error '~>> @@ -32,4 +38,10 @@ "Note that the inputs to ~>> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) - #'(on ags (~>> clause ...))]) + #'(on ags (~>> clause ...)) + ;; (report-syntax-error '~>> + ;; (syntax->datum #'((args) sep clause ...)) + ;; "(~>> (arg ...) flo ...)" + ;; "ERROR" + ;; "Note that the inputs to ~>> must be wrapped in parentheses.") + ]) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 68c33fafb..5902bf926 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -857,10 +857,10 @@ 1 -3 5) (list 1 1 5 5 -3) "sieve with arity-increasing clause") - (check-equal? (~> (1 2 -3 4) - (-< (gen positive? + (☯ (+ 2))) _) - sieve - ▽) + (check-equal? ((☯ (~> (-< (gen positive? + (☯ (+ 2))) _) + sieve + ▽)) + 1 2 -3 4) (list 7 -1) "pure control form of sieve")) (test-suite @@ -933,11 +933,12 @@ 9)) (test-suite "fanout" - (check-equal? (~> (5) (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽)) + 5) (list 5 5 5)) - (check-equal? (~> (2 3) (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽)) 2 3) (list 2 3 2 3 2 3)) - (check-equal? (~> (3 "a") fanout string-append) + (check-equal? (~> (3 "a") fanout string-append) ; TODO: don't use Racket-level ~> in this module "aaa" "control form of fanout") (check-equal? (~> (3 "a" "b") fanout string-append) From f00200fc0194e77812ea2935275b77ce7c076df8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 31 Aug 2022 19:51:31 -0700 Subject: [PATCH 044/338] Report source location info in `report-syntax-error` --- qi-lib/private/util.rkt | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/qi-lib/private/util.rkt b/qi-lib/private/util.rkt index 1dd34c618..4a6c329aa 100644 --- a/qi-lib/private/util.rkt +++ b/qi-lib/private/util.rkt @@ -6,21 +6,25 @@ (require racket/string racket/format + racket/match syntax/parse/define (for-syntax racket/base syntax/parse/lib/function-header)) -(define (report-syntax-error name args usage . msgs) - (raise-syntax-error name - (~a "Syntax error in " - (list* name args) - "\n" - "Usage:\n" - " " usage - (if (null? msgs) - "" - (string-append "\n" - (string-join msgs "\n")))))) +(define (report-syntax-error stx usage . msgs) + (match (syntax->datum stx) + [(cons name args) + (raise-syntax-error name + (~a "Syntax error in " + (list* name args) + "\n" + "Usage:\n" + " " usage + (if (null? msgs) + "" + (string-append "\n" + (string-join msgs "\n")))) + stx)])) (define-syntax-parse-rule (define-alias alias:id name:id) (define-syntax alias (make-rename-transformer #'name))) From 0f43627574f8d3f428229609bd6ae2814de4e1c3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 31 Aug 2022 19:59:59 -0700 Subject: [PATCH 045/338] Remove error-handling code from the compiler --- qi-lib/flow/core/compiler.rkt | 40 ++++++----------------------------- 1 file changed, 6 insertions(+), 34 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index e93b82a35..ecaefc754 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -7,8 +7,6 @@ racket/match "syntax.rkt" "../aux-syntax.rkt" - (only-in "../../private/util.rkt" - report-syntax-error) racket/format) "impl.rkt" racket/function @@ -166,21 +164,13 @@ the DSL. (define (select-parser stx) (syntax-parse stx - [(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'select - (syntax->datum #'(arg ...)) - "(select ...)")])) + [(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))])) (define (block-parser stx) (syntax-parse stx [(_ n:number ...) #'(qi0->racket (~> (esc (except-args n ...)) - △))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'block - (syntax->datum #'(arg ...)) - "(block ...)")])) + △))])) (define (group-parser stx) (syntax-parse stx @@ -194,11 +184,7 @@ the DSL. #'(λ (n selection-flo remainder-flo . vs) (apply (qi0->racket (group n (esc selection-flo) - (esc remainder-flo))) vs))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'group - (syntax->datum #'(arg ...)) - "(group racket> racket>)")])) + (esc remainder-flo))) vs))])) (define (sieve-parser stx) (syntax-parse stx @@ -213,11 +199,7 @@ the DSL. #'(λ (condition sonex ronex . args) (apply (qi0->racket (-< (~> (pass (esc condition)) (esc sonex)) (~> (pass (not (esc condition))) (esc ronex)))) - args))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'sieve - (syntax->datum #'(arg ...)) - "(sieve racket> racket> racket>)")])) + args))])) (define (try-parser stx) (syntax-parse stx @@ -231,11 +213,7 @@ the DSL. ;; error via a binding / syntax parameter (apply (qi0->racket error-handler-flo) args))] ...) - (apply (qi0->racket flo) args)))] - [(_ arg ...) - (report-syntax-error 'try - (syntax->datum #'(arg ...)) - "(try [error-predicate-flo error-handler-flo] ...)")])) + (apply (qi0->racket flo) args)))])) (define (if-parser stx) (syntax-parse stx @@ -314,13 +292,7 @@ the DSL. [_:id #'(qi0->racket ==)] [(_ onex:clause) - #'(qi0->racket (loop onex))] - [(_ onex0:clause onex:clause ...) - (report-syntax-error - 'amp - (syntax->datum #'(onex0 onex ...)) - "(>< flo)" - "amp expects a single qi0->racket specification, but it received many.")])) + #'(qi0->racket (loop onex))])) (define (pass-parser stx) (syntax-parse stx From c8128c6a0d5b630ac8c40f348d4dc1881cfc2ec3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 31 Aug 2022 20:09:06 -0700 Subject: [PATCH 046/338] Use the new `report-syntax-error` interface --- qi-lib/flow.rkt | 3 +-- qi-lib/flow/extended/expander.rkt | 18 ++++++------------ qi-lib/threading.rkt | 6 ++---- qi-test/tests/util.rkt | 3 +-- 4 files changed, 10 insertions(+), 20 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index 284b00716..afe655c88 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -41,7 +41,6 @@ in the flow macro. ;; error handling catch-all [(_ expr0 expr ...+) (report-syntax-error - 'flow - (syntax->datum #'(expr0 expr ...)) + this-syntax "(flow flo)" "flow expects a single flow specification, but it received many.")]) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index aeead30be..bd2603711 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -45,8 +45,7 @@ ;; potentially pull out as a phase 1 function ;; just a stopgap until better error messages (report-syntax-error - 'amp - (syntax->datum #'(f0 f ...)) + this-syntax "(>< flo)" "amp expects a single flow specification, but it received many.")) pass @@ -63,19 +62,16 @@ (not f:floe) (select e:expr ...) (~>/form (select arg ...) - (report-syntax-error 'select - (syntax->datum #'(arg ...)) + (report-syntax-error this-syntax "(select ...)")) (block e:expr ...) (~>/form (block arg ...) - (report-syntax-error 'block - (syntax->datum #'(arg ...)) + (report-syntax-error this-syntax "(block ...)")) (group n:expr e1:floe e2:floe) group (~>/form (group arg ...) - (report-syntax-error 'group - (syntax->datum #'(arg ...)) + (report-syntax-error this-syntax "(group )")) (if consequent:floe alternative:floe) @@ -87,15 +83,13 @@ ronex:floe) sieve (~>/form (sieve arg ...) - (report-syntax-error 'sieve - (syntax->datum #'(arg ...)) + (report-syntax-error this-syntax "(sieve )")) (try flo:floe [error-condition-flo:floe error-handler-flo:floe] ...+) (~>/form (try arg ...) - (report-syntax-error 'try - (syntax->datum #'(arg ...)) + (report-syntax-error this-syntax "(try [error-predicate-flo error-handler-flo] ...)")) >> (>> fn:floe init:floe) diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 3e4020c4b..9af332a60 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -14,8 +14,7 @@ (define-syntax-parser R~> [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error - (report-syntax-error '~> - (syntax->datum #'((arg0 arg ...) sep clause ...)) + (report-syntax-error this-syntax "(~> (arg ...) flo ...)" "Attempted to separate multiple values." "Note that the inputs to ~> must be wrapped in parentheses.")] @@ -31,8 +30,7 @@ (define-syntax-parser R~>> [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error - (report-syntax-error '~>> - (syntax->datum #'((arg0 arg ...) sep clause ...)) + (report-syntax-error this-syntax "(~>> (arg ...) flo ...)" "Attempted to separate multiple values." "Note that the inputs to ~>> must be wrapped in parentheses.")] diff --git a/qi-test/tests/util.rkt b/qi-test/tests/util.rkt index c3fd81232..ffa87a15f 100644 --- a/qi-test/tests/util.rkt +++ b/qi-test/tests/util.rkt @@ -14,8 +14,7 @@ (test-suite "report-syntax-error" (check-exn exn:fail:syntax? - (thunk (report-syntax-error 'dummy - (list 1 2 3) + (thunk (report-syntax-error #'(dummy 1 2 3) "blah: blah" "Use it" "like" From f6b0bf2858a93aa5d4a19d4736f48a9b07b6d69d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 2 Sep 2022 19:44:53 -0700 Subject: [PATCH 047/338] Restore end-to-end functionality including bindingspec This was done in a pairing session in today's Qi compiler meetup. More details on the wiki: https://github.com/countvajhula/qi/wiki/Qi-Compiler-Sync-Sept-2-2022 --- qi-doc/scribblings/field-guide.scrbl | 4 +++- qi-doc/scribblings/forms.scrbl | 4 +++- qi-doc/scribblings/interface.scrbl | 4 +++- qi-doc/scribblings/intro.scrbl | 8 +++++--- qi-doc/scribblings/macros.scrbl | 4 +++- qi-doc/scribblings/tutorial.scrbl | 4 +++- qi-lib/flow.rkt | 18 +++++++++++++++++- qi-lib/flow/extended/expander.rkt | 5 ----- qi-lib/macro.rkt | 3 ++- qi-lib/main.rkt | 6 ++---- qi-lib/switch.rkt | 6 +++--- qi-test/tests/flow-dummy.rkt | 23 +++++++++++++++++++++++ 12 files changed, 67 insertions(+), 22 deletions(-) create mode 100644 qi-test/tests/flow-dummy.rkt diff --git a/qi-doc/scribblings/field-guide.scrbl b/qi-doc/scribblings/field-guide.scrbl index 853093cd3..b0d704ac0 100644 --- a/qi-doc/scribblings/field-guide.scrbl +++ b/qi-doc/scribblings/field-guide.scrbl @@ -8,6 +8,8 @@ racket]] @(define eval-for-docs + (call-with-trusted-sandbox-configuration + (lambda () (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-memory-limit #f]) @@ -19,7 +21,7 @@ (for-syntax syntax/parse racket/base)) '(define (sqr x) - (* x x))))) + (* x x))))))) @title{Field Guide} diff --git a/qi-doc/scribblings/forms.scrbl b/qi-doc/scribblings/forms.scrbl index cd5ef1f4c..58956aad2 100644 --- a/qi-doc/scribblings/forms.scrbl +++ b/qi-doc/scribblings/forms.scrbl @@ -7,6 +7,8 @@ racket]] @(define eval-for-docs + (call-with-trusted-sandbox-configuration + (lambda () (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-memory-limit #f]) @@ -15,7 +17,7 @@ (only-in racket/list range first rest) racket/string) '(define (sqr x) - (* x x))))) + (* x x))))))) @(define diagram-eval (make-base-eval)) @(diagram-eval '(require metapict)) diff --git a/qi-doc/scribblings/interface.scrbl b/qi-doc/scribblings/interface.scrbl index 70cdcbaf6..1d272d239 100644 --- a/qi-doc/scribblings/interface.scrbl +++ b/qi-doc/scribblings/interface.scrbl @@ -8,6 +8,8 @@ syntax/parse/define]] @(define eval-for-docs + (call-with-trusted-sandbox-configuration + (lambda () (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-memory-limit #f]) @@ -17,7 +19,7 @@ racket/string) '(define ->string number->string) '(define (sqr x) - (* x x))))) + (* x x))))))) @title{Language Interface} diff --git a/qi-doc/scribblings/intro.scrbl b/qi-doc/scribblings/intro.scrbl index a8968f8cd..aedb37e25 100644 --- a/qi-doc/scribblings/intro.scrbl +++ b/qi-doc/scribblings/intro.scrbl @@ -7,15 +7,17 @@ racket]] @(define eval-for-docs - (parameterize ([sandbox-output 'string] + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-memory-limit #f]) - (make-evaluator 'racket/base + (make-evaluator 'racket/base '(require qi (only-in racket/list range) racket/string) '(define (sqr x) - (* x x))))) + (* x x))))))) @title{Introduction and Usage} diff --git a/qi-doc/scribblings/macros.scrbl b/qi-doc/scribblings/macros.scrbl index 3c33dedf1..d55ca3f0b 100644 --- a/qi-doc/scribblings/macros.scrbl +++ b/qi-doc/scribblings/macros.scrbl @@ -9,6 +9,8 @@ syntax/parse/define]] @(define eval-for-docs + (call-with-trusted-sandbox-configuration + (lambda () (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-memory-limit #f]) @@ -18,7 +20,7 @@ (for-syntax syntax/parse racket/base) racket/string) '(define (sqr x) - (* x x))))) + (* x x))))))) @title[#:tag "Qi_Macros"]{Qi Macros} diff --git a/qi-doc/scribblings/tutorial.scrbl b/qi-doc/scribblings/tutorial.scrbl index 054fcc9ca..d1b749df8 100644 --- a/qi-doc/scribblings/tutorial.scrbl +++ b/qi-doc/scribblings/tutorial.scrbl @@ -8,6 +8,8 @@ racket]] @(define eval-for-docs + (call-with-trusted-sandbox-configuration + (lambda () (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-memory-limit #f]) @@ -17,7 +19,7 @@ (only-in racket/function curry) racket/string) '(define (sqr x) - (* x x))))) + (* x x))))))) @title{Tutorial} diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index afe655c88..1cebaef78 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -2,7 +2,9 @@ (provide flow ☯ - (all-from-out "flow/extended/expander.rkt")) + flow-dummy + (all-from-out "flow/extended/expander.rkt") + (all-from-out "flow/extended/forms.rkt")) (require syntax/parse/define (prefix-in fancy: fancy-app) @@ -15,6 +17,7 @@ report-syntax-error)) "flow/extended/expander.rkt" "flow/core/compiler.rkt" + "flow/extended/forms.rkt" (only-in "private/util.rkt" define-alias)) @@ -44,3 +47,16 @@ in the flow macro. this-syntax "(flow flo)" "flow expects a single flow specification, but it received many.")]) + +(define-syntax-parser flow-dummy + [(_ onex) (let ([stx (expand-flow #'onex)]) + (displayln (syntax-property (cadr (syntax->list stx)) 'chirality)) + stx)] + ;; a non-flow + [_ #'values] + ;; error handling catch-all + [(_ expr0 expr ...+) + (report-syntax-error + this-syntax + "(flow flo)" + "flow expects a single flow specification, but it received many.")]) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index bd2603711..c11b16c04 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -149,11 +149,6 @@ (begin-for-syntax (define (expand-flow stx) (displayln (~a "input: " stx)) - (syntax-parse stx - [(a:id . _) (displayln (~a "syntax info: " - (syntax-debug-info - ((make-interned-syntax-introducer 'qi) #'a))))] - [_ (void)]) (let ([result ((nonterminal-expander floe) stx)]) (displayln (~a "output: " result)) result))) diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index 08bbccdbe..09dfdb63b 100644 --- a/qi-lib/macro.rkt +++ b/qi-lib/macro.rkt @@ -13,7 +13,8 @@ racket/match racket/list) (only-in "flow/extended/expander.rkt" - qi-macro) + qi-macro + esc) racket/format syntax/parse/define syntax/parse) diff --git a/qi-lib/main.rkt b/qi-lib/main.rkt index 9d2ddb6fb..e672597ce 100644 --- a/qi-lib/main.rkt +++ b/qi-lib/main.rkt @@ -5,13 +5,11 @@ qi/macro qi/on qi/switch - qi/threading - qi/flow/extended/forms)) + qi/threading)) (require qi/flow (except-in qi/macro qi-macro) qi/on qi/switch - qi/threading - qi/flow/extended/forms) + qi/threading) diff --git a/qi-lib/switch.rkt b/qi-lib/switch.rkt index a6b8ce7de..47b5e7779 100644 --- a/qi-lib/switch.rkt +++ b/qi-lib/switch.rkt @@ -1,6 +1,6 @@ #lang racket/base -(provide switch +(provide (rename-out [Rswitch switch]) switch-lambda switch-λ λ01 @@ -16,7 +16,7 @@ define-alias params-parser)) -(define-syntax-parser switch +(define-syntax-parser Rswitch [(_ args:subject clause ...) #'(on args @@ -30,7 +30,7 @@ [(_ args:formals expr:expr ...) #:with ags (params-parser #'args) #'(lambda args - (switch ags + (Rswitch ags expr ...))]) (define-alias λ01 switch-lambda) diff --git a/qi-test/tests/flow-dummy.rkt b/qi-test/tests/flow-dummy.rkt new file mode 100644 index 000000000..f63f66994 --- /dev/null +++ b/qi-test/tests/flow-dummy.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(require qi + rackunit + rackunit/text-ui + (only-in math sqr) + (only-in adjutor values->list) + racket/list + racket/string + racket/function + "private/util.rkt") + +;; used in the "language extension" tests for `qi:*` +(define tests + (test-suite + "flow tests" + + (check-equal? #t #t) + ;; (check-equal? ((flow-dummy (~>> add1)) 5) 6) + )) + +(module+ main + (void (run-tests tests))) From 3cfaf085d1e3a0c264c5266272c0b48b46f81e9b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 2 Sep 2022 20:14:24 -0700 Subject: [PATCH 048/338] formatting.. --- qi-doc/scribblings/field-guide.scrbl | 24 ++++++++++++------------ qi-doc/scribblings/forms.scrbl | 18 +++++++++--------- qi-doc/scribblings/interface.scrbl | 20 ++++++++++---------- qi-doc/scribblings/intro.scrbl | 16 ++++++++-------- qi-doc/scribblings/macros.scrbl | 20 ++++++++++---------- qi-doc/scribblings/tutorial.scrbl | 20 ++++++++++---------- 6 files changed, 59 insertions(+), 59 deletions(-) diff --git a/qi-doc/scribblings/field-guide.scrbl b/qi-doc/scribblings/field-guide.scrbl index b0d704ac0..5b9ffa6a1 100644 --- a/qi-doc/scribblings/field-guide.scrbl +++ b/qi-doc/scribblings/field-guide.scrbl @@ -10,18 +10,18 @@ @(define eval-for-docs (call-with-trusted-sandbox-configuration (lambda () - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - qi/probe - (only-in racket/list range) - racket/string - (for-syntax syntax/parse - racket/base)) - '(define (sqr x) - (* x x))))))) + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + qi/probe + (only-in racket/list range) + racket/string + (for-syntax syntax/parse + racket/base)) + '(define (sqr x) + (* x x))))))) @title{Field Guide} diff --git a/qi-doc/scribblings/forms.scrbl b/qi-doc/scribblings/forms.scrbl index 58956aad2..843edd2fb 100644 --- a/qi-doc/scribblings/forms.scrbl +++ b/qi-doc/scribblings/forms.scrbl @@ -9,15 +9,15 @@ @(define eval-for-docs (call-with-trusted-sandbox-configuration (lambda () - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range first rest) - racket/string) - '(define (sqr x) - (* x x))))))) + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range first rest) + racket/string) + '(define (sqr x) + (* x x))))))) @(define diagram-eval (make-base-eval)) @(diagram-eval '(require metapict)) diff --git a/qi-doc/scribblings/interface.scrbl b/qi-doc/scribblings/interface.scrbl index 1d272d239..cabce1393 100644 --- a/qi-doc/scribblings/interface.scrbl +++ b/qi-doc/scribblings/interface.scrbl @@ -10,16 +10,16 @@ @(define eval-for-docs (call-with-trusted-sandbox-configuration (lambda () - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - racket/string) - '(define ->string number->string) - '(define (sqr x) - (* x x))))))) + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range) + racket/string) + '(define ->string number->string) + '(define (sqr x) + (* x x))))))) @title{Language Interface} diff --git a/qi-doc/scribblings/intro.scrbl b/qi-doc/scribblings/intro.scrbl index aedb37e25..b5a92d866 100644 --- a/qi-doc/scribblings/intro.scrbl +++ b/qi-doc/scribblings/intro.scrbl @@ -10,14 +10,14 @@ (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - racket/string) - '(define (sqr x) - (* x x))))))) + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range) + racket/string) + '(define (sqr x) + (* x x))))))) @title{Introduction and Usage} diff --git a/qi-doc/scribblings/macros.scrbl b/qi-doc/scribblings/macros.scrbl index d55ca3f0b..3f01981df 100644 --- a/qi-doc/scribblings/macros.scrbl +++ b/qi-doc/scribblings/macros.scrbl @@ -11,16 +11,16 @@ @(define eval-for-docs (call-with-trusted-sandbox-configuration (lambda () - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range first rest) - (for-syntax syntax/parse racket/base) - racket/string) - '(define (sqr x) - (* x x))))))) + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range first rest) + (for-syntax syntax/parse racket/base) + racket/string) + '(define (sqr x) + (* x x))))))) @title[#:tag "Qi_Macros"]{Qi Macros} diff --git a/qi-doc/scribblings/tutorial.scrbl b/qi-doc/scribblings/tutorial.scrbl index d1b749df8..93ba4bb52 100644 --- a/qi-doc/scribblings/tutorial.scrbl +++ b/qi-doc/scribblings/tutorial.scrbl @@ -10,16 +10,16 @@ @(define eval-for-docs (call-with-trusted-sandbox-configuration (lambda () - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - (only-in racket/function curry) - racket/string) - '(define (sqr x) - (* x x))))))) + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range) + (only-in racket/function curry) + racket/string) + '(define (sqr x) + (* x x))))))) @title{Tutorial} From e7529d7e3be3ed8a86073d30a80f88e666135700 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 2 Sep 2022 20:15:17 -0700 Subject: [PATCH 049/338] remove "flow-dummy" used for debugging --- qi-lib/flow.rkt | 14 -------------- qi-test/tests/flow-dummy.rkt | 23 ----------------------- 2 files changed, 37 deletions(-) delete mode 100644 qi-test/tests/flow-dummy.rkt diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index 1cebaef78..f5fc09f5b 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -2,7 +2,6 @@ (provide flow ☯ - flow-dummy (all-from-out "flow/extended/expander.rkt") (all-from-out "flow/extended/forms.rkt")) @@ -47,16 +46,3 @@ in the flow macro. this-syntax "(flow flo)" "flow expects a single flow specification, but it received many.")]) - -(define-syntax-parser flow-dummy - [(_ onex) (let ([stx (expand-flow #'onex)]) - (displayln (syntax-property (cadr (syntax->list stx)) 'chirality)) - stx)] - ;; a non-flow - [_ #'values] - ;; error handling catch-all - [(_ expr0 expr ...+) - (report-syntax-error - this-syntax - "(flow flo)" - "flow expects a single flow specification, but it received many.")]) diff --git a/qi-test/tests/flow-dummy.rkt b/qi-test/tests/flow-dummy.rkt deleted file mode 100644 index f63f66994..000000000 --- a/qi-test/tests/flow-dummy.rkt +++ /dev/null @@ -1,23 +0,0 @@ -#lang racket/base - -(require qi - rackunit - rackunit/text-ui - (only-in math sqr) - (only-in adjutor values->list) - racket/list - racket/string - racket/function - "private/util.rkt") - -;; used in the "language extension" tests for `qi:*` -(define tests - (test-suite - "flow tests" - - (check-equal? #t #t) - ;; (check-equal? ((flow-dummy (~>> add1)) 5) 6) - )) - -(module+ main - (void (run-tests tests))) From 75865a317080c049de49623397a8dfe441ad4c41 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 2 Sep 2022 20:30:40 -0700 Subject: [PATCH 050/338] remove debugging code from expander and compiler --- qi-lib/flow/core/compiler.rkt | 210 +++++++++++++++--------------- qi-lib/flow/extended/expander.rkt | 5 +- 2 files changed, 105 insertions(+), 110 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index ecaefc754..50f521262 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -22,112 +22,110 @@ stx)) (define-syntax (qi0->racket stx) - (let ([result (syntax-parse (cadr (syntax->list stx)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;; Core language forms ;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - [((~datum gen) ex:expr ...) - #'(λ _ (values ex ...))] - ;; pass-through (identity flow) - [(~datum _) #'values] - ;; routing - [(~or* (~datum ⏚) (~datum ground)) ; NOTE: technically not core - #'(qi0->racket (select))] - [((~or* (~datum ~>) (~datum thread)) onex:clause ...) - #`(compose . #,(reverse - (syntax->list - #'((qi0->racket onex) ...))))] - [e:relay-form (relay-parser #'e)] - [e:tee-form (tee-parser #'e)] - ;; map and filter - [e:amp-form (amp-parser #'e)] ; NOTE: technically not core - [e:pass-form (pass-parser #'e)] ; NOTE: technically not core - ;; prisms - [e:sep-form (sep-parser #'e)] - [(~or* (~datum ▽) (~datum collect)) - #'list] - ;; predicates - [(~or* (~datum AND) (~datum &)) ; NOTE: technically not core - #'(qi0->racket (>> (and (select 2) (select 1)) (gen #t)))] - [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core - #'(qi0->racket (<< (or (select 1) (select 2)) (gen #f)))] - [(~or* (~datum NOT) (~datum !)) - #'not] - [(~datum XOR) - #'parity-xor] - [((~datum and) onex:clause ...) - #'(conjoin (qi0->racket onex) ...)] - [((~datum or) onex:clause ...) - #'(disjoin (qi0->racket onex) ...)] - [((~datum not) onex:clause) ; NOTE: technically not core - #'(qi0->racket (~> onex NOT))] - ;; selection - [e:select-form (select-parser #'e)] - [e:block-form (block-parser #'e)] - [e:group-form (group-parser #'e)] - ;; conditionals - [e:if-form (if-parser #'e)] - [e:sieve-form (sieve-parser #'e)] - ;; exceptions - [e:try-form (try-parser #'e)] - ;; folds - [e:fold-left-form (fold-left-parser #'e)] - [e:fold-right-form (fold-right-parser #'e)] - ;; looping - [e:feedback-form (feedback-parser #'e)] - [e:loop-form (loop-parser #'e)] - [((~datum loop2) pred:clause mapex:clause combex:clause) - #'(letrec ([loop2 (qi0->racket (if pred - (~> (== (-< (esc cdr) - (~> (esc car) mapex)) _) - (group 1 _ combex) - (esc loop2)) - (select 2)))]) - loop2)] - ;; towards universality - [(~datum appleye) - #'call] - [e:clos-form (clos-parser #'e)] - ;; escape hatch for racket expressions or anything - ;; to be "passed through" - [((~datum esc) ex:expr) - #'ex] - - ;;; Miscellaneous - - ;; Partial application with syntactically pre-supplied arguments - ;; in a blanket template - ;; Note: at this point it's already been parsed/validated - ;; and we don't need to worry about checking at the compiler - ;; level - [((~datum #%blanket-template) e) - (blanket-template-form-parser this-syntax)] - - ;; Fine-grained template-based application - ;; This handles templates that indicate a specific number of template - ;; variables (i.e. expected arguments). The semantics of template-based - ;; application here is fulfilled by the fancy-app module. In order to use - ;; it, we simply use the #%app macro provided by fancy-app instead of the - ;; implicit one used for function application in racket/base. - ;; "prarg" = "pre-supplied argument" - [((~datum #%fine-template) (prarg-pre ... (~datum _) prarg-post ...)) - #'(fancy:#%app prarg-pre ... _ prarg-post ...)] - - ;; Pre-supplied arguments without a template - [((~datum #%partial-application) (natex prarg ...+)) - ;; we use currying instead of templates when a template hasn't - ;; explicitly been indicated since in such cases, we cannot - ;; always infer the appropriate arity for a template (e.g. it - ;; may change under composition within the form), while a - ;; curried function will accept any number of arguments - #:do [(define chirality (syntax-property this-syntax 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(curry natex prarg ...) - #'(curryr natex prarg ...))])]) - (displayln (~a "qi0->racket output" result)) - result)) + (syntax-parse (cadr (syntax->list stx)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; Core language forms ;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + [((~datum gen) ex:expr ...) + #'(λ _ (values ex ...))] + ;; pass-through (identity flow) + [(~datum _) #'values] + ;; routing + [(~or* (~datum ⏚) (~datum ground)) ; NOTE: technically not core + #'(qi0->racket (select))] + [((~or* (~datum ~>) (~datum thread)) onex:clause ...) + #`(compose . #,(reverse + (syntax->list + #'((qi0->racket onex) ...))))] + [e:relay-form (relay-parser #'e)] + [e:tee-form (tee-parser #'e)] + ;; map and filter + [e:amp-form (amp-parser #'e)] ; NOTE: technically not core + [e:pass-form (pass-parser #'e)] ; NOTE: technically not core + ;; prisms + [e:sep-form (sep-parser #'e)] + [(~or* (~datum ▽) (~datum collect)) + #'list] + ;; predicates + [(~or* (~datum AND) (~datum &)) ; NOTE: technically not core + #'(qi0->racket (>> (and (select 2) (select 1)) (gen #t)))] + [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core + #'(qi0->racket (<< (or (select 1) (select 2)) (gen #f)))] + [(~or* (~datum NOT) (~datum !)) + #'not] + [(~datum XOR) + #'parity-xor] + [((~datum and) onex:clause ...) + #'(conjoin (qi0->racket onex) ...)] + [((~datum or) onex:clause ...) + #'(disjoin (qi0->racket onex) ...)] + [((~datum not) onex:clause) ; NOTE: technically not core + #'(qi0->racket (~> onex NOT))] + ;; selection + [e:select-form (select-parser #'e)] + [e:block-form (block-parser #'e)] + [e:group-form (group-parser #'e)] + ;; conditionals + [e:if-form (if-parser #'e)] + [e:sieve-form (sieve-parser #'e)] + ;; exceptions + [e:try-form (try-parser #'e)] + ;; folds + [e:fold-left-form (fold-left-parser #'e)] + [e:fold-right-form (fold-right-parser #'e)] + ;; looping + [e:feedback-form (feedback-parser #'e)] + [e:loop-form (loop-parser #'e)] + [((~datum loop2) pred:clause mapex:clause combex:clause) + #'(letrec ([loop2 (qi0->racket (if pred + (~> (== (-< (esc cdr) + (~> (esc car) mapex)) _) + (group 1 _ combex) + (esc loop2)) + (select 2)))]) + loop2)] + ;; towards universality + [(~datum appleye) + #'call] + [e:clos-form (clos-parser #'e)] + ;; escape hatch for racket expressions or anything + ;; to be "passed through" + [((~datum esc) ex:expr) + #'ex] + + ;;; Miscellaneous + + ;; Partial application with syntactically pre-supplied arguments + ;; in a blanket template + ;; Note: at this point it's already been parsed/validated + ;; and we don't need to worry about checking at the compiler + ;; level + [((~datum #%blanket-template) e) + (blanket-template-form-parser this-syntax)] + + ;; Fine-grained template-based application + ;; This handles templates that indicate a specific number of template + ;; variables (i.e. expected arguments). The semantics of template-based + ;; application here is fulfilled by the fancy-app module. In order to use + ;; it, we simply use the #%app macro provided by fancy-app instead of the + ;; implicit one used for function application in racket/base. + ;; "prarg" = "pre-supplied argument" + [((~datum #%fine-template) (prarg-pre ... (~datum _) prarg-post ...)) + #'(fancy:#%app prarg-pre ... _ prarg-post ...)] + + ;; Pre-supplied arguments without a template + [((~datum #%partial-application) (natex prarg ...+)) + ;; we use currying instead of templates when a template hasn't + ;; explicitly been indicated since in such cases, we cannot + ;; always infer the appropriate arity for a template (e.g. it + ;; may change under composition within the form), while a + ;; curried function will accept any number of arguments + #:do [(define chirality (syntax-property this-syntax 'chirality))] + (if (and chirality (eq? chirality 'right)) + #'(curry natex prarg ...) + #'(curryr natex prarg ...))])) ;; The form-specific parsers, which are delegated to from ;; the qi0->racket macro: diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index c11b16c04..3b8287dd0 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -148,7 +148,4 @@ ;; 2. nonterminal (begin-for-syntax (define (expand-flow stx) - (displayln (~a "input: " stx)) - (let ([result ((nonterminal-expander floe) stx)]) - (displayln (~a "output: " result)) - result))) + ((nonterminal-expander floe) stx))) From 8d7c10dad7f0b01d48508ac859b4f030e427dcbb Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 2 Sep 2022 20:39:13 -0700 Subject: [PATCH 051/338] tidy.. --- qi-lib/threading.rkt | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 9af332a60..23c49ed39 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -20,12 +20,7 @@ "Note that the inputs to ~> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) - #'(on ags (~> clause ...)) - ;; tweak report-syntax-error to give srcloc - ;; (raise-syntax-error #f "Error!" this-syntax) - ]) - -;; (raise-syntax-error #f "Error!" this-syntax) + #'(on ags (~> clause ...))]) (define-syntax-parser R~>> [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) @@ -36,10 +31,4 @@ "Note that the inputs to ~>> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) - #'(on ags (~>> clause ...)) - ;; (report-syntax-error '~>> - ;; (syntax->datum #'((args) sep clause ...)) - ;; "(~>> (arg ...) flo ...)" - ;; "ERROR" - ;; "Note that the inputs to ~>> must be wrapped in parentheses.") - ]) + #'(on ags (~>> clause ...))]) From d5a42649f3d7a31ed41263362e07537efd6ed6d7 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 2 Sep 2022 21:44:14 -0700 Subject: [PATCH 052/338] Don't use interface macros other than `flow` in flow tests --- qi-test/tests/flow.rkt | 80 +++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 5902bf926..2a312fb90 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -864,30 +864,30 @@ (list 7 -1) "pure control form of sieve")) (test-suite - "partition" - (check-equal? ((flow (~> (partition) collect))) - (list) - "base partition case") - (check-equal? ((flow (partition [positive? +])) - -1 2 1 1 -2 2) - 6 - "partition composes ~> and pass") - (check-equal? ((flow (~> (partition [positive? +] - [zero? (-< count (gen "zero"))] - [negative? *]) collect)) - -1 0 2 1 1 -2 0 0 2) - (list 6 3 "zero" 2)) - (check-equal? ((flow (~> (partition [positive? +] - [zero? (-< count (gen "zero"))] - [negative? *]) collect)) - -1 2 1 1 -2 2) - (list 6 0 "zero" 2) - "some partition bodies have no inputs") - (check-equal? ((flow (~> (partition [(and positive? (> 1)) +] - [_ list]) collect)) - -1 2 1 1 -2 2) - (list 4 (list -1 1 1 -2)) - "partition bodies can be flows")) + "partition" + (check-equal? ((flow (~> (partition) collect))) + (list) + "base partition case") + (check-equal? ((flow (partition [positive? +])) + -1 2 1 1 -2 2) + 6 + "partition composes ~> and pass") + (check-equal? ((flow (~> (partition [positive? +] + [zero? (-< count (gen "zero"))] + [negative? *]) collect)) + -1 0 2 1 1 -2 0 0 2) + (list 6 3 "zero" 2)) + (check-equal? ((flow (~> (partition [positive? +] + [zero? (-< count (gen "zero"))] + [negative? *]) collect)) + -1 2 1 1 -2 2) + (list 6 0 "zero" 2) + "some partition bodies have no inputs") + (check-equal? ((flow (~> (partition [(and positive? (> 1)) +] + [_ list]) collect)) + -1 2 1 1 -2 2) + (list 4 (list -1 1 1 -2)) + "partition bodies can be flows")) (test-suite "gate" (check-equal? ((☯ (gate positive?)) @@ -938,27 +938,27 @@ (list 5 5 5)) (check-equal? ((☯ (~> (fanout 3) ▽)) 2 3) (list 2 3 2 3 2 3)) - (check-equal? (~> (3 "a") fanout string-append) ; TODO: don't use Racket-level ~> in this module + (check-equal? ((☯ (~> fanout string-append)) 3 "a") "aaa" "control form of fanout") - (check-equal? (~> (3 "a" "b") fanout string-append) + (check-equal? ((☯ (~> fanout string-append)) 3 "a" "b") "ababab" "control form of fanout") - (check-equal? (~> (5) (fanout (add1 2)) ▽) + (check-equal? ((☯ (~> (fanout (add1 2)) ▽)) 5) (list 5 5 5) "arbitrary racket expressions and not just literals") (check-equal? (let ([n 3]) - (~> (5) (fanout n) ▽)) + ((☯ (~> (fanout n) ▽)) 5)) (list 5 5 5) "arbitrary racket expressions and not just literals") - (check-equal? (~> (2 3) (fanout 0) ▽) + (check-equal? ((☯ (~> (fanout 0) ▽)) 2 3) null "N=0 produces no values.") - (check-equal? (~> () (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽))) null "No inputs produces no outputs.") (check-exn exn:fail:contract? - (thunk (~> (-1 3) fanout ▽)) + (thunk ((☯ (~> fanout ▽)) -1 3)) "Negative N signals an error.")) (test-suite "inverter" @@ -974,7 +974,7 @@ 5) 625 "(feedback N flo)") - (check-equal? (~> (3 5) (feedback add1)) + (check-equal? ((☯ (~> (feedback add1))) 3 5) 8 "(feedback flo) consumes the first input as N") (check-equal? ((☯ (feedback 5 (then sqr) add1)) @@ -1172,16 +1172,16 @@ (check-true ((☯ live?) 3 4 5)) (check-true ((☯ live?) 5)) (check-false ((☯ live?))) - (check-true (~> (1 2) live?)) - (check-false (~> (1 2) ⏚ live?))) + (check-true ((☯ (~> live?)) 1 2)) + (check-false ((☯ (~> ⏚ live?)) 1 2))) (test-suite "rectify" - (check-equal? (~> (3 4 5) (rectify 'boo) ▽) (list 3 4 5)) - (check-equal? (~> (5) (rectify 'boo)) 5) - (check-equal? (~> () (rectify 'boo)) 'boo) - (check-equal? (~> (1 2) (rectify #f) ▽) (list 1 2)) - (check-equal? (~> (1 2) ⏚ (rectify #f)) #f))) + (check-equal? ((☯ (~> (rectify 'boo) ▽)) 3 4 5) (list 3 4 5)) + (check-equal? ((☯ (~> (rectify 'boo))) 5) 5) + (check-equal? ((☯ (~> (rectify 'boo)))) 'boo) + (check-equal? ((☯ (~> (rectify #f) ▽)) 1 2) (list 1 2)) + (check-equal? ((☯ (~> ⏚ (rectify #f))) 1 2) #f))) (test-suite "higher-order flows" @@ -1332,7 +1332,7 @@ "language extension" (test-suite "qi:" - (check-equal? (~> (2 3) + (qi:square sqr)) + (check-equal? ((☯ (~> + (qi:square sqr))) 2 3) 625))) (test-suite From 139f806b0c4d1686b6a85e1503cf732e3e08e4b5 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Sep 2022 20:06:00 -0700 Subject: [PATCH 053/338] Avoid inter-space name collisions in benchmarks --- qi-sdk/profile/forms.rkt | 212 +++++++++++++++++++-------------------- qi-sdk/profile/util.rkt | 18 +++- 2 files changed, 121 insertions(+), 109 deletions(-) diff --git a/qi-sdk/profile/forms.rkt b/qi-sdk/profile/forms.rkt index 5cd5a383a..8add47ff0 100644 --- a/qi-sdk/profile/forms.rkt +++ b/qi-sdk/profile/forms.rkt @@ -23,79 +23,79 @@ for the forms are run. (module one-of? "forms-base.rkt" (provide run) - (define (one-of? v) + (define (~one-of? v) ((☯ (one-of? 3 5 7)) v)) (define (run) - (run-benchmark one-of? + (run-benchmark ~one-of? check-value 100000))) (module and "forms-base.rkt" (provide run) - (define (and v) + (define (~and v) ((☯ (and positive? integer?)) v)) (define (run) - (run-benchmark and + (run-benchmark ~and check-value 200000))) (module or "forms-base.rkt" (provide run) - (define (or v) + (define (~or v) ((☯ (or positive? integer?)) v)) (define (run) - (run-benchmark or + (run-benchmark ~or check-value 200000))) (module not "forms-base.rkt" (provide run) - (define (not v) + (define (~not v) ((☯ (not integer?)) v)) (define (run) - (run-benchmark not + (run-benchmark ~not check-value 200000))) (module and% "forms-base.rkt" (provide run) - (define (and% a b) + (define (~and% a b) ((☯ (and% positive? integer?)) a b)) (define (run) - (run-benchmark and% + (run-benchmark ~and% check-two-values 200000))) (module or% "forms-base.rkt" (provide run) - (define (or% a b) + (define (~or% a b) ((☯ (or% positive? integer?)) a b)) (define (run) - (run-benchmark or% + (run-benchmark ~or% check-two-values 200000))) (module group "forms-base.rkt" (provide run) - (define (group . vs) + (define (~group . vs) (apply (☯ (~> (group 2 + _) (group 3 + _) @@ -104,27 +104,27 @@ for the forms are run. vs)) (define (run) - (run-benchmark group + (run-benchmark ~group check-values 200000))) (module count "forms-base.rkt" (provide run) - (define (count . vs) + (define (~count . vs) (apply (☯ count) vs)) (define (run) - (run-benchmark count + (run-benchmark ~count check-values 1000000))) (module relay "forms-base.rkt" (provide run) - (define (relay . vs) + (define (~relay . vs) (apply (☯ (== add1 sub1 @@ -139,14 +139,14 @@ for the forms are run. vs)) (define (run) - (run-benchmark relay + (run-benchmark ~relay check-values 50000))) (module relay* "forms-base.rkt" (provide run) - (define (relay* . vs) + (define (~relay* . vs) (apply (☯ (==* add1 sub1 @@ -155,40 +155,40 @@ for the forms are run. vs)) (define (run) - (run-benchmark relay* + (run-benchmark ~relay* check-values 50000))) (module amp "forms-base.rkt" (provide run) - (define (amp . vs) + (define (~amp . vs) (apply (☯ (>< sqr)) vs)) (define (run) - (run-benchmark amp + (run-benchmark ~amp check-values 300000))) (module ground "forms-base.rkt" (provide run) - (define (ground . vs) + (define (~ground . vs) (apply (☯ ⏚) vs)) (define (run) - (run-benchmark ground + (run-benchmark ~ground check-values 200000))) (module thread "forms-base.rkt" (provide run) - (define (thread . vs) + (define (~thread . vs) (apply (☯ (~> (+ 5) add1 @@ -204,14 +204,14 @@ for the forms are run. vs)) (define (run) - (run-benchmark thread + (run-benchmark ~thread check-values 200000))) (module thread-right "forms-base.rkt" (provide run) - (define (thread-right . vs) + (define (~thread-right . vs) (apply (☯ (~>> (+ 5) add1 @@ -227,251 +227,251 @@ for the forms are run. vs)) (define (run) - (run-benchmark thread-right + (run-benchmark ~thread-right check-values 200000))) (module crossover "forms-base.rkt" (provide run) - (define (crossover . vs) + (define (~crossover . vs) (apply (☯ X) vs)) (define (run) - (run-benchmark crossover + (run-benchmark ~crossover check-values 200000))) (module all "forms-base.rkt" (provide run) - (define (all . vs) + (define (~all . vs) (apply (☯ (all positive?)) vs)) (define (run) - (run-benchmark all + (run-benchmark ~all check-values 200000))) (module any "forms-base.rkt" (provide run) - (define (any . vs) + (define (~any . vs) (apply (☯ (any positive?)) vs)) (define (run) - (run-benchmark any + (run-benchmark ~any check-values 200000))) (module none "forms-base.rkt" (provide run) - (define (none . vs) + (define (~none . vs) (apply (☯ (none positive?)) vs)) (define (run) - (run-benchmark none + (run-benchmark ~none check-values 200000))) (module all? "forms-base.rkt" (provide run) - (define (all? . vs) + (define (~all? . vs) (apply (☯ all?) vs)) (define (run) - (run-benchmark all? + (run-benchmark ~all? check-values 200000))) (module any? "forms-base.rkt" (provide run) - (define (any? . vs) + (define (~any? . vs) (apply (☯ any?) vs)) (define (run) - (run-benchmark any? + (run-benchmark ~any? check-values 200000))) (module none? "forms-base.rkt" (provide run) - (define (none? . vs) + (define (~none? . vs) (apply (☯ none?) vs)) (define (run) - (run-benchmark none? + (run-benchmark ~none? check-values 200000))) (module collect "forms-base.rkt" (provide run) - (define (collect . vs) + (define (~collect . vs) (apply (☯ ▽) vs)) (define (run) - (run-benchmark collect + (run-benchmark ~collect check-values 1000000))) (module sep "forms-base.rkt" (provide run) - (define (sep v) + (define (~sep v) ((☯ △) v)) (define (run) - (run-benchmark sep + (run-benchmark ~sep check-list 1000000))) (module gen "forms-base.rkt" (provide run) - (define (gen . vs) + (define (~gen . vs) (apply (☯ (gen 1 2 3)) vs)) (define (run) - (run-benchmark gen + (run-benchmark ~gen check-values 1000000))) (module esc "forms-base.rkt" (provide run) - (define (esc . vs) + (define (~esc . vs) (apply (☯ (esc (λ args args))) vs)) (define (run) - (run-benchmark esc + (run-benchmark ~esc check-values 1000000))) (module AND "forms-base.rkt" (provide run) - (define (AND . vs) + (define (~AND . vs) (apply (☯ AND) vs)) (define (run) - (run-benchmark AND + (run-benchmark ~AND check-values 200000))) (module OR "forms-base.rkt" (provide run) - (define (OR . vs) + (define (~OR . vs) (apply (☯ OR) vs)) (define (run) - (run-benchmark OR + (run-benchmark ~OR check-values 200000))) (module NOT "forms-base.rkt" (provide run) - (define (NOT v) + (define (~NOT v) ((☯ NOT) v)) (define (run) - (run-benchmark NOT + (run-benchmark ~NOT check-value 200000))) (module NAND "forms-base.rkt" (provide run) - (define (NAND . vs) + (define (~NAND . vs) (apply (☯ NAND) vs)) (define (run) - (run-benchmark NAND + (run-benchmark ~NAND check-values 200000))) (module NOR "forms-base.rkt" (provide run) - (define (NOR . vs) + (define (~NOR . vs) (apply (☯ NOR) vs)) (define (run) - (run-benchmark NOR + (run-benchmark ~NOR check-values 200000))) (module XOR "forms-base.rkt" (provide run) - (define (XOR . vs) + (define (~XOR . vs) (apply (☯ XOR) vs)) (define (run) - (run-benchmark XOR + (run-benchmark ~XOR check-values 200000))) (module XNOR "forms-base.rkt" (provide run) - (define (XNOR . vs) + (define (~XNOR . vs) (apply (☯ XNOR) vs)) (define (run) - (run-benchmark XNOR + (run-benchmark ~XNOR check-values 200000))) (module tee "forms-base.rkt" (provide run) - (define (tee v) + (define (~tee v) ((☯ (-< add1 sub1 sqr)) v)) (define (run) - (run-benchmark tee + (run-benchmark ~tee check-value 200000))) @@ -534,36 +534,36 @@ for the forms are run. (module if "forms-base.rkt" (provide run) - (define (if . vs) + (define (~if . vs) (apply (☯ (if < 'hi 'bye)) vs)) (define (run) - (run-benchmark if + (run-benchmark ~if check-values 500000))) (module when "forms-base.rkt" (provide run) - (define (when . vs) + (define (~when . vs) (apply (☯ (when < 'hi)) vs)) (define (run) - (run-benchmark when + (run-benchmark ~when check-values 500000))) (module unless "forms-base.rkt" (provide run) - (define (unless . vs) + (define (~unless . vs) (apply (☯ (unless < 'hi)) vs)) (define (run) - (run-benchmark unless + (run-benchmark ~unless check-values 500000))) @@ -598,34 +598,34 @@ for the forms are run. (module sieve "forms-base.rkt" (provide run) - (define (sieve . vs) + (define (~sieve . vs) (apply (☯ (sieve positive? 'hi 'bye)) vs)) (define (run) - (run-benchmark sieve + (run-benchmark ~sieve check-values 100000))) (module partition "forms-base.rkt" (provide run) - (define (partition . vs) + (define (~partition . vs) (apply (flow (partition [negative? *] [zero? count] [positive? +])) vs)) (define (run) - (run-benchmark partition check-values 100000))) + (run-benchmark ~partition check-values 100000))) (module gate "forms-base.rkt" (provide run) - (define (gate . vs) + (define (~gate . vs) (apply (☯ (gate <)) vs)) (define (run) - (run-benchmark gate + (run-benchmark ~gate check-values 500000))) @@ -681,12 +681,12 @@ for the forms are run. (module inverter "forms-base.rkt" (provide run) - (define (inverter . vs) + (define (~inverter . vs) (apply (☯ inverter) vs)) (define (run) - (run-benchmark inverter + (run-benchmark ~inverter check-values 200000))) @@ -722,127 +722,127 @@ for the forms are run. (module select "forms-base.rkt" (provide run) - (define (select . vs) + (define (~select . vs) (apply (☯ (select 3 5 8)) vs)) (define (run) - (run-benchmark select + (run-benchmark ~select check-values 20000))) (module block "forms-base.rkt" (provide run) - (define (block . vs) + (define (~block . vs) (apply (☯ (block 3 5 8)) vs)) (define (run) - (run-benchmark block + (run-benchmark ~block check-values 20000))) (module bundle "forms-base.rkt" (provide run) - (define (bundle . vs) + (define (~bundle . vs) (apply (☯ (bundle (3 5 8) + -)) vs)) (define (run) - (run-benchmark bundle + (run-benchmark ~bundle check-values 20000))) (module effect "forms-base.rkt" (provide run) - (define (effect . vs) + (define (~effect . vs) (apply (☯ (effect + +)) vs)) (define (run) - (run-benchmark effect + (run-benchmark ~effect check-values 200000))) (module live? "forms-base.rkt" (provide run) - (define (live? . vs) + (define (~live? . vs) (apply (☯ live?) vs)) (define (run) - (run-benchmark live? + (run-benchmark ~live? check-values 500000))) (module rectify "forms-base.rkt" (provide run) - (define (rectify . vs) + (define (~rectify . vs) (apply (☯ (rectify #f)) vs)) (define (run) - (run-benchmark rectify + (run-benchmark ~rectify check-values 500000))) (module pass "forms-base.rkt" (provide run) - (define (pass . vs) + (define (~pass . vs) (apply (☯ (pass odd?)) vs)) (define (run) - (run-benchmark pass + (run-benchmark ~pass check-values 200000))) (module foldl "forms-base.rkt" (provide run) - (define (>> . vs) + (define (~foldl . vs) (apply (☯ (>> +)) vs)) (define (run) - (run-benchmark >> + (run-benchmark ~foldl check-values 200000))) (module foldr "forms-base.rkt" (provide run) - (define (<< . vs) + (define (~foldr . vs) (apply (☯ (<< +)) vs)) (define (run) - (run-benchmark << + (run-benchmark ~foldr check-values 200000))) (module loop "forms-base.rkt" (provide run) - (define (loop . vs) + (define (~loop . vs) (apply (☯ (loop live? sqr)) vs)) (define (run) - (run-benchmark loop + (run-benchmark ~loop check-values 100000))) (module loop2 "forms-base.rkt" (provide run) - (define (loop2 . vs) + (define (~loop2 . vs) ((☯ (~> (loop2 (~> 1> (not null?)) sqr +))) @@ -850,7 +850,7 @@ for the forms are run. 0)) (define (run) - (run-benchmark loop2 + (run-benchmark ~loop2 check-values 100000))) @@ -860,12 +860,12 @@ for the forms are run. (require (only-in racket/base [apply b:apply])) - (define (apply . vs) + (define (~apply . vs) (b:apply (☯ apply) (cons + vs))) (define (run) - (run-benchmark apply + (run-benchmark ~apply check-values 300000))) @@ -874,13 +874,13 @@ for the forms are run. ;; TODO: this uses a lot of other things besides `clos` and is ;; likely not a reliable indicator - (define (clos . vs) + (define (~clos . vs) (apply (☯ (~> (-< (~> 5 (clos *)) _) apply)) vs)) (define (run) - (run-benchmark clos + (run-benchmark ~clos check-values 100000))) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index 64720c827..17fd1c805 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -24,7 +24,9 @@ racket/function racket/format syntax/parse/define - (for-syntax racket/base) + (for-syntax racket/base + (only-in racket/string + string-trim)) qi) (define-flow average @@ -86,8 +88,18 @@ ;; and report the time taken. (define-syntax-parse-rule (run-benchmark f-name runner n-times) #:with name (datum->syntax #'f-name - (symbol->string - (syntax->datum #'f-name))) + ;; this is because of the name collision between + ;; Racket functions and Qi forms, now that the latter + ;; are provided as identifiers in the qi binding space. + ;; Using a standard prefix (i.e. ~) in the naming and then + ;; detecting that, trimming it, here, is pretty hacky. + ;; One alternative could be to broaden the run-benchmark + ;; macro to support a name argument, but that seems like + ;; more work. It would be better to be able to introspect + ;; these somehow. + (string-trim (symbol->string + (syntax->datum #'f-name)) + "~")) (let ([ms (measure runner f-name n-times)]) (list name ms))) From 1604ec94c58ca7911c2b9be8b5d3e139b6c5f4fc Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 10 Sep 2022 08:51:16 -0700 Subject: [PATCH 054/338] declare bindingspec dependency in a git url --- qi-lib/info.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index aec2a73a7..090f16017 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -3,7 +3,10 @@ (define version "3.0") (define collection "qi") (define deps '("base" - ("fancy-app" #:version "1.1"))) + ("fancy-app" #:version "1.1") + ;; this git URL should be changed to a named package spec + ;; once bindingspec is on the package index + "git://github.com/michaelballantyne/bindingspec.git")) (define build-deps '()) (define clean '("compiled" "private/compiled")) (define pkg-authors '(countvajhula)) From 5263f64bdf6240ba62f0c9c0753054106a8959e3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 10 Sep 2022 09:05:40 -0700 Subject: [PATCH 055/338] fix git url --- qi-lib/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index 090f16017..d4d4cc6a9 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -6,7 +6,7 @@ ("fancy-app" #:version "1.1") ;; this git URL should be changed to a named package spec ;; once bindingspec is on the package index - "git://github.com/michaelballantyne/bindingspec.git")) + "git://github.com/michaelballantyne/bindingspec.git#main")) (define build-deps '()) (define clean '("compiled" "private/compiled")) (define pkg-authors '(countvajhula)) From 92f2e603b364d1f7135c7c338cec037cdea47031 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 12 Sep 2022 11:00:12 -0700 Subject: [PATCH 056/338] try bumping legacy version to 8.4 --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 321a10169..a940d4381 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -14,7 +14,7 @@ jobs: fail-fast: true matrix: racket-variant: ['BC', 'CS'] - racket-version: ['8.3', 'stable'] + racket-version: ['8.4', 'stable'] experimental: [false] include: - racket-version: 'current' From 70cb85465d8b021805d4615539657d741017f568 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 12 Sep 2022 11:31:35 -0700 Subject: [PATCH 057/338] bump legacy racket version to 8.5 --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index a940d4381..d844ca173 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -14,7 +14,7 @@ jobs: fail-fast: true matrix: racket-variant: ['BC', 'CS'] - racket-version: ['8.4', 'stable'] + racket-version: ['8.5', 'stable'] experimental: [false] include: - racket-version: 'current' From 9cc35e8579069112922a8e75c8f11afc189d6681 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 13 Sep 2022 15:34:38 -0700 Subject: [PATCH 058/338] add a comment explaining the need for the trusted sandbox in docs --- qi-doc/scribblings/field-guide.scrbl | 4 ++++ qi-doc/scribblings/forms.scrbl | 4 ++++ qi-doc/scribblings/interface.scrbl | 4 ++++ qi-doc/scribblings/intro.scrbl | 4 ++++ qi-doc/scribblings/macros.scrbl | 4 ++++ qi-doc/scribblings/tutorial.scrbl | 4 ++++ 6 files changed, 24 insertions(+) diff --git a/qi-doc/scribblings/field-guide.scrbl b/qi-doc/scribblings/field-guide.scrbl index 5b9ffa6a1..3b9dafbfc 100644 --- a/qi-doc/scribblings/field-guide.scrbl +++ b/qi-doc/scribblings/field-guide.scrbl @@ -8,6 +8,10 @@ racket]] @(define eval-for-docs + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] diff --git a/qi-doc/scribblings/forms.scrbl b/qi-doc/scribblings/forms.scrbl index 843edd2fb..7e5644cf5 100644 --- a/qi-doc/scribblings/forms.scrbl +++ b/qi-doc/scribblings/forms.scrbl @@ -7,6 +7,10 @@ racket]] @(define eval-for-docs + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] diff --git a/qi-doc/scribblings/interface.scrbl b/qi-doc/scribblings/interface.scrbl index cabce1393..991e7570f 100644 --- a/qi-doc/scribblings/interface.scrbl +++ b/qi-doc/scribblings/interface.scrbl @@ -8,6 +8,10 @@ syntax/parse/define]] @(define eval-for-docs + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] diff --git a/qi-doc/scribblings/intro.scrbl b/qi-doc/scribblings/intro.scrbl index b5a92d866..47428f66c 100644 --- a/qi-doc/scribblings/intro.scrbl +++ b/qi-doc/scribblings/intro.scrbl @@ -7,6 +7,10 @@ racket]] @(define eval-for-docs + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] diff --git a/qi-doc/scribblings/macros.scrbl b/qi-doc/scribblings/macros.scrbl index 3f01981df..d3da331aa 100644 --- a/qi-doc/scribblings/macros.scrbl +++ b/qi-doc/scribblings/macros.scrbl @@ -9,6 +9,10 @@ syntax/parse/define]] @(define eval-for-docs + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] diff --git a/qi-doc/scribblings/tutorial.scrbl b/qi-doc/scribblings/tutorial.scrbl index 93ba4bb52..0dcdfb62f 100644 --- a/qi-doc/scribblings/tutorial.scrbl +++ b/qi-doc/scribblings/tutorial.scrbl @@ -8,6 +8,10 @@ racket]] @(define eval-for-docs + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] From a01286cc5309b6f2c790e68e4823e6b5518d01c8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 13 Sep 2022 17:10:35 -0700 Subject: [PATCH 059/338] add clarifying comments; remove leftover unused and debugging code --- qi-lib/flow/core/compiler.rkt | 4 ++-- qi-lib/flow/extended/expander.rkt | 25 +++++++++++++++++++------ qi-lib/flow/extended/syntax.rkt | 7 +++---- 3 files changed, 24 insertions(+), 12 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 50f521262..5b4f44f2f 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -100,8 +100,8 @@ ;; Partial application with syntactically pre-supplied arguments ;; in a blanket template ;; Note: at this point it's already been parsed/validated - ;; and we don't need to worry about checking at the compiler - ;; level + ;; by the expander and we don't need to worry about checking + ;; the syntax at the compiler level [((~datum #%blanket-template) e) (blanket-template-form-parser this-syntax)] diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 3b8287dd0..bf68cc139 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -17,10 +17,11 @@ "syntax.rkt" racket/base syntax/parse - "../../private/util.rkt" - racket/format)) + "../../private/util.rkt")) (define-hosted-syntaxes + ;; Declare a compile-time datatype by which qi macros may + ;; be identified. (extension-class qi-macro #:binding-space qi) (nonterminal floe @@ -30,7 +31,12 @@ #:allow-extension qi-macro #:binding-space qi (gen e:expr ...) - ;; hack to allow _ to be used ... + ;; Ad hoc expansion rule to allow _ to be used in application + ;; position in a template. + ;; Without it, (_ v ...) would be treated as an error since + ;; _ is an unrelated form of the core language having different + ;; semantics. The expander would assume it is a syntax error + ;; from that perspective. (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) _ ground @@ -129,13 +135,22 @@ ;; a literal is interpreted as a flow generating it (~> val:literal #'(gen val)) + ;; Certain rules of the language aren't determined by the "head" + ;; position, so naively, these can't be core forms. In order to + ;; treat them as core forms, we tag them at the expander level + ;; by wrapping them with #%-prefixed forms, similar to Racket's + ;; approach to a similiar case - "interposition points." These + ;; new forms can then be treated as core forms in the compiler. (~> f:blanket-template-form #'(#%blanket-template f)) (#%blanket-template (arg:any-stx ...)) - ;; (~> v:expr (begin (displayln "hello!") (error 'bye))) (~> f:fine-template-form #'(#%fine-template f)) (#%fine-template (arg:any-stx ...)) + ;; The core rule must come before the tagging rule here since + ;; the former as a production of the latter would still match + ;; the latter (i.e. it is still a parenthesized expression), + ;; which would lead to infinite code generation. (#%partial-application (arg:any-stx ...)) (~> f:partial-application-form #'(#%partial-application f)) @@ -144,8 +159,6 @@ ;; everything else is stable (~> f:expr #'(esc f)))) -;; 1. extension class -;; 2. nonterminal (begin-for-syntax (define (expand-flow stx) ((nonterminal-expander floe) stx))) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index 0d151e43e..20067ab2a 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -38,6 +38,9 @@ onex:clause #:with chiral (make-right-chiral #'onex))) +;; Note these are used in the expander instead of in the compiler. +;; That's why they don't need the tag (i.e. they don't look for +;; #%blanket-template, #%fine-template, or #%partial-application) (define-syntax-class blanket-template-form ;; "prarg" = "pre-supplied argument" (pattern @@ -46,15 +49,11 @@ (define-syntax-class fine-template-form ;; "prarg" = "pre-supplied argument" (pattern - ;; note these are used in the expander instead of in the compiler - ;; that's why they don't need the tag (prarg-pre ... (~datum _) prarg-post ...))) (define-syntax-class partial-application-form ;; "prarg" = "pre-supplied argument" (pattern - ;; note these are used in the expander instead of in the compiler - ;; that's why they don't need the tag (natex prarg ...+))) (define-syntax-class any-stx From 0d4074e91e6d4f1cb6a111eda3a39dd884ab38ad Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 13 Sep 2022 17:21:37 -0700 Subject: [PATCH 060/338] Use rename-out to avoid defining duplicate macros for aliases --- qi-lib/flow/extended/forms.rkt | 68 ++++------------------------------ qi-lib/macro.rkt | 7 ++-- 2 files changed, 10 insertions(+), 65 deletions(-) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index fca7cf1af..78bc3c5be 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -1,49 +1,13 @@ #lang racket/base (provide (for-space qi - one-of? - all - any - none - NOR - NAND - XNOR - any? - all? - none? - and% - or% - thread-right - ~>> - crossover - X - relay* - ==* - bundle - when - unless - switch - partition - gate - fanout - count - live? - rectify - 1> - 2> - 3> - 4> - 5> - 6> - 7> - 8> - 9> - ;; try rename-out instead of - ;; duplicate macros below, as - ;; an alternative to define-qi-alias - inverter - effect - ε)) + (all-defined-out) + ;; defining and using a `define-qi-alias` form + ;; would be a more direct way to do this + (rename-out [thread-right ~>>] + [crossover X] + [relay* ==*] + [effect ε]))) (require (for-syntax racket/base syntax/parse @@ -102,28 +66,14 @@ (define-qi-syntax-rule (thread-right onex:right-threading-clause ...) (~> onex.chiral ...)) -;; TODO: do it as an alias? -;; (define-qi-alias ~>> thread-right) - -(define-qi-syntax-rule (~>> arg ...) - (thread-right arg ...)) - (define-qi-syntax-parser crossover [_:id #'(~> ▽ reverse △)]) -;; TODO: alias -(define-qi-syntax-parser X - [_:id #'crossover]) - (define-qi-syntax-parser relay* [(_ onex:clause ... rest-onex:clause) #:with len #`#,(length (syntax->list #'(onex ...))) #'(group len (== onex ...) rest-onex)]) -;; TODO: alias -(define-qi-syntax-rule (==* onex ...) - (relay* onex ...)) - (define-qi-syntax-rule (bundle (n:number ...) selection-onex:clause remainder-onex:clause) @@ -267,7 +217,3 @@ [(_ sidex:clause) #'(-< (~> sidex ⏚) _)]) - -;; TODO: alias -(define-qi-syntax-rule (ε arg ...) - (effect arg ...)) diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index 09dfdb63b..ffdaf456e 100644 --- a/qi-lib/macro.rkt +++ b/qi-lib/macro.rkt @@ -3,7 +3,6 @@ (provide define-qi-syntax define-qi-syntax-rule define-qi-syntax-parser - define-qi-alias define-qi-foreign-syntaxes (for-syntax qi-macro)) @@ -96,9 +95,9 @@ transformer)])) ;; TODO: get this to work -(define-syntax define-qi-alias - (syntax-parser - [(_ alias:id name:id) #'(define-qi-syntax alias (make-rename-transformer #'name))])) +;; (define-syntax define-qi-alias +;; (syntax-parser +;; [(_ alias:id name:id) #'(define-qi-syntax alias (make-rename-transformer #'name))])) (define-syntax define-qi-syntax-rule (syntax-parser From 7ccda1f8fe44c326e716d81208793ce1ea404c0b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 13 Sep 2022 17:31:55 -0700 Subject: [PATCH 061/338] providing the qi-macro datatype was accidentally excluded - revert --- qi-lib/main.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/qi-lib/main.rkt b/qi-lib/main.rkt index e672597ce..b81c616ee 100644 --- a/qi-lib/main.rkt +++ b/qi-lib/main.rkt @@ -8,8 +8,7 @@ qi/threading)) (require qi/flow - (except-in qi/macro - qi-macro) + qi/macro qi/on qi/switch qi/threading) From 61ff859ec94fcbdae76224f4f5b1ea2fa5b344da Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 13 Sep 2022 17:39:01 -0700 Subject: [PATCH 062/338] Use % convention for interface macros. Also explain the inter-space name collision issue in comments. --- qi-lib/switch.rkt | 10 +++++++--- qi-lib/threading.rkt | 12 ++++++++---- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/qi-lib/switch.rkt b/qi-lib/switch.rkt index 47b5e7779..aeb9a5df1 100644 --- a/qi-lib/switch.rkt +++ b/qi-lib/switch.rkt @@ -1,6 +1,10 @@ #lang racket/base -(provide (rename-out [Rswitch switch]) +;; This name juggling is necessary since the Racket macros would +;; otherwise collide with the Qi forms with the same name in the qi +;; binding space, since Qi forms are now exported literals and not simply +;; matched as datum patterns as they were formerly. +(provide (rename-out [%switch switch]) switch-lambda switch-λ λ01 @@ -16,7 +20,7 @@ define-alias params-parser)) -(define-syntax-parser Rswitch +(define-syntax-parser %switch [(_ args:subject clause ...) #'(on args @@ -30,7 +34,7 @@ [(_ args:formals expr:expr ...) #:with ags (params-parser #'args) #'(lambda args - (Rswitch ags + (%switch ags expr ...))]) (define-alias λ01 switch-lambda) diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 23c49ed39..88874b764 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -1,7 +1,11 @@ #lang racket/base -(provide (rename-out [R~> ~>] - [R~>> ~>>])) +;; This name juggling is necessary since the Racket macros would +;; otherwise collide with the Qi forms with the same name in the qi +;; binding space, since Qi forms are now exported literals and not simply +;; matched as datum patterns as they were formerly. +(provide (rename-out [%~> ~>] + [%~>> ~>>])) (require syntax/parse/define (for-syntax racket/base @@ -11,7 +15,7 @@ "flow.rkt" "on.rkt") -(define-syntax-parser R~> +(define-syntax-parser %~> [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error this-syntax @@ -22,7 +26,7 @@ #:with ags (attribute args.args) #'(on ags (~> clause ...))]) -(define-syntax-parser R~>> +(define-syntax-parser %~>> [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error this-syntax From 5189a0228ea715478bb625aa4b93201ffc159016 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 13 Sep 2022 18:38:49 -0700 Subject: [PATCH 063/338] fix ambiguous binding? --- qi-test/tests/flow.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 2a312fb90..e1a1be788 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -10,7 +10,8 @@ racket/list racket/string racket/function - "private/util.rkt") + (except-in "private/util.rkt" + add-two)) ;; used in the "language extension" tests for `qi:*` (define-syntax-rule (qi:square flo) From 8515e1555ce690ae7fa6e7f91c478c106c38fc19 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 14 Sep 2022 11:56:13 -0700 Subject: [PATCH 064/338] change a "note" to a "TODO" so it's easier to discover --- qi-sdk/profile/report.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 82ed4b2d7..decf6e1a3 100644 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -145,7 +145,7 @@ "clos" clos:run)) (program (main) - ;; Note: could use try-order? with hash-keys if support is dropped for Racket 8.3 + ;; TODO: could use try-order? with hash-keys if support is dropped for Racket 8.3 (define fs (~>> (env) hash-keys (sort <))) (define forms-data (for/list ([f (in-list fs)]) (match-let ([(list name ms) ((hash-ref env f))]) From 736adb121ccd032dac743225ebe85d0ede9ae3de Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 21:01:58 -0700 Subject: [PATCH 065/338] Note preliminary transformation rules for the `as` binding form --- qi-lib/flow/core/compiler.rkt | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 5b4f44f2f..d16ccf6a6 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -21,6 +21,34 @@ (define (optimize-flow stx) stx)) +;; Transformation rules for the `as` binding form: +;; +;; 1. escape to wrap outermost ~> with let and re-enter +;; +;; (~> flo ... (... (as name) ...)) +;; ... +;; ↓ +;; ... +;; (esc (let ([name (void)]) +;; (☯ original-flow))) +;; +;; 2. as → set! +;; +;; (as name) +;; ... +;; ↓ +;; ... +;; (~> (esc (λ (x) (set! name x))) ⏚) +;; +;; 3. Overall transformation: +;; +;; (~> flo ... (... (as name) ...)) +;; ... +;; ↓ +;; ... +;; (esc (let ([name (void)]) +;; (☯ (~> flo ... (... (~> (esc (λ (x) (set! name x))) ⏚) ...))))) + (define-syntax (qi0->racket stx) (syntax-parse (cadr (syntax->list stx)) From eff7989f6d772e48c45c564c317fc7e5295a03ae Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 30 Sep 2022 09:54:34 -0700 Subject: [PATCH 066/338] shell for a distinct codegen pass for processing bindings --- qi-lib/flow/core/compiler.rkt | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index d16ccf6a6..d6800808a 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -16,7 +16,7 @@ ;; note: this does not return compiled code but instead, ;; syntax whose expansion compiles the code (define (compile-flow stx) - #`(qi0->racket #,(optimize-flow stx))) + #`(qi0->racket #,(process-bindings (optimize-flow stx)))) (define (optimize-flow stx) stx)) @@ -49,7 +49,25 @@ ;; (esc (let ([name (void)]) ;; (☯ (~> flo ... (... (~> (esc (λ (x) (set! name x))) ⏚) ...))))) +(begin-for-syntax + (define (handle-binding stx) + stx) + + (define (process-bindings stx) + (if (syntax-property stx 'bindings-done) + stx + ;; find a single `as`, transform it, loop. + ;; if no `as` found, attach a syntax property + ;; and return without looping. + (let loop ([stx stx]) + (if #f + (loop (handle-binding stx)) + (syntax-property stx 'bindings-done #t)))))) + (define-syntax (qi0->racket stx) + ;; this is a macro so it receives the entire expression + ;; (qi0->racket ...). We use cadr here to parse the + ;; contained expression. (syntax-parse (cadr (syntax->list stx)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 0475ccf6fd245f6b2cb1832ae47fbef7655443cc Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 6 Oct 2022 06:25:23 -0700 Subject: [PATCH 067/338] list-based (for now) functions to perform the bindings transformations --- qi-lib/flow/core/compiler.rkt | 55 ++++++++++++++++++++++++++++------- 1 file changed, 44 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index d6800808a..83ef2b3a0 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -50,19 +50,52 @@ ;; (☯ (~> flo ... (... (~> (esc (λ (x) (set! name x))) ⏚) ...))))) (begin-for-syntax - (define (handle-binding stx) - stx) + + (define (find-and-map pred f lst) + (if (null? lst) + null + (let ([v (car lst)] + [vs (cdr lst)]) + (cons (cond [(pred v) (f v)] + [(list? v) (find-and-map pred f v)] + [else v]) + (find-and-map pred f vs))))) + + (define (binding-form? stx) + (and (list? stx) (equal? 'as (car stx)))) + + ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) + (define (rewrite-binding stx) + (let ([id (cadr stx)]) + `(~> (esc (λ (x) (set! ,id x))) ⏚))) + + (define (rewrite-all-bindings stx) + (find-and-map binding-form? + rewrite-binding + stx)) + + (define (bound-identifiers stx) + (let ([ids null]) + (find-and-map binding-form? + (λ (v) + (set! ids + (cons (cadr v) ids)) + v) + stx) + ids)) + + ;; wrap stx with (let ([v undefined] ...) stx) for v ∈ ids + (define (wrap-with-scopes stx ids) + (syntax->datum + (syntax-parse (datum->syntax #f ids) + [(v ...) #`(let ([v undefined] ...) #,stx)]))) (define (process-bindings stx) - (if (syntax-property stx 'bindings-done) - stx - ;; find a single `as`, transform it, loop. - ;; if no `as` found, attach a syntax property - ;; and return without looping. - (let loop ([stx stx]) - (if #f - (loop (handle-binding stx)) - (syntax-property stx 'bindings-done #t)))))) + ;; TODO: use syntax-parse and match ~> specifically. + ;; Since macros are expanded "outside in," presumably + ;; it will naturally wrap the outermost ~> + (wrap-with-scopes (rewrite-all-bindings stx) + (bound-identifiers stx)))) (define-syntax (qi0->racket stx) ;; this is a macro so it receives the entire expression From 49f121d4f4b4ab622f7ae27acf151f7c5fdb3200 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 6 Oct 2022 06:26:57 -0700 Subject: [PATCH 068/338] note a todo --- qi-lib/flow/core/compiler.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 83ef2b3a0..d9e36a7a8 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -65,6 +65,7 @@ (and (list? stx) (equal? 'as (car stx)))) ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) + ;; TODO: use a box instead of set! (define (rewrite-binding stx) (let ([id (cadr stx)]) `(~> (esc (λ (x) (set! ,id x))) ⏚))) From a1a48dc1f8a25df259dc7e72a2c15261555c7ef9 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 6 Oct 2022 09:34:51 -0700 Subject: [PATCH 069/338] simplify find-and-map (CR) --- qi-lib/flow/core/compiler.rkt | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index d9e36a7a8..918b08744 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -52,14 +52,11 @@ (begin-for-syntax (define (find-and-map pred f lst) - (if (null? lst) - null - (let ([v (car lst)] - [vs (cdr lst)]) - (cons (cond [(pred v) (f v)] - [(list? v) (find-and-map pred f v)] - [else v]) - (find-and-map pred f vs))))) + (map (λ (v) + (cond [(pred v) (f v)] + [(list? v) (find-and-map pred f v)] + [else v])) + lst)) (define (binding-form? stx) (and (list? stx) (equal? 'as (car stx)))) From 2fdb5d8b85cd1fc85897558b21c77f1e6ba1d175 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 31 Oct 2022 18:22:19 -0600 Subject: [PATCH 070/338] WIP implementation of bindings in the compiler These changes are what we did in last time's Qi meetup. There are still a few issues and cases to work out (as noted in the meeting notes on the wiki) but it roughly works. --- qi-lib/flow/core/compiler.rkt | 45 ++++++++++++++++++------------- qi-lib/flow/extended/expander.rkt | 1 + qi-test/tests/flow.rkt | 5 ++++ 3 files changed, 32 insertions(+), 19 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 918b08744..78020ed8f 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -7,16 +7,18 @@ racket/match "syntax.rkt" "../aux-syntax.rkt" - racket/format) + racket/format + ee-lib) "impl.rkt" racket/function + racket/undefined (prefix-in fancy: fancy-app)) (begin-for-syntax ;; note: this does not return compiled code but instead, ;; syntax whose expansion compiles the code (define (compile-flow stx) - #`(qi0->racket #,(process-bindings (optimize-flow stx)))) + (process-bindings (optimize-flow stx))) (define (optimize-flow stx) stx)) @@ -51,21 +53,23 @@ (begin-for-syntax - (define (find-and-map pred f lst) - (map (λ (v) - (cond [(pred v) (f v)] - [(list? v) (find-and-map pred f v)] - [else v])) - lst)) + (define (find-and-map pred f stx) + (map-transform (λ (v) + (cond [(pred v) (f v)] + [else v])) + stx)) (define (binding-form? stx) - (and (list? stx) (equal? 'as (car stx)))) + (syntax-parse stx + [((~datum as) v:id) #t] + [_ #f])) ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) ;; TODO: use a box instead of set! (define (rewrite-binding stx) - (let ([id (cadr stx)]) - `(~> (esc (λ (x) (set! ,id x))) ⏚))) + (syntax-parse stx + [(_ idx) + #'(thread (esc (λ (x) (set! idx x))) ground)])) (define (rewrite-all-bindings stx) (find-and-map binding-form? @@ -76,23 +80,24 @@ (let ([ids null]) (find-and-map binding-form? (λ (v) - (set! ids - (cons (cadr v) ids)) + (syntax-parse v + [(_ x) + (set! ids + (cons #'x ids))]) v) stx) ids)) ;; wrap stx with (let ([v undefined] ...) stx) for v ∈ ids (define (wrap-with-scopes stx ids) - (syntax->datum - (syntax-parse (datum->syntax #f ids) - [(v ...) #`(let ([v undefined] ...) #,stx)]))) + (with-syntax ([(v ...) ids]) + #`(let ([v undefined] ...) #,stx))) (define (process-bindings stx) ;; TODO: use syntax-parse and match ~> specifically. ;; Since macros are expanded "outside in," presumably ;; it will naturally wrap the outermost ~> - (wrap-with-scopes (rewrite-all-bindings stx) + (wrap-with-scopes #`(qi0->racket #,(rewrite-all-bindings stx)) (bound-identifiers stx)))) (define-syntax (qi0->racket stx) @@ -201,8 +206,10 @@ ;; curried function will accept any number of arguments #:do [(define chirality (syntax-property this-syntax 'chirality))] (if (and chirality (eq? chirality 'right)) - #'(curry natex prarg ...) - #'(curryr natex prarg ...))])) + #'(lambda args + (apply natex (append (list prarg ...) args))) + #'(lambda args + (apply natex (append args (list prarg ...)))))])) ;; The form-specific parsers, which are delegated to from ;; the qi0->racket macro: diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index bf68cc139..40c36137f 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -129,6 +129,7 @@ clos (clos onex:floe) (esc ex:expr) + (as v:id) ;; backwards compat macro extensibility via Racket macros (~> ((~var ext-form (starts-with "qi:")) expr ...) #'(esc (ext-form expr ...))) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index e1a1be788..57b9c4880 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -330,6 +330,11 @@ (check-equal? ((☯ (~> ▽ △ string-append)) "a" "b" "c") "abc")))) + (test-suite + "bindings" + (check-equal? ((☯ (~> (as v) (+ v))) 3) + 3)) + (test-suite "routing forms" (test-suite From ee9366de48dc09eb199ea8c71afc7fc39aa23ede Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 31 Oct 2022 19:12:38 -0600 Subject: [PATCH 071/338] a comment to be addressed --- qi-lib/flow/core/compiler.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 78020ed8f..7ec4fe388 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -206,6 +206,7 @@ ;; curried function will accept any number of arguments #:do [(define chirality (syntax-property this-syntax 'chirality))] (if (and chirality (eq? chirality 'right)) + ;; currying quirk with 0 args isn't preserved #'(lambda args (apply natex (append (list prarg ...) args))) #'(lambda args From 6c56ee40672b03f07338cd8b50cff2fc608ce18f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 10 Nov 2022 19:10:03 -0800 Subject: [PATCH 072/338] Require non-Qi syntax in a flow position to be a function identifier --- qi-lib/flow/extended/expander.rkt | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 40c36137f..4e2896da3 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -156,9 +156,7 @@ (~> f:partial-application-form #'(#%partial-application f)) ;; literally indicated function identifier - ;; TODO: make this id rather than expr once - ;; everything else is stable - (~> f:expr #'(esc f)))) + (~> f:id #'(esc f)))) (begin-for-syntax (define (expand-flow stx) From 83af3b8628a732ed04a6c76dfd9716856ed02a4a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 10 Nov 2022 19:37:02 -0800 Subject: [PATCH 073/338] update tests --- qi-test/tests/flow.rkt | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 57b9c4880..36fde6d84 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -32,9 +32,18 @@ (check-equal? (values->list ((☯))) null "empty flow with no inputs") (check-equal? ((☯) 0) 0 "empty flow with one input") (check-equal? (values->list ((☯) 1 2)) (list 1 2) "empty flow with multiple inputs") - (check-equal? ((☯ (const 3))) 3 "no arguments") + (check-equal? ((☯ (+ 3))) 3 "partial application with no runtime arguments") (check-equal? ((flow add1) 2) 3 "simple function") - (check-equal? ((flow (get-f 1)) 2) 3 "fully qualified function") + (check-exn exn:fail:contract? + (thunk ((flow (get-f 1)) 2)) + "fully qualified function is still treated as a partial application") + ;; As this is a syntax error, it can't be written as a unit test + ;; (check-exn exn:fail:contract? + ;; (thunk (flow (get-f))) + ;; "empty partial application isn't allowed") + (check-equal? ((flow (esc (get-f 1))) 2) + 3 + "fully qualified function used as a flow must still use esc") (check-equal? ((flow _) 5) 5 "identity flow") (check-equal? ((flow (~> _ ▽)) 5 6) (list 5 6) "identity flow")) (test-suite @@ -255,6 +264,8 @@ (list 3 4 5))) (test-suite "escape hatch" + (check-equal? ((☯ (esc add1)) 2) 3) + (check-equal? ((☯ (esc (const 3)))) 3) (check-equal? ((☯ (esc (first (list + *)))) 3 7) 10 "normal racket expressions")) @@ -590,10 +601,13 @@ (list "a" "b" "c")) "cba" "curried foldl") - (check-exn exn:fail? - (thunk ((☯ (+)) - 5 7 8)) - "function isn't curried when no arguments are provided")) + (check-equal? (((☯ (const 3)))) 3 "partial application with no arguments") + ;; As this is now a syntax error, it can't be written as a unit test + ;; (check-exn exn:fail? + ;; (thunk ((☯ (+)) + ;; 5 7 8)) + ;; "function isn't curried when no arguments are provided") + ) (test-suite "blanket template" (check-equal? ((☯ (+ __))) 0) From 06ac690b7014a6a0759878dc5e3801abdfdc1a00 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 11 Nov 2022 09:42:26 -0800 Subject: [PATCH 074/338] some wip on bindings and notes --- qi-lib/flow/core/compiler.rkt | 18 ++++++++++++++++-- qi-test/tests/flow.rkt | 5 ++++- 2 files changed, 20 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 7ec4fe388..91baca53d 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -53,6 +53,14 @@ (begin-for-syntax + (define (extract-kwargs stx) + ;; TODO: extract keyword args as (kw val ...) + null) + + (define (extract-posargs stx) + ;; TODO: extract positional args as (val ...) + null) + (define (find-and-map pred f stx) (map-transform (λ (v) (cond [(pred v) (f v)] @@ -205,11 +213,17 @@ ;; may change under composition within the form), while a ;; curried function will accept any number of arguments #:do [(define chirality (syntax-property this-syntax 'chirality))] + ;; #:with prarg-kw (extract-kwargs #'(prarg ...)) + ;; #:with prarg-pos (extract-posargs #'(prarg ...)) (if (and chirality (eq? chirality 'right)) - ;; currying quirk with 0 args isn't preserved #'(lambda args - (apply natex (append (list prarg ...) args))) + (apply natex prarg ... args)) + ;; TODO: keyword arguments don't work for the left-chiral case + ;; since we can't just blanket place the pre-supplied args + ;; and need to handle the keyword arguments differently + ;; from the positional arguments. #'(lambda args + ;; (apply natex #,@prarg-kw (append args #,@prarg-pos)) (apply natex (append args (list prarg ...)))))])) ;; The form-specific parsers, which are delegated to from diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 36fde6d84..d41f7809d 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -344,7 +344,10 @@ (test-suite "bindings" (check-equal? ((☯ (~> (as v) (+ v))) 3) - 3)) + 3) + (let ([as (lambda (v) v)]) + (check-equal? ((☯ (~> (gen (as 3))))) 3) ; TODO: why does this work? + (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3))) (test-suite "routing forms" From 6eae0a82586357c23789cede4dcc2355a25aeb81 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 11 Nov 2022 12:17:46 -0800 Subject: [PATCH 075/338] fix left chiral case and add tests --- qi-lib/flow/core/compiler.rkt | 5 ++++- qi-test/tests/flow.rkt | 10 ++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 91baca53d..82642c2ad 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -224,7 +224,10 @@ ;; from the positional arguments. #'(lambda args ;; (apply natex #,@prarg-kw (append args #,@prarg-pos)) - (apply natex (append args (list prarg ...)))))])) + (let ([f (make-keyword-procedure + (λ (kws kws-vs . pos) + (keyword-apply natex kws kws-vs (append args pos))))]) + (f prarg ...))))])) ;; The form-specific parsers, which are delegated to from ;; the qi0->racket macro: diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index d41f7809d..0320a12ac 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -347,7 +347,9 @@ 3) (let ([as (lambda (v) v)]) (check-equal? ((☯ (~> (gen (as 3))))) 3) ; TODO: why does this work? - (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3))) + ;; TODO: uncomment for bindings + ;; (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3) + )) (test-suite "routing forms" @@ -859,13 +861,13 @@ "short-circuiting")) (test-suite "sieve" - (check-equal? ((☯ (~> (sieve positive? add1 (const -1)) ▽)) + (check-equal? ((☯ (~> (sieve positive? add1 (gen -1)) ▽)) 1 -2) (list 2 -1)) (check-equal? ((☯ (~> (sieve positive? + (+ 2)) ▽)) 1 2 -3 4) (list 7 -1)) - (check-equal? ((☯ (~> (sieve positive? + (const 0)) ▽)) + (check-equal? ((☯ (~> (sieve positive? + (gen 0)) ▽)) 1 2 3 4) (list 10 0)) (check-equal? ((☯ (~> (sieve negative? ⏚ ⏚) ▽)) @@ -1041,7 +1043,7 @@ "pure control form of feedback")) (test-suite "group" - (check-equal? ((☯ (~> (group 0 (const 5) +) ▽)) + (check-equal? ((☯ (~> (group 0 (gen 5) +) ▽)) 1 2) (list 5 3)) (check-equal? ((☯ (~> (group 1 add1 sub1) ▽)) From 3a59e2df86aff52b4eec782b481ea0ea49a2268a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 11 Nov 2022 12:28:59 -0800 Subject: [PATCH 076/338] remove old scratch code --- qi-lib/flow/core/compiler.rkt | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 82642c2ad..499184454 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -53,14 +53,6 @@ (begin-for-syntax - (define (extract-kwargs stx) - ;; TODO: extract keyword args as (kw val ...) - null) - - (define (extract-posargs stx) - ;; TODO: extract positional args as (val ...) - null) - (define (find-and-map pred f stx) (map-transform (λ (v) (cond [(pred v) (f v)] @@ -213,8 +205,6 @@ ;; may change under composition within the form), while a ;; curried function will accept any number of arguments #:do [(define chirality (syntax-property this-syntax 'chirality))] - ;; #:with prarg-kw (extract-kwargs #'(prarg ...)) - ;; #:with prarg-pos (extract-posargs #'(prarg ...)) (if (and chirality (eq? chirality 'right)) #'(lambda args (apply natex prarg ... args)) @@ -223,7 +213,6 @@ ;; and need to handle the keyword arguments differently ;; from the positional arguments. #'(lambda args - ;; (apply natex #,@prarg-kw (append args #,@prarg-pos)) (let ([f (make-keyword-procedure (λ (kws kws-vs . pos) (keyword-apply natex kws kws-vs (append args pos))))]) From a4985b3f6b1e0aa29c7e46a5f74fb22420bde7c3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 11 Nov 2022 12:31:54 -0800 Subject: [PATCH 077/338] reduce size of partial application code --- qi-lib/flow/core/compiler.rkt | 5 +---- qi-lib/flow/core/impl.rkt | 8 +++++++- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 499184454..bfc2794ac 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -213,10 +213,7 @@ ;; and need to handle the keyword arguments differently ;; from the positional arguments. #'(lambda args - (let ([f (make-keyword-procedure - (λ (kws kws-vs . pos) - (keyword-apply natex kws kws-vs (append args pos))))]) - (f prarg ...))))])) + ((kw-helper natex args) prarg ...)))])) ;; The form-specific parsers, which are delegated to from ;; the qi0->racket macro: diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 58aca04b6..f1c345c33 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -19,7 +19,8 @@ foldr-values values->list feedback-times - feedback-while) + feedback-while + kw-helper) (require racket/match (only-in racket/function @@ -35,6 +36,11 @@ (define-syntax-parse-rule (values->list body:expr ...+) (call-with-values (λ () body ...) list)) +(define (kw-helper f args) + (make-keyword-procedure + (λ (kws kws-vs . pos) + (keyword-apply f kws kws-vs (append args pos))))) + ;; we use a lambda to capture the arguments at runtime ;; since they aren't available at compile time (define (loom-compose f g [n #f]) From 03034bb6c4a47af2004ca5699acd39666b616e95 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 11 Nov 2022 18:31:37 -0800 Subject: [PATCH 078/338] update some other tests --- qi-test/tests/on.rkt | 2 +- qi-test/tests/threading.rkt | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/qi-test/tests/on.rkt b/qi-test/tests/on.rkt index cf08c6087..224ea02c1 100644 --- a/qi-test/tests/on.rkt +++ b/qi-test/tests/on.rkt @@ -21,7 +21,7 @@ (list 5 5) "no clauses, binary") (check-equal? (on () - (const 3)) + (gen 3)) 3 "no arguments")) (test-suite diff --git a/qi-test/tests/threading.rkt b/qi-test/tests/threading.rkt index f1489b9d2..cfda5ed2c 100644 --- a/qi-test/tests/threading.rkt +++ b/qi-test/tests/threading.rkt @@ -16,8 +16,8 @@ "Edge/base cases" (check-equal? (values->list (~> ())) null) (check-equal? (values->list (~>> ())) null) - (check-equal? (~> () (const 5)) 5) - (check-equal? (~>> () (const 5)) 5) + (check-equal? (~> () (gen 5)) 5) + (check-equal? (~>> () (gen 5)) 5) (check-equal? (~> (4)) 4) (check-equal? (~>> (4)) 4) (check-equal? (values->list (~> (4 5 6))) '(4 5 6)) From dad2f659a98c42655b4cf4f5b16d1257dbcc69f1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 18 Nov 2022 11:02:07 -0800 Subject: [PATCH 079/338] add a failing test for "anaphoric" bindings references --- qi-test/tests/flow.rkt | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 0320a12ac..3b2be9a8a 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -11,7 +11,8 @@ racket/string racket/function (except-in "private/util.rkt" - add-two)) + add-two) + syntax/macro-testing) ;; used in the "language extension" tests for `qi:*` (define-syntax-rule (qi:square flo) @@ -119,7 +120,7 @@ (check-true ((☯ (and positive? (or integer? odd?))) - 5)) + 5)) (check-false ((☯ (and positive? (or (> 6) even?))) @@ -345,6 +346,11 @@ "bindings" (check-equal? ((☯ (~> (as v) (+ v))) 3) 3) + ;; convert-compile-time-error + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> sqr (list v) (as v) (gen v))) 3))) + "bindings cannot be referenced before being assigned") (let ([as (lambda (v) v)]) (check-equal? ((☯ (~> (gen (as 3))))) 3) ; TODO: why does this work? ;; TODO: uncomment for bindings From c7a4c8a47ac2506b9b074f0dbfd8ee6b25981386 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 29 Nov 2022 10:44:35 -0800 Subject: [PATCH 080/338] declare binding rules --- qi-lib/flow/extended/expander.rkt | 32 +++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 4e2896da3..a4710084e 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -22,13 +22,34 @@ (define-hosted-syntaxes ;; Declare a compile-time datatype by which qi macros may ;; be identified. + (binding-class qi-var) (extension-class qi-macro #:binding-space qi) (nonterminal floe - ;; Check first whether the form is a macro. If it is, expand it. - ;; This is prioritized over other forms so that extensions may - ;; override built-in Qi forms. - #:allow-extension qi-macro + f:binding-floe + #:binding (nest-one f [])) + (nesting-nonterminal binding-floe (nested) + ;; Check first whether the form is a macro. If it is, expand it. + ;; This is prioritized over other forms so that extensions may + ;; override built-in Qi forms. + #:allow-extension qi-macro + + #:binding-space qi + + (as v:qi-var ...+) + #:binding {(bind v) nested} + + (thread f:binding-floe ...) + #:binding (nest f nested) + + ;; [f nested] is the implicit binding rule + ;; anything not mentioned (e.g. nested) is treated as a + ;; subexpression that's not in any scope + ;; Note: this could be at the top level floe after + ;; binding-floe, but that isnt supported atm because + ;; it doesn't backtrack + f:simple-floe) + (nonterminal simple-floe #:binding-space qi (gen e:expr ...) ;; Ad hoc expansion rule to allow _ to be used in application @@ -40,7 +61,6 @@ (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) _ ground - (thread f:floe ...) (relay f:floe ...) relay (tee f:floe ...) @@ -129,7 +149,7 @@ clos (clos onex:floe) (esc ex:expr) - (as v:id) + ;; backwards compat macro extensibility via Racket macros (~> ((~var ext-form (starts-with "qi:")) expr ...) #'(esc (ext-form expr ...))) From 03aa552917a789da8a29cf61881d98db2dde522f Mon Sep 17 00:00:00 2001 From: Michael Ballantyne Date: Tue, 6 Dec 2022 14:08:04 -0500 Subject: [PATCH 081/338] use new bindingspec features and syntax syntax-spec, host, racket-var --- qi-lib/flow/extended/expander.rkt | 311 ++++++++++++++++-------------- 1 file changed, 164 insertions(+), 147 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index a4710084e..3b3e79604 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -19,164 +19,181 @@ syntax/parse "../../private/util.rkt")) -(define-hosted-syntaxes +(syntax-spec ;; Declare a compile-time datatype by which qi macros may ;; be identified. - (binding-class qi-var) (extension-class qi-macro #:binding-space qi) (nonterminal floe - f:binding-floe - #:binding (nest-one f [])) - (nesting-nonterminal binding-floe (nested) - ;; Check first whether the form is a macro. If it is, expand it. - ;; This is prioritized over other forms so that extensions may - ;; override built-in Qi forms. - #:allow-extension qi-macro + f:binding-floe + #:binding (nest-one f [])) + (nonterminal/nesting binding-floe (nested) + ;; Check first whether the form is a macro. If it is, expand it. + ;; This is prioritized over other forms so that extensions may + ;; override built-in Qi forms. + #:allow-extension qi-macro - #:binding-space qi + #:binding-space qi - (as v:qi-var ...+) - #:binding {(bind v) nested} + (as v:racket-var ...+) + #:binding {(bind v) nested} - (thread f:binding-floe ...) - #:binding (nest f nested) + (thread f:binding-floe ...) + #:binding (nest f nested) - ;; [f nested] is the implicit binding rule - ;; anything not mentioned (e.g. nested) is treated as a - ;; subexpression that's not in any scope - ;; Note: this could be at the top level floe after - ;; binding-floe, but that isnt supported atm because - ;; it doesn't backtrack - f:simple-floe) + ;; [f nested] is the implicit binding rule + ;; anything not mentioned (e.g. nested) is treated as a + ;; subexpression that's not in any scope + ;; Note: this could be at the top level floe after + ;; binding-floe, but that isnt supported atm because + ;; it doesn't backtrack + f:simple-floe) (nonterminal simple-floe - #:binding-space qi - (gen e:expr ...) - ;; Ad hoc expansion rule to allow _ to be used in application - ;; position in a template. - ;; Without it, (_ v ...) would be treated as an error since - ;; _ is an unrelated form of the core language having different - ;; semantics. The expander would assume it is a syntax error - ;; from that perspective. - (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) - _ - ground - (relay f:floe ...) - relay - (tee f:floe ...) - tee - amp - (amp f:floe) - (~>/form (amp f0:clause f:clause ...) - ;; potentially pull out as a phase 1 function - ;; just a stopgap until better error messages - (report-syntax-error - this-syntax - "(>< flo)" - "amp expects a single flow specification, but it received many.")) - pass - (pass f:floe) - sep - (sep f:floe) - collect - AND - OR - NOT - XOR - (and f:floe ...) - (or f:floe ...) - (not f:floe) - (select e:expr ...) - (~>/form (select arg ...) - (report-syntax-error this-syntax - "(select ...)")) - (block e:expr ...) - (~>/form (block arg ...) - (report-syntax-error this-syntax - "(block ...)")) - (group n:expr e1:floe e2:floe) - group - (~>/form (group arg ...) - (report-syntax-error this-syntax - "(group )")) - (if consequent:floe - alternative:floe) - (if condition:floe - consequent:floe - alternative:floe) - (sieve condition:floe - sonex:floe - ronex:floe) - sieve - (~>/form (sieve arg ...) - (report-syntax-error this-syntax - "(sieve )")) - (try flo:floe - [error-condition-flo:floe error-handler-flo:floe] - ...+) - (~>/form (try arg ...) - (report-syntax-error this-syntax - "(try [error-predicate-flo error-handler-flo] ...)")) - >> - (>> fn:floe init:floe) - (>> fn:floe) - << - (<< fn:floe init:floe) - (<< fn:floe) - (feedback ((~datum while) tilex:floe) - ((~datum then) thenex:floe) - onex:floe) - (feedback ((~datum while) tilex:floe) - ((~datum then) thenex:floe)) - (feedback ((~datum while) tilex:floe) onex:floe) - (feedback ((~datum while) tilex:floe)) - (feedback n:expr - ((~datum then) thenex:floe) - onex:floe) - (feedback n:expr - ((~datum then) thenex:floe)) - (feedback n:expr onex:floe) - (feedback onex:floe) - feedback - (loop pred:floe mapex:floe combex:floe retex:floe) - (loop pred:floe mapex:floe combex:floe) - (loop pred:floe mapex:floe) - (loop mapex:floe) - loop - (loop2 pred:floe mapex:floe combex:floe) - appleye - (~> (~literal apply) #'appleye) - clos - (clos onex:floe) - (esc ex:expr) + #:binding-space qi + (gen e:expr ...) + #:binding (host e) + ;; Ad hoc expansion rule to allow _ to be used in application + ;; position in a template. + ;; Without it, (_ v ...) would be treated as an error since + ;; _ is an unrelated form of the core language having different + ;; semantics. The expander would assume it is a syntax error + ;; from that perspective. + (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) + _ + ground + (relay f:floe ...) + relay + (tee f:floe ...) + tee + amp + (amp f:floe) + (~>/form (amp f0:clause f:clause ...) + ;; potentially pull out as a phase 1 function + ;; just a stopgap until better error messages + (report-syntax-error + this-syntax + "(>< flo)" + "amp expects a single flow specification, but it received many.")) + pass + (pass f:floe) + sep + (sep f:floe) + collect + AND + OR + NOT + XOR + (and f:floe ...) + (or f:floe ...) + (not f:floe) + (select n:number ...) + (~>/form (select arg ...) + (report-syntax-error this-syntax + "(select ...)")) + (block n:number ...) + (~>/form (block arg ...) + (report-syntax-error this-syntax + "(block ...)")) + (group n:expr e1:floe e2:floe) + #:binding (host n) + group + (~>/form (group arg ...) + (report-syntax-error this-syntax + "(group )")) + (if consequent:floe + alternative:floe) + (if condition:floe + consequent:floe + alternative:floe) + (sieve condition:floe + sonex:floe + ronex:floe) + sieve + (~>/form (sieve arg ...) + (report-syntax-error this-syntax + "(sieve )")) + (try flo:floe + [error-condition-flo:floe error-handler-flo:floe] + ...+) + (~>/form (try arg ...) + (report-syntax-error this-syntax + "(try [error-predicate-flo error-handler-flo] ...)")) + >> + (>> fn:floe init:floe) + (>> fn:floe) + << + (<< fn:floe init:floe) + (<< fn:floe) + (feedback ((~datum while) tilex:floe) + ((~datum then) thenex:floe) + onex:floe) + (feedback ((~datum while) tilex:floe) + ((~datum then) thenex:floe)) + (feedback ((~datum while) tilex:floe) onex:floe) + (feedback ((~datum while) tilex:floe)) + (feedback n:expr + ((~datum then) thenex:floe) + onex:floe) + #:binding (host n) + (feedback n:expr + ((~datum then) thenex:floe)) + #:binding (host n) + (feedback n:expr onex:floe) + #:binding (host n) + (feedback onex:floe) + feedback + (loop pred:floe mapex:floe combex:floe retex:floe) + (loop pred:floe mapex:floe combex:floe) + (loop pred:floe mapex:floe) + (loop mapex:floe) + loop + (loop2 pred:floe mapex:floe combex:floe) + appleye + (~> (~literal apply) #'appleye) + clos + (clos onex:floe) + (esc ex:expr) + #:binding (host ex) - ;; backwards compat macro extensibility via Racket macros - (~> ((~var ext-form (starts-with "qi:")) expr ...) - #'(esc (ext-form expr ...))) - ;; a literal is interpreted as a flow generating it - (~> val:literal - #'(gen val)) - ;; Certain rules of the language aren't determined by the "head" - ;; position, so naively, these can't be core forms. In order to - ;; treat them as core forms, we tag them at the expander level - ;; by wrapping them with #%-prefixed forms, similar to Racket's - ;; approach to a similiar case - "interposition points." These - ;; new forms can then be treated as core forms in the compiler. - (~> f:blanket-template-form - #'(#%blanket-template f)) - (#%blanket-template (arg:any-stx ...)) - (~> f:fine-template-form - #'(#%fine-template f)) - (#%fine-template (arg:any-stx ...)) - ;; The core rule must come before the tagging rule here since - ;; the former as a production of the latter would still match - ;; the latter (i.e. it is still a parenthesized expression), - ;; which would lead to infinite code generation. - (#%partial-application (arg:any-stx ...)) - (~> f:partial-application-form - #'(#%partial-application f)) - ;; literally indicated function identifier - (~> f:id #'(esc f)))) + ;; backwards compat macro extensibility via Racket macros + (~> ((~var ext-form (starts-with "qi:")) expr ...) + #'(esc (ext-form expr ...))) + ;; a literal is interpreted as a flow generating it + (~> val:literal + #'(gen val)) + ;; Certain rules of the language aren't determined by the "head" + ;; position, so naively, these can't be core forms. In order to + ;; treat them as core forms, we tag them at the expander level + ;; by wrapping them with #%-prefixed forms, similar to Racket's + ;; approach to a similiar case - "interposition points." These + ;; new forms can then be treated as core forms in the compiler. + (~> f:blanket-template-form + #'(#%blanket-template f)) + + (#%blanket-template (arg:arg-stx ...)) + + (~> f:fine-template-form + #'(#%fine-template f)) + (#%fine-template (arg:arg-stx ...)) + + ;; The core rule must come before the tagging rule here since + ;; the former as a production of the latter would still match + ;; the latter (i.e. it is still a parenthesized expression), + ;; which would lead to infinite code generation. + (#%partial-application (arg:arg-stx ...)) + + (~> f:partial-application-form + #'(#%partial-application f)) + ;; literally indicated function identifier + (~> f:id #'(esc f))) + + (nonterminal arg-stx + (~datum _) + (~datum __) + k:keyword + + e:expr + #:binding (host e))) (begin-for-syntax (define (expand-flow stx) From aa5f10ead8d0a92bdc43599ac0c60b3e45eb5da8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 12:59:18 -0800 Subject: [PATCH 082/338] Complete support for bindings - support binding single or multiple values - don't apply the bindings transformation on host expressions - mark outdated docs for review --- qi-doc/scribblings/field-guide.scrbl | 1 + qi-doc/scribblings/interface.scrbl | 13 ------ qi-lib/flow/core/compiler.rkt | 60 +++++++++++++++------------- qi-test/tests/flow.rkt | 12 +++--- 4 files changed, 40 insertions(+), 46 deletions(-) diff --git a/qi-doc/scribblings/field-guide.scrbl b/qi-doc/scribblings/field-guide.scrbl index 3b9dafbfc..a73ba2511 100644 --- a/qi-doc/scribblings/field-guide.scrbl +++ b/qi-doc/scribblings/field-guide.scrbl @@ -342,6 +342,7 @@ Another way to do it is to simply promote the expression out of the nest: (~> (3) (get-f 1)) ] +@;{Update this to reflect new partial application behavior} Now, you might, once again, expect this to be treated as a partial application template, so that this would be equivalent to @racket[(get-f 3 1)] and would raise an error. But in fact, since the expression @racket[(get-f 1)] happens to be fully qualified with all the arguments it needs, the currying employed under the hood to implement partial application in this case @seclink["Using_Racket_to_Define_Flows"]{evaluates to a function result right away}. This then receives the value @racket[3], and consequently, this expression produces the correct result. So in sum, it's perhaps best to rely on @racket[esc] in such cases to be as explicit as possible about what you mean, rather than rely on quirks of the implementation that are revealed at this boundary between two languages. diff --git a/qi-doc/scribblings/interface.scrbl b/qi-doc/scribblings/interface.scrbl index 991e7570f..6a085e5fc 100644 --- a/qi-doc/scribblings/interface.scrbl +++ b/qi-doc/scribblings/interface.scrbl @@ -360,19 +360,6 @@ The second way is if you want to describe a flow using the host language instead (~> (3 5) add-two) ] -Finally, note that the following case works: - -@examples[ - #:eval eval-for-docs - (define (get-flow v) - (☯ (~> sqr (+ v)))) - (~> (5) (get-flow 3)) - ] - -You might expect here that the expression @racket[(get-flow 3)] would be treated as a @seclink["Templates_and_Partial_Application"]{partial application template}, so that the value @racket[5] would be provided to it as @racket[(get-flow 5 3)], resulting in an error. The reason this isn't what happens is that the partial application behavior in Qi when no argument positions have been indicated is implemented using currying rather than as a template application, and Racket's @racket[curry] and @racket[curryr] functions happen to evaluate to a result immediately if the maximum expected arguments have been provided. Thus, in this case, the @racket[(get-flow 3)] expression is first evaluated to produce a resulting flow which then receives the value @racket[5]. - -So, function applications where all of the arguments are provided syntactically, and which produce functions as their result, may be used as if they were simple function identifiers, and @racket[esc] may be left out. - @subsection{Using Racket Macros as Flows} Flows are expected to be @seclink["What_is_a_Flow_"]{functions}, and so you cannot naively use a macro as a flow. But there are many ways in which you can. If you'd just like to use such a macro in a one-off manner, see @secref["Converting_a_Macro_to_a_Flow"] for an ad hoc way to do this. But a simpler and more complete way in many cases is to first register the macro (or any number of such macros) using @racket[define-qi-foreign-syntaxes] prior to use. diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index bfc2794ac..0d57f009c 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -7,8 +7,7 @@ racket/match "syntax.rkt" "../aux-syntax.rkt" - racket/format - ee-lib) + racket/format) "impl.rkt" racket/function racket/undefined @@ -53,39 +52,44 @@ (begin-for-syntax - (define (find-and-map pred f stx) - (map-transform (λ (v) - (cond [(pred v) (f v)] - [else v])) - stx)) - - (define (binding-form? stx) - (syntax-parse stx - [((~datum as) v:id) #t] - [_ #f])) + (define (find-and-map f stx) + ;; f : syntax? -> (or/c syntax? #f) + (match stx + [(? syntax?) (let ([stx^ (f stx)]) + (or stx^ (datum->syntax stx + (find-and-map f (syntax-e stx)) + stx + stx)))] + [(cons a d) (cons (find-and-map f a) + (find-and-map f d))] + [_ stx])) + + (define (find-and-map/qi f stx) + ;; #%host-expression is a Racket macro defined by syntax-spec + ;; that resumes expansion of its sub-expression with an + ;; expander environment containing the original surface bindings + (find-and-map (syntax-parser [((~datum #%host-expression) e:expr) this-syntax] + [_ (f this-syntax)]) + stx)) ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) ;; TODO: use a box instead of set! - (define (rewrite-binding stx) - (syntax-parse stx - [(_ idx) - #'(thread (esc (λ (x) (set! idx x))) ground)])) - (define (rewrite-all-bindings stx) - (find-and-map binding-form? - rewrite-binding - stx)) + (find-and-map/qi (syntax-parser + [((~datum as) x ...) + #:with (x-val ...) (generate-temporaries (attribute x)) + #'(thread (esc (λ (x-val ...) (set! x x-val) ...)) ground)] + [_ #f]) + stx)) (define (bound-identifiers stx) (let ([ids null]) - (find-and-map binding-form? - (λ (v) - (syntax-parse v - [(_ x) - (set! ids - (cons #'x ids))]) - v) - stx) + (find-and-map/qi (syntax-parser + [((~datum as) x ...) + (set! ids + (append (attribute x) ids))] + [_ #f]) + stx) ids)) ;; wrap stx with (let ([v undefined] ...) stx) for v ∈ ids diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 3b2be9a8a..0efc8d73e 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -345,17 +345,19 @@ (test-suite "bindings" (check-equal? ((☯ (~> (as v) (+ v))) 3) - 3) + 3 + "binds a single value") + (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) + 7 + "binds multiple values") ;; convert-compile-time-error (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> sqr (list v) (as v) (gen v))) 3))) "bindings cannot be referenced before being assigned") (let ([as (lambda (v) v)]) - (check-equal? ((☯ (~> (gen (as 3))))) 3) ; TODO: why does this work? - ;; TODO: uncomment for bindings - ;; (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3) - )) + (check-equal? ((☯ (~> (gen (as 3))))) 3) + (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3))) (test-suite "routing forms" From e2788785d7adb2e1a27d9f6679929f046543c84b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 13:16:33 -0800 Subject: [PATCH 083/338] Provide helpful error message when `as` is used outside of `~>` --- qi-lib/flow/extended/expander.rkt | 16 +++++++++++++++- qi-test/tests/flow.rkt | 4 ++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 3b3e79604..cfc25d30c 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -25,7 +25,7 @@ (extension-class qi-macro #:binding-space qi) (nonterminal floe - f:binding-floe + f:threading-floe #:binding (nest-one f [])) (nonterminal/nesting binding-floe (nested) ;; Check first whether the form is a macro. If it is, expand it. @@ -38,6 +38,20 @@ (as v:racket-var ...+) #:binding {(bind v) nested} + f:threading-floe + #:binding (nest-one f nested)) + (nonterminal/nesting threading-floe (nested) + ;; Check first whether the form is a macro. If it is, expand it. + ;; This is prioritized over other forms so that extensions may + ;; override built-in Qi forms. + #:allow-extension qi-macro + + #:binding-space qi + + (~> ((~literal as) v:id ...+) + (report-syntax-error this-syntax + "(as ...) may only be used inside ~>")) + (thread f:binding-floe ...) #:binding (nest f nested) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 0efc8d73e..085f99c44 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -350,6 +350,10 @@ (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) 7 "binds multiple values") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> list (-< vs (as vs))))))) + "using `as` outside a threading form is an error") ;; convert-compile-time-error (check-exn exn:fail? (thunk (convert-compile-time-error From fb3cdc15f7df979c023c88b1832777ba6be0b821 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 14:33:25 -0800 Subject: [PATCH 084/338] Use official syntax-spec interface to define the host interface Formerly we were using an internal utility to generate the expander from the syntax-spec grammar. We now do it using a syntax-spec macro subform. This also adds descriptions to the flow nonterminals which are used in error messages. --- qi-lib/flow.rkt | 20 ++++++++++++++------ qi-lib/flow/aux-syntax.rkt | 2 +- qi-lib/flow/extended/expander.rkt | 28 ++++++++++++++-------------- 3 files changed, 29 insertions(+), 21 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index f5fc09f5b..a09d0e62f 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -1,11 +1,12 @@ #lang racket/base -(provide flow +(provide (rename-out [flow-interface flow]) ☯ (all-from-out "flow/extended/expander.rkt") (all-from-out "flow/extended/forms.rkt")) (require syntax/parse/define + bindingspec (prefix-in fancy: fancy-app) racket/function (only-in racket/list @@ -20,7 +21,7 @@ (only-in "private/util.rkt" define-alias)) -(define-alias ☯ flow) +(define-alias ☯ flow-interface) #| The `flow` macro specifies the Qi language. In cases where there is @@ -36,11 +37,18 @@ module, defined after the flow macro. They are all invoked as needed in the flow macro. |# -(define-syntax-parser flow - [(_ onex) ((compose compile-flow expand-flow) #'onex)] - ;; a non-flow +(syntax-spec + (host-interface/expression + (flow f:floe) + (compile-flow #'f))) + +(define-syntax-parser flow-interface + ;; we could define `flow` exclusively using syntax-spec if there weren't + ;; these extra-linguistic cases to handle. Otherwise, if we did that now, + ;; the multi-argument case would only report the intended error message + ;; if the component expressions were valid flows + [(_ onex) #'(flow onex)] [(_) #'values] - ;; error handling catch-all [(_ expr0 expr ...+) (report-syntax-error this-syntax diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index 0f12421db..b1dba0ea1 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -10,13 +10,13 @@ (define-syntax-class literal (pattern + ;; TODO: would be ideal to also match literal vectors, boxes and prefabs (~or* expr:boolean expr:char expr:string expr:bytes expr:number expr:regexp - expr:byte-regexp ;; We'd like to treat quoted forms as literals as well. This ;; includes symbols, and would also include, for instance, ;; syntactic specifications of flows, since flows are diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index cfc25d30c..75a8e03aa 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -1,7 +1,7 @@ #lang racket/base -(provide (for-syntax expand-flow - qi-macro) +(provide (for-syntax qi-macro + floe) (for-space qi (all-defined-out) (rename-out [ground ⏚] @@ -20,14 +20,16 @@ "../../private/util.rkt")) (syntax-spec - ;; Declare a compile-time datatype by which qi macros may - ;; be identified. - (extension-class qi-macro - #:binding-space qi) + ;; Declare a compile-time datatype by which qi macros may + ;; be identified. + (extension-class qi-macro + #:binding-space qi) (nonterminal floe + #:description "a flow expression" f:threading-floe #:binding (nest-one f [])) (nonterminal/nesting binding-floe (nested) + #:description "a flow expression" ;; Check first whether the form is a macro. If it is, expand it. ;; This is prioritized over other forms so that extensions may ;; override built-in Qi forms. @@ -41,6 +43,7 @@ f:threading-floe #:binding (nest-one f nested)) (nonterminal/nesting threading-floe (nested) + #:description "a flow expression" ;; Check first whether the form is a macro. If it is, expand it. ;; This is prioritized over other forms so that extensions may ;; override built-in Qi forms. @@ -63,6 +66,7 @@ ;; it doesn't backtrack f:simple-floe) (nonterminal simple-floe + #:description "a flow expression" #:binding-space qi (gen e:expr ...) #:binding (host e) @@ -127,8 +131,8 @@ (report-syntax-error this-syntax "(sieve )")) (try flo:floe - [error-condition-flo:floe error-handler-flo:floe] - ...+) + [error-condition-flo:floe error-handler-flo:floe] + ...+) (~>/form (try arg ...) (report-syntax-error this-syntax "(try [error-predicate-flo error-handler-flo] ...)")) @@ -200,15 +204,11 @@ #'(#%partial-application f)) ;; literally indicated function identifier (~> f:id #'(esc f))) - + (nonterminal arg-stx (~datum _) (~datum __) k:keyword - + e:expr #:binding (host e))) - -(begin-for-syntax - (define (expand-flow stx) - ((nonterminal-expander floe) stx))) From 370cb10b249ccd92d88a034e9b37601f941abb4b Mon Sep 17 00:00:00 2001 From: Michael Ballantyne Date: Fri, 9 Dec 2022 20:03:45 -0500 Subject: [PATCH 085/338] switch dependency to renamed syntax-spec --- qi-lib/flow.rkt | 2 +- qi-lib/flow/extended/expander.rkt | 2 +- qi-lib/info.rkt | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index a09d0e62f..6624c92ca 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -6,7 +6,7 @@ (all-from-out "flow/extended/forms.rkt")) (require syntax/parse/define - bindingspec + syntax-spec (prefix-in fancy: fancy-app) racket/function (only-in racket/list diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 75a8e03aa..a22232038 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -12,7 +12,7 @@ [sep △] [collect ▽]))) -(require bindingspec +(require syntax-spec (for-syntax "../aux-syntax.rkt" "syntax.rkt" racket/base diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index d4d4cc6a9..630025a20 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -5,8 +5,8 @@ (define deps '("base" ("fancy-app" #:version "1.1") ;; this git URL should be changed to a named package spec - ;; once bindingspec is on the package index - "git://github.com/michaelballantyne/bindingspec.git#main")) + ;; once syntax-spec is on the package index + "git://github.com/michaelballantyne/syntax-spec.git#main")) (define build-deps '()) (define clean '("compiled" "private/compiled")) (define pkg-authors '(countvajhula)) From 33ac6ed28b53b717f549185fe0c0d6d590e1f278 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 17:27:51 -0800 Subject: [PATCH 086/338] Declare flow macro exclusively with syntax-spec Avoid defining the wrapping syntax-parse macro, since it's useful in only a few corner cases anyway, and this makes the implementation a lot cleaner. --- qi-lib/flow.rkt | 31 ++++++++++++++----------------- qi-lib/flow/extended/expander.rkt | 13 +++++++++---- 2 files changed, 23 insertions(+), 21 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index 6624c92ca..8975469e1 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -1,6 +1,6 @@ #lang racket/base -(provide (rename-out [flow-interface flow]) +(provide flow ☯ (all-from-out "flow/extended/expander.rkt") (all-from-out "flow/extended/forms.rkt")) @@ -21,7 +21,7 @@ (only-in "private/util.rkt" define-alias)) -(define-alias ☯ flow-interface) +(define-alias ☯ flow) #| The `flow` macro specifies the Qi language. In cases where there is @@ -39,18 +39,15 @@ in the flow macro. (syntax-spec (host-interface/expression - (flow f:floe) - (compile-flow #'f))) - -(define-syntax-parser flow-interface - ;; we could define `flow` exclusively using syntax-spec if there weren't - ;; these extra-linguistic cases to handle. Otherwise, if we did that now, - ;; the multi-argument case would only report the intended error message - ;; if the component expressions were valid flows - [(_ onex) #'(flow onex)] - [(_) #'values] - [(_ expr0 expr ...+) - (report-syntax-error - this-syntax - "(flow flo)" - "flow expects a single flow specification, but it received many.")]) + (flow f:floe ...) + (syntax-parse #'(f ...) + [(f) (compile-flow #'f)] + ;; a non-flow + [() #'values] + ;; error handling catch-all + [(expr0 expr ...+) + (report-syntax-error + (datum->syntax this-syntax + (cons 'flow (syntax->list this-syntax))) + "(flow flo)" + "flow expects a single flow specification, but it received many.")]))) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index a22232038..b400ce62a 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -20,14 +20,17 @@ "../../private/util.rkt")) (syntax-spec - ;; Declare a compile-time datatype by which qi macros may - ;; be identified. - (extension-class qi-macro - #:binding-space qi) + + ;; Declare a compile-time datatype by which qi macros may + ;; be identified. + (extension-class qi-macro + #:binding-space qi) + (nonterminal floe #:description "a flow expression" f:threading-floe #:binding (nest-one f [])) + (nonterminal/nesting binding-floe (nested) #:description "a flow expression" ;; Check first whether the form is a macro. If it is, expand it. @@ -42,6 +45,7 @@ f:threading-floe #:binding (nest-one f nested)) + (nonterminal/nesting threading-floe (nested) #:description "a flow expression" ;; Check first whether the form is a macro. If it is, expand it. @@ -65,6 +69,7 @@ ;; binding-floe, but that isnt supported atm because ;; it doesn't backtrack f:simple-floe) + (nonterminal simple-floe #:description "a flow expression" #:binding-space qi From 7480010b5eacb317f6d08fcd41d32951b3a6ba54 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 18:40:30 -0800 Subject: [PATCH 087/338] Cleanup - Remove unused requires and stale comments - use `flow` internally in qi-lib to aid searchability --- qi-lib/flow.rkt | 7 +------ qi-lib/flow/core/compiler.rkt | 3 +-- qi-lib/flow/core/impl.rkt | 2 -- qi-lib/flow/extended/expander.rkt | 10 ++-------- qi-lib/flow/extended/forms.rkt | 3 +-- qi-lib/macro.rkt | 2 -- qi-lib/switch.rkt | 2 +- qi-test/tests/macro.rkt | 3 +-- qi-test/tests/on.rkt | 3 +-- qi-test/tests/qi.rkt | 3 +-- qi-test/tests/threading.rkt | 3 +-- 11 files changed, 10 insertions(+), 31 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index 8975469e1..694a24012 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -5,12 +5,7 @@ (all-from-out "flow/extended/expander.rkt") (all-from-out "flow/extended/forms.rkt")) -(require syntax/parse/define - syntax-spec - (prefix-in fancy: fancy-app) - racket/function - (only-in racket/list - make-list) +(require syntax-spec (for-syntax racket/base syntax/parse (only-in "private/util.rkt" diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 0d57f009c..29026b866 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -6,8 +6,7 @@ syntax/parse racket/match "syntax.rkt" - "../aux-syntax.rkt" - racket/format) + "../aux-syntax.rkt") "impl.rkt" racket/function racket/undefined diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index f1c345c33..85e5eb9de 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -24,8 +24,6 @@ (require racket/match (only-in racket/function - thunk - thunk* negate) racket/bool racket/list diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index b400ce62a..86554c3ce 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -28,16 +28,13 @@ (nonterminal floe #:description "a flow expression" + f:threading-floe #:binding (nest-one f [])) (nonterminal/nesting binding-floe (nested) #:description "a flow expression" - ;; Check first whether the form is a macro. If it is, expand it. - ;; This is prioritized over other forms so that extensions may - ;; override built-in Qi forms. #:allow-extension qi-macro - #:binding-space qi (as v:racket-var ...+) @@ -48,11 +45,7 @@ (nonterminal/nesting threading-floe (nested) #:description "a flow expression" - ;; Check first whether the form is a macro. If it is, expand it. - ;; This is prioritized over other forms so that extensions may - ;; override built-in Qi forms. #:allow-extension qi-macro - #:binding-space qi (~> ((~literal as) v:id ...+) @@ -73,6 +66,7 @@ (nonterminal simple-floe #:description "a flow expression" #:binding-space qi + (gen e:expr ...) #:binding (host e) ;; Ad hoc expansion rule to allow _ to be used in application diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 78bc3c5be..8901b4bda 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -13,8 +13,7 @@ syntax/parse (only-in racket/list make-list) "syntax.rkt" - "../aux-syntax.rkt" - "../../private/util.rkt") + "../aux-syntax.rkt") "expander.rkt" "../../macro.rkt" "impl.rkt") diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index ffdaf456e..fbb96a056 100644 --- a/qi-lib/macro.rkt +++ b/qi-lib/macro.rkt @@ -7,14 +7,12 @@ (for-syntax qi-macro)) (require (for-syntax racket/base - syntax/parse racket/format racket/match racket/list) (only-in "flow/extended/expander.rkt" qi-macro esc) - racket/format syntax/parse/define syntax/parse) diff --git a/qi-lib/switch.rkt b/qi-lib/switch.rkt index aeb9a5df1..a5c3dbf2e 100644 --- a/qi-lib/switch.rkt +++ b/qi-lib/switch.rkt @@ -48,4 +48,4 @@ expr ...))] [(_ name:id expr:expr ...) #'(define name - (☯ (switch expr ...)))]) + (flow (switch expr ...)))]) diff --git a/qi-test/tests/macro.rkt b/qi-test/tests/macro.rkt index 252bc6f97..a7a80df95 100644 --- a/qi-test/tests/macro.rkt +++ b/qi-test/tests/macro.rkt @@ -7,8 +7,7 @@ rackunit/text-ui (only-in math sqr) (only-in racket/function thunk) - (for-syntax syntax/parse - racket/base) + (for-syntax racket/base) syntax/parse/define "private/util.rkt") diff --git a/qi-test/tests/on.rkt b/qi-test/tests/on.rkt index 224ea02c1..0fec5949f 100644 --- a/qi-test/tests/on.rkt +++ b/qi-test/tests/on.rkt @@ -6,8 +6,7 @@ rackunit rackunit/text-ui (only-in math sqr) - (only-in adjutor values->list) - racket/function) + (only-in adjutor values->list)) (define tests (test-suite diff --git a/qi-test/tests/qi.rkt b/qi-test/tests/qi.rkt index 3b4705089..c3f675232 100644 --- a/qi-test/tests/qi.rkt +++ b/qi-test/tests/qi.rkt @@ -8,8 +8,7 @@ (prefix-in threading: "threading.rkt") (prefix-in definitions: "definitions.rkt") (prefix-in macro: "macro.rkt") - (prefix-in util: "util.rkt") - "private/util.rkt") + (prefix-in util: "util.rkt")) (define tests (test-suite diff --git a/qi-test/tests/threading.rkt b/qi-test/tests/threading.rkt index cfda5ed2c..1af68e1ec 100644 --- a/qi-test/tests/threading.rkt +++ b/qi-test/tests/threading.rkt @@ -6,8 +6,7 @@ rackunit rackunit/text-ui (only-in math sqr) - (only-in adjutor values->list) - racket/function) + (only-in adjutor values->list)) (define tests (test-suite From 291dd334e00ab6babf037bfc7a84e762b482a343 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 19:04:14 -0800 Subject: [PATCH 088/338] Add back accidentally-removed byte-regexp literal support --- qi-lib/flow/aux-syntax.rkt | 1 + qi-test/tests/flow.rkt | 2 ++ 2 files changed, 3 insertions(+) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index b1dba0ea1..38e765c07 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -17,6 +17,7 @@ expr:bytes expr:number expr:regexp + expr:byte-regexp ;; We'd like to treat quoted forms as literals as well. This ;; includes symbols, and would also include, for instance, ;; syntactic specifications of flows, since flows are diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 085f99c44..29bf82cda 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -55,6 +55,8 @@ (check-equal? ((flow #"hi") 5) #"hi" "literal byte string") (check-equal? ((flow #px"hi") 5) #px"hi" "literal regexp") (check-equal? ((flow #rx"hi") 5) #rx"hi" "literal regexp") + (check-equal? ((flow #px#"hi") 5) #px#"hi" "bytestring literal regexp") + (check-equal? ((flow #rx#"hi") 5) #rx#"hi" "bytestring literal regexp") (check-equal? ((flow 'hi) 5) 'hi "literal symbol") (check-equal? ((flow '(+ 1 2)) 5) '(+ 1 2) "literal quoted list") (check-equal? ((flow `(+ 1 ,(* 2 3))) 5) '(+ 1 6) "literal quasiquoted list") From 957779277a2db93eb59fd65981286e39843bd24a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 19:10:25 -0800 Subject: [PATCH 089/338] Support literal vectors --- qi-lib/flow/aux-syntax.rkt | 5 +++++ qi-test/tests/flow.rkt | 1 + 2 files changed, 6 insertions(+) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index 38e765c07..d8d5302c1 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -18,6 +18,7 @@ expr:number expr:regexp expr:byte-regexp + expr:vector-literal ;; We'd like to treat quoted forms as literals as well. This ;; includes symbols, and would also include, for instance, ;; syntactic specifications of flows, since flows are @@ -40,6 +41,10 @@ (pattern expr:expr)) +(define-syntax-class vector-literal + (pattern + #(_ ...))) + (define-syntax-class (starts-with pfx) (pattern i:id #:when (string-prefix? (symbol->string diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 29bf82cda..146abdfb0 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -58,6 +58,7 @@ (check-equal? ((flow #px#"hi") 5) #px#"hi" "bytestring literal regexp") (check-equal? ((flow #rx#"hi") 5) #rx#"hi" "bytestring literal regexp") (check-equal? ((flow 'hi) 5) 'hi "literal symbol") + (check-equal? ((flow #(1 2 3)) 2) #(1 2 3) "literal vector") (check-equal? ((flow '(+ 1 2)) 5) '(+ 1 2) "literal quoted list") (check-equal? ((flow `(+ 1 ,(* 2 3))) 5) '(+ 1 6) "literal quasiquoted list") (check-equal? (syntax->datum ((flow #'(+ 1 2)) 5)) '(+ 1 2) "Literal syntax quoted list")) From 70e6d1c82908823c653391b3bc0191880766802d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 19:11:15 -0800 Subject: [PATCH 090/338] Support literal boxes --- qi-lib/flow/aux-syntax.rkt | 4 ++++ qi-test/tests/flow.rkt | 2 ++ 2 files changed, 6 insertions(+) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index d8d5302c1..df8443c95 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -19,6 +19,7 @@ expr:regexp expr:byte-regexp expr:vector-literal + expr:box-literal ;; We'd like to treat quoted forms as literals as well. This ;; includes symbols, and would also include, for instance, ;; syntactic specifications of flows, since flows are @@ -45,6 +46,9 @@ (pattern #(_ ...))) +(define-syntax-class box-literal + (pattern #&v)) + (define-syntax-class (starts-with pfx) (pattern i:id #:when (string-prefix? (symbol->string diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 146abdfb0..bbe9231d3 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -59,6 +59,8 @@ (check-equal? ((flow #rx#"hi") 5) #rx#"hi" "bytestring literal regexp") (check-equal? ((flow 'hi) 5) 'hi "literal symbol") (check-equal? ((flow #(1 2 3)) 2) #(1 2 3) "literal vector") + (check-equal? ((flow #&3) 2) #&3 "literal box") + (check-equal? ((flow #&(1 2 3)) 2) #&(1 2 3) "literal collection in a box") (check-equal? ((flow '(+ 1 2)) 5) '(+ 1 2) "literal quoted list") (check-equal? ((flow `(+ 1 ,(* 2 3))) 5) '(+ 1 6) "literal quasiquoted list") (check-equal? (syntax->datum ((flow #'(+ 1 2)) 5)) '(+ 1 2) "Literal syntax quoted list")) From ffc60be1d31d12c242d7593fd72b83caba973660 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 9 Dec 2022 19:24:39 -0800 Subject: [PATCH 091/338] formatting.. --- qi-lib/flow/aux-syntax.rkt | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index df8443c95..072c365d8 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -33,24 +33,22 @@ (define-syntax-class subject #:attributes (args arity) - (pattern - (arg:expr ...) - #:with args #'(arg ...) - #:attr arity (length (syntax->list #'args)))) + (pattern (arg:expr ...) + #:with args #'(arg ...) + #:attr arity (length (syntax->list #'args)))) (define-syntax-class clause - (pattern - expr:expr)) + (pattern expr:expr)) (define-syntax-class vector-literal - (pattern - #(_ ...))) + (pattern #(_ ...))) (define-syntax-class box-literal (pattern #&v)) (define-syntax-class (starts-with pfx) - (pattern - i:id #:when (string-prefix? (symbol->string - (syntax-e #'i)) pfx))) - + (pattern i:id + #:when (string-prefix? + (symbol->string + (syntax-e #'i)) + pfx))) From 81c2278012ae3296f674bc604e9623dc0a26865f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 12 Dec 2022 12:21:02 -0800 Subject: [PATCH 092/338] support prefab literals --- qi-lib/flow/aux-syntax.rkt | 5 +++++ qi-test/tests/flow.rkt | 1 + 2 files changed, 6 insertions(+) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index 072c365d8..c91512454 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -20,6 +20,7 @@ expr:byte-regexp expr:vector-literal expr:box-literal + expr:prefab-literal ;; We'd like to treat quoted forms as literals as well. This ;; includes symbols, and would also include, for instance, ;; syntactic specifications of flows, since flows are @@ -46,6 +47,10 @@ (define-syntax-class box-literal (pattern #&v)) +(define-syntax-class prefab-literal + (pattern e:expr + #:when (prefab-struct-key (syntax-e #'e)))) + (define-syntax-class (starts-with pfx) (pattern i:id #:when (string-prefix? diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index bbe9231d3..593f178ac 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -61,6 +61,7 @@ (check-equal? ((flow #(1 2 3)) 2) #(1 2 3) "literal vector") (check-equal? ((flow #&3) 2) #&3 "literal box") (check-equal? ((flow #&(1 2 3)) 2) #&(1 2 3) "literal collection in a box") + (check-equal? ((flow #s(dog "Fido")) 2) #s(dog "Fido") "literal prefab") (check-equal? ((flow '(+ 1 2)) 5) '(+ 1 2) "literal quoted list") (check-equal? ((flow `(+ 1 ,(* 2 3))) 5) '(+ 1 6) "literal quasiquoted list") (check-equal? (syntax->datum ((flow #'(+ 1 2)) 5)) '(+ 1 2) "Literal syntax quoted list")) From 6a2139f58fca27214359c42f2221c4ca7d6b37a3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 12 Dec 2022 17:57:22 -0800 Subject: [PATCH 093/338] more tests for bindings --- qi-test/tests/flow.rkt | 50 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 49 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 593f178ac..9f6f1dfca 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -10,6 +10,7 @@ racket/list racket/string racket/function + racket/format (except-in "private/util.rkt" add-two) syntax/macro-testing) @@ -353,18 +354,65 @@ (check-equal? ((☯ (~> (as v) (+ v))) 3) 3 "binds a single value") + (check-false ((☯ (~> (as v) live?)) 3) + "binding does not propagate the value") (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) 7 "binds multiple values") + (check-equal? ((☯ (~> (-< (~> list (as vs)) + +) + (~a "The sum of " vs " is " _))) + 1 2) + "The sum of (1 2) is 3" + "bindings are scoped to the outermost threading form") + (check-equal? ((☯ (~> (-< _ (~> list (as S))) + (-< sqr (~>> list (append S) (as S))) + (-< add1 (~>> list (append S) (as S))) + (list S))) + 5) + (list 26 (list 5 25 26)) + "binding to accumulate state") + (check-equal? ((☯ (~> (ε (as args)) (append args))) + (list 1 2 3)) + (list 1 2 3 1 2 3) + "idiom: bind as a side effect") + (check-equal? ((☯ (~> (ε (as args)) (append args))) + (list 1 2 3)) + (list 1 2 3 1 2 3) + "idiom: bind as a side effect") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (as n) 5 (feedback n add1))) + 3))) + "using a bound value in a flow specification is an error") + (check-equal? ((☯ (~> (== (as n) _) sqr (+ n))) + 3 5) + 8 + "binding some but not all values using a relay") (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> list (-< vs (as vs))))))) "using `as` outside a threading form is an error") - ;; convert-compile-time-error (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> sqr (list v) (as v) (gen v))) 3))) "bindings cannot be referenced before being assigned") + (check-equal? ((☯ (~> (-< (as v) + (gen v)))) + 3) + 3 + "tee junction tines bind succeeding peers") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (or (ε (as v)) 5) (+ v))) + 3))) + "error is raised if identifier is not guaranteed to be bound downstream") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (-< (gen v) + (as v)))) + 3))) + "tee junction tines don't bind preceding peers") (let ([as (lambda (v) v)]) (check-equal? ((☯ (~> (gen (as 3))))) 3) (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3))) From a204f9b2f6f18f921bbbffba08a93f3848377073 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 12 Dec 2022 18:07:26 -0800 Subject: [PATCH 094/338] minor cleanup and notes --- qi-test/tests/flow.rkt | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 9f6f1dfca..3f2ad988f 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -376,19 +376,17 @@ (list 1 2 3)) (list 1 2 3 1 2 3) "idiom: bind as a side effect") - (check-equal? ((☯ (~> (ε (as args)) (append args))) - (list 1 2 3)) - (list 1 2 3 1 2 3) - "idiom: bind as a side effect") (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> (as n) 5 (feedback n add1))) 3))) + ;; TODO: discuss this "using a bound value in a flow specification is an error") (check-equal? ((☯ (~> (== (as n) _) sqr (+ n))) 3 5) 8 "binding some but not all values using a relay") + ;; TODO: remove / fix (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> list (-< vs (as vs))))))) @@ -402,17 +400,17 @@ 3) 3 "tee junction tines bind succeeding peers") - (check-exn exn:fail? - (thunk (convert-compile-time-error - ((☯ (~> (or (ε (as v)) 5) (+ v))) - 3))) - "error is raised if identifier is not guaranteed to be bound downstream") (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> (-< (gen v) (as v)))) 3))) "tee junction tines don't bind preceding peers") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (or (ε (as v)) 5) (+ v))) + 3))) + "error is raised if identifier is not guaranteed to be bound downstream") (let ([as (lambda (v) v)]) (check-equal? ((☯ (~> (gen (as 3))))) 3) (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3))) From 195e03ab379ef5ebe3de939f59c1c1a8834d733a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 14 Dec 2022 14:19:17 -0800 Subject: [PATCH 095/338] lint and reorder some subforms --- qi-lib/flow/extended/expander.rkt | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 86554c3ce..0f1cd1178 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -32,17 +32,6 @@ f:threading-floe #:binding (nest-one f [])) - (nonterminal/nesting binding-floe (nested) - #:description "a flow expression" - #:allow-extension qi-macro - #:binding-space qi - - (as v:racket-var ...+) - #:binding {(bind v) nested} - - f:threading-floe - #:binding (nest-one f nested)) - (nonterminal/nesting threading-floe (nested) #:description "a flow expression" #:allow-extension qi-macro @@ -61,7 +50,18 @@ ;; Note: this could be at the top level floe after ;; binding-floe, but that isnt supported atm because ;; it doesn't backtrack - f:simple-floe) + _:simple-floe) + + (nonterminal/nesting binding-floe (nested) + #:description "a flow expression" + #:allow-extension qi-macro + #:binding-space qi + + (as v:racket-var ...+) + #:binding {(bind v) nested} + + f:threading-floe + #:binding (nest-one f nested)) (nonterminal simple-floe #:description "a flow expression" From fe3c24ab01da7daebec0f321d0b6a6b15059e9d2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 14 Dec 2022 18:51:19 -0800 Subject: [PATCH 096/338] remove rule restricting bindings to ~> directly --- qi-lib/flow/extended/expander.rkt | 4 ---- qi-test/tests/flow.rkt | 5 ----- 2 files changed, 9 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 0f1cd1178..d1f839224 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -37,10 +37,6 @@ #:allow-extension qi-macro #:binding-space qi - (~> ((~literal as) v:id ...+) - (report-syntax-error this-syntax - "(as ...) may only be used inside ~>")) - (thread f:binding-floe ...) #:binding (nest f nested) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 3f2ad988f..e72067363 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -386,11 +386,6 @@ 3 5) 8 "binding some but not all values using a relay") - ;; TODO: remove / fix - (check-exn exn:fail? - (thunk (convert-compile-time-error - ((☯ (~> list (-< vs (as vs))))))) - "using `as` outside a threading form is an error") (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> sqr (list v) (as v) (gen v))) 3))) From 880aeca1d563bf263b18382141614fc96ed7b4f4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 14 Dec 2022 20:28:00 -0800 Subject: [PATCH 097/338] formatting --- qi-lib/flow.rkt | 8 ++++---- qi-lib/flow/extended/expander.rkt | 17 ++++++++--------- qi-lib/threading.rkt | 12 ++++++------ qi-test/tests/util.rkt | 8 ++++---- 4 files changed, 22 insertions(+), 23 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index 694a24012..a6b20690b 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -42,7 +42,7 @@ in the flow macro. ;; error handling catch-all [(expr0 expr ...+) (report-syntax-error - (datum->syntax this-syntax - (cons 'flow (syntax->list this-syntax))) - "(flow flo)" - "flow expects a single flow specification, but it received many.")]))) + (datum->syntax this-syntax + (cons 'flow (syntax->list this-syntax))) + "(flow flo)" + "flow expects a single flow specification, but it received many.")]))) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index d1f839224..5b074bd1f 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -83,10 +83,9 @@ (~>/form (amp f0:clause f:clause ...) ;; potentially pull out as a phase 1 function ;; just a stopgap until better error messages - (report-syntax-error - this-syntax - "(>< flo)" - "amp expects a single flow specification, but it received many.")) + (report-syntax-error this-syntax + "(>< flo)" + "amp expects a single flow specification, but it received many.")) pass (pass f:floe) sep @@ -102,17 +101,17 @@ (select n:number ...) (~>/form (select arg ...) (report-syntax-error this-syntax - "(select ...)")) + "(select ...)")) (block n:number ...) (~>/form (block arg ...) (report-syntax-error this-syntax - "(block ...)")) + "(block ...)")) (group n:expr e1:floe e2:floe) #:binding (host n) group (~>/form (group arg ...) (report-syntax-error this-syntax - "(group )")) + "(group )")) (if consequent:floe alternative:floe) (if condition:floe @@ -124,13 +123,13 @@ sieve (~>/form (sieve arg ...) (report-syntax-error this-syntax - "(sieve )")) + "(sieve )")) (try flo:floe [error-condition-flo:floe error-handler-flo:floe] ...+) (~>/form (try arg ...) (report-syntax-error this-syntax - "(try [error-predicate-flo error-handler-flo] ...)")) + "(try [error-predicate-flo error-handler-flo] ...)")) >> (>> fn:floe init:floe) (>> fn:floe) diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 88874b764..64ae273af 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -19,9 +19,9 @@ [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error this-syntax - "(~> (arg ...) flo ...)" - "Attempted to separate multiple values." - "Note that the inputs to ~> must be wrapped in parentheses.")] + "(~> (arg ...) flo ...)" + "Attempted to separate multiple values." + "Note that the inputs to ~> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) #'(on ags (~> clause ...))]) @@ -30,9 +30,9 @@ [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error this-syntax - "(~>> (arg ...) flo ...)" - "Attempted to separate multiple values." - "Note that the inputs to ~>> must be wrapped in parentheses.")] + "(~>> (arg ...) flo ...)" + "Attempted to separate multiple values." + "Note that the inputs to ~>> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) #'(on ags (~>> clause ...))]) diff --git a/qi-test/tests/util.rkt b/qi-test/tests/util.rkt index ffa87a15f..9e0510a9c 100644 --- a/qi-test/tests/util.rkt +++ b/qi-test/tests/util.rkt @@ -15,10 +15,10 @@ "report-syntax-error" (check-exn exn:fail:syntax? (thunk (report-syntax-error #'(dummy 1 2 3) - "blah: blah" - "Use it" - "like" - "this")))))) + "blah: blah" + "Use it" + "like" + "this")))))) (module+ main (void (run-tests tests))) From 9402730b8cb850eadbb089907b0f84cc0c7911b4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Dec 2022 00:27:40 -0800 Subject: [PATCH 098/338] add descriptions to a couple of tests --- qi-test/tests/flow.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index e72067363..5d6ba5c39 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -407,8 +407,8 @@ 3))) "error is raised if identifier is not guaranteed to be bound downstream") (let ([as (lambda (v) v)]) - (check-equal? ((☯ (~> (gen (as 3))))) 3) - (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3))) + (check-equal? ((☯ (~> (gen (as 3))))) 3 "Racket functions named `as` aren't clobbered") + (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3 "Racket functions named `as` aren't clobbered"))) (test-suite "routing forms" From ef053f336e247535a19ea6add4e731bfa6e8690b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Dec 2022 11:49:45 -0800 Subject: [PATCH 099/338] fix bindings tests --- qi-test/tests/flow.rkt | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 5d6ba5c39..e0880ae0c 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -365,9 +365,9 @@ 1 2) "The sum of (1 2) is 3" "bindings are scoped to the outermost threading form") - (check-equal? ((☯ (~> (-< _ (~> list (as S))) - (-< sqr (~>> list (append S) (as S))) + (check-equal? ((☯ (~> (-< sqr (~> list (as S))) (-< add1 (~>> list (append S) (as S))) + (-< _ (~>> list (append S) (as S))) (list S))) 5) (list 26 (list 5 25 26)) @@ -376,15 +376,13 @@ (list 1 2 3)) (list 1 2 3 1 2 3) "idiom: bind as a side effect") - (check-exn exn:fail? - (thunk (convert-compile-time-error - ((☯ (~> (as n) 5 (feedback n add1))) - 3))) - ;; TODO: discuss this - "using a bound value in a flow specification is an error") + (check-equal? ((☯ (~> (as n) 5 (feedback n add1))) + 3) + 8 + "using a bound value in a flow specification") (check-equal? ((☯ (~> (== (as n) _) sqr (+ n))) 3 5) - 8 + 28 "binding some but not all values using a relay") (check-exn exn:fail? (thunk (convert-compile-time-error @@ -407,8 +405,12 @@ 3))) "error is raised if identifier is not guaranteed to be bound downstream") (let ([as (lambda (v) v)]) - (check-equal? ((☯ (~> (gen (as 3))))) 3 "Racket functions named `as` aren't clobbered") - (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) 3 "Racket functions named `as` aren't clobbered"))) + (check-equal? ((☯ (~> (gen (as 3))))) + 3 + "Racket functions named `as` aren't clobbered") + (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) + 3 + "Racket functions named `as` aren't clobbered"))) (test-suite "routing forms" From a71c71bebf04ebe3987f0176e9c132b039525993 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Dec 2022 11:50:01 -0800 Subject: [PATCH 100/338] Fix feedback implementation to be able to use a binding This is the same issue as we were seeing with partial application's use of the `curry` form in its implementation, which required that the arguments be available at compile time. We fixed it in the same way, by wrapping the implementation in a lambda that accepts the runtime arguments, allowing the use of bound identifiers in the feedback specification. --- qi-lib/flow/core/compiler.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 29026b866..354542630 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -340,7 +340,9 @@ the DSL. [(_ n:expr ((~datum then) thenex:clause) onex:clause) - #'(feedback-times (qi0->racket onex) n (qi0->racket thenex))] + #'(lambda args + (apply (feedback-times (qi0->racket onex) n (qi0->racket thenex)) + args))] [(_ n:expr ((~datum then) thenex:clause)) #'(λ (f . args) From 231426579e8c19cd014dd6986f68d35b6afc3ba8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Dec 2022 11:57:46 -0800 Subject: [PATCH 101/338] reorder nonterminals in order of fallbacks --- qi-lib/flow/extended/expander.rkt | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 5b074bd1f..e9215a01e 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -32,6 +32,17 @@ f:threading-floe #:binding (nest-one f [])) + (nonterminal/nesting binding-floe (nested) + #:description "a flow expression" + #:allow-extension qi-macro + #:binding-space qi + + (as v:racket-var ...+) + #:binding {(bind v) nested} + + f:threading-floe + #:binding (nest-one f nested)) + (nonterminal/nesting threading-floe (nested) #:description "a flow expression" #:allow-extension qi-macro @@ -48,17 +59,6 @@ ;; it doesn't backtrack _:simple-floe) - (nonterminal/nesting binding-floe (nested) - #:description "a flow expression" - #:allow-extension qi-macro - #:binding-space qi - - (as v:racket-var ...+) - #:binding {(bind v) nested} - - f:threading-floe - #:binding (nest-one f nested)) - (nonterminal simple-floe #:description "a flow expression" #:binding-space qi From f575f30669436c5b4afec1869a7c26be8f9a5e1d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Dec 2022 11:58:10 -0800 Subject: [PATCH 102/338] allow bindings to escape tee junctions --- qi-lib/flow/extended/expander.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index e9215a01e..2ff7d0c18 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -51,6 +51,11 @@ (thread f:binding-floe ...) #:binding (nest f nested) + (tee f:binding-floe ...) + #:binding (nest f nested) + tee + ;; Note: `#:binding nested` is the implicit binding rule here + ;; [f nested] is the implicit binding rule ;; anything not mentioned (e.g. nested) is treated as a ;; subexpression that's not in any scope @@ -76,8 +81,6 @@ ground (relay f:floe ...) relay - (tee f:floe ...) - tee amp (amp f:floe) (~>/form (amp f0:clause f:clause ...) From 7cc3baac9c4b67f7b532da4f38a443fa09fca6c1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Dec 2022 11:58:39 -0800 Subject: [PATCH 103/338] allow bindings to escape relays --- qi-lib/flow/extended/expander.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 2ff7d0c18..e0d09d286 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -56,6 +56,10 @@ tee ;; Note: `#:binding nested` is the implicit binding rule here + (relay f:binding-floe ...) + #:binding (nest f nested) + relay + ;; [f nested] is the implicit binding rule ;; anything not mentioned (e.g. nested) is treated as a ;; subexpression that's not in any scope @@ -79,8 +83,6 @@ (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) _ ground - (relay f:floe ...) - relay amp (amp f:floe) (~>/form (amp f0:clause f:clause ...) From e89b49902420eb42078980c16a01dba4a767a04f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Dec 2022 15:59:36 -0800 Subject: [PATCH 104/338] add another test --- qi-test/tests/flow.rkt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index e0880ae0c..d9875b610 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -384,6 +384,10 @@ 3 5) 28 "binding some but not all values using a relay") + (check-equal? (map (☯ (~> (as n) (+ n n))) + (list 1 3 5)) + (list 2 6 10) + "binding arguments without a lambda") (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> sqr (list v) (as v) (gen v))) 3))) From ee8d40501954d50c5f245335550520b0c2ee5b60 Mon Sep 17 00:00:00 2001 From: Michael Ballantyne Date: Tue, 3 Jan 2023 23:37:31 -0700 Subject: [PATCH 105/338] use new syntax-spec racket-expr feature --- qi-lib/flow/extended/expander.rkt | 21 +++++++-------------- 1 file changed, 7 insertions(+), 14 deletions(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index e0d09d286..dee7f0821 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -72,8 +72,7 @@ #:description "a flow expression" #:binding-space qi - (gen e:expr ...) - #:binding (host e) + (gen e:racket-expr ...) ;; Ad hoc expansion rule to allow _ to be used in application ;; position in a template. ;; Without it, (_ v ...) would be treated as an error since @@ -111,8 +110,7 @@ (~>/form (block arg ...) (report-syntax-error this-syntax "(block ...)")) - (group n:expr e1:floe e2:floe) - #:binding (host n) + (group n:racket-expr e1:floe e2:floe) group (~>/form (group arg ...) (report-syntax-error this-syntax @@ -148,15 +146,12 @@ ((~datum then) thenex:floe)) (feedback ((~datum while) tilex:floe) onex:floe) (feedback ((~datum while) tilex:floe)) - (feedback n:expr + (feedback n:racket-expr ((~datum then) thenex:floe) onex:floe) - #:binding (host n) - (feedback n:expr + (feedback n:racket-expr ((~datum then) thenex:floe)) - #:binding (host n) - (feedback n:expr onex:floe) - #:binding (host n) + (feedback n:racket-expr onex:floe) (feedback onex:floe) feedback (loop pred:floe mapex:floe combex:floe retex:floe) @@ -169,8 +164,7 @@ (~> (~literal apply) #'appleye) clos (clos onex:floe) - (esc ex:expr) - #:binding (host ex) + (esc ex:racket-expr) ;; backwards compat macro extensibility via Racket macros (~> ((~var ext-form (starts-with "qi:")) expr ...) @@ -209,5 +203,4 @@ (~datum __) k:keyword - e:expr - #:binding (host e))) + e:racket-expr)) From a066ab9369e4a3ef792ae514bde239803928a3b8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 29 Dec 2022 01:36:12 -0800 Subject: [PATCH 106/338] script to measure form performance regressions --- qi-sdk/perf-regression.rkt | 55 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100755 qi-sdk/perf-regression.rkt diff --git a/qi-sdk/perf-regression.rkt b/qi-sdk/perf-regression.rkt new file mode 100755 index 000000000..098ad09db --- /dev/null +++ b/qi-sdk/perf-regression.rkt @@ -0,0 +1,55 @@ +#!/usr/bin/env racket +#lang cli + +(require qi + qi/probe) + +(require relation + json + racket/format + racket/port) + +(define (parse-json-file filename) + (call-with-input-file filename + (λ (port) + (read-json port)))) + +(help + (usage (~a "Reports relative performance of forms between two sets of results\n" + "(e.g. run against two different commits)."))) + +(program (main [before-file "'before' file"] [after-file "'after' file"]) + (define before + (make-hash + (map (☯ (~> (-< (hash-ref 'name) + (hash-ref 'value)) cons)) + (parse-json-file before-file)))) + (define after + (make-hash + (map (☯ (~> (-< (~> (hash-ref 'name) + (switch + [(equal? "foldr") "<<"] + [(equal? "foldl") ">>"] + [else _])) + (hash-ref 'value)) cons)) + (parse-json-file after-file)))) + (define results + (~>> (before) + hash-keys + △ + (>< + (~> + (-< _ + (~> (-< (hash-ref after _) + (hash-ref before _)) + / + (if (< 0.75 _ 1.5) + 1 + (~r #:precision 2)))) + ▽)) + ▽ + (sort > #:key (☯ (~> cadr ->inexact))))) + ;; (write-json results) + (println results)) + +(run main) From d0ddab39ef1f4dde4853dc93bfc1b0c13cbbc51c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 29 Dec 2022 01:52:12 -0800 Subject: [PATCH 107/338] define threshold values as constants --- qi-sdk/perf-regression.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/qi-sdk/perf-regression.rkt b/qi-sdk/perf-regression.rkt index 098ad09db..ca4a05f0d 100755 --- a/qi-sdk/perf-regression.rkt +++ b/qi-sdk/perf-regression.rkt @@ -9,6 +9,9 @@ racket/format racket/port) +(define LOWER-THRESHOLD 0.75) +(define HIGHER-THRESHOLD 1.5) + (define (parse-json-file filename) (call-with-input-file filename (λ (port) @@ -43,7 +46,7 @@ (~> (-< (hash-ref after _) (hash-ref before _)) / - (if (< 0.75 _ 1.5) + (if (< LOWER-THRESHOLD _ HIGHER-THRESHOLD) 1 (~r #:precision 2)))) ▽)) From b67d40a9ea151560a756d9a5e03aa1d2f2ca0aa6 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 29 Dec 2022 11:28:50 -0800 Subject: [PATCH 108/338] put performance regression script in profile folder --- qi-sdk/{perf-regression.rkt => profile/regression.rkt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename qi-sdk/{perf-regression.rkt => profile/regression.rkt} (100%) diff --git a/qi-sdk/perf-regression.rkt b/qi-sdk/profile/regression.rkt similarity index 100% rename from qi-sdk/perf-regression.rkt rename to qi-sdk/profile/regression.rkt From 529457262e8d4f83d2ad984f20d8f1878b397568 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 29 Dec 2022 12:29:58 -0800 Subject: [PATCH 109/338] fix SDK makefile targets --- Makefile | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 6f620b06a..db2de22b7 100644 --- a/Makefile +++ b/Makefile @@ -82,6 +82,9 @@ build-standalone-docs: clean: raco setup --fast-clean --pkgs $(PACKAGE-NAME)-{lib,test,doc,probe} +clean-sdk: + raco setup --fast-clean --pkgs $(PACKAGE-NAME)-sdk + # Primarily for use by CI, after make install -- since that already # does the equivalent of make setup, this tries to do as little as # possible except checking deps. @@ -164,7 +167,7 @@ profile-forms: racket $(PACKAGE-NAME)-sdk/profile/forms.rkt profile-selected-forms: - @echo "Use 'racket profile/forms.rkt' directly, with -f form-name for each form." + @echo "Use 'racket qi-sdk/profile/forms.rkt' directly, with -f form-name for each form." profile-competitive: echo "Running competitive benchmarks..." From 812ebb5c6b861e8a3d78857d1cee3adb7ac3a262 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 2 Jan 2023 16:33:02 -0800 Subject: [PATCH 110/338] improvements in performance regression script --- qi-sdk/profile/regression.rkt | 48 ++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 21 deletions(-) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index ca4a05f0d..78f3447b0 100755 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -21,21 +21,32 @@ (usage (~a "Reports relative performance of forms between two sets of results\n" "(e.g. run against two different commits)."))) -(program (main [before-file "'before' file"] [after-file "'after' file"]) - (define before - (make-hash - (map (☯ (~> (-< (hash-ref 'name) - (hash-ref 'value)) cons)) - (parse-json-file before-file)))) - (define after - (make-hash - (map (☯ (~> (-< (~> (hash-ref 'name) - (switch - [(equal? "foldr") "<<"] - [(equal? "foldl") ">>"] - [else _])) - (hash-ref 'value)) cons)) - (parse-json-file after-file)))) +(define (parse-benchmarks filename) + (make-hash + (map (☯ (~> (-< (~> (hash-ref 'name) + (switch + [(equal? "foldr") "<<"] ; these were renamed at some point + [(equal? "foldl") ">>"] ; so rename them back to match them + [else _])) + (hash-ref 'value)) + cons)) + (parse-json-file filename)))) + +(program (main [before-file "'before' file"] + [after-file "'after' file"]) + ;; before and after are expected to be JSON-formatted, as + ;; generated by report.rkt (e.g. via `make benchmarks-report`) + (define before (parse-benchmarks before-file)) + (define after (parse-benchmarks after-file)) + + (define-flow calculate-ratio + (~> (-< (hash-ref after _) + (hash-ref before _)) + / + (if (< LOWER-THRESHOLD _ HIGHER-THRESHOLD) + 1 + (~r #:precision 2)))) + (define results (~>> (before) hash-keys @@ -43,12 +54,7 @@ (>< (~> (-< _ - (~> (-< (hash-ref after _) - (hash-ref before _)) - / - (if (< LOWER-THRESHOLD _ HIGHER-THRESHOLD) - 1 - (~r #:precision 2)))) + calculate-ratio) ▽)) ▽ (sort > #:key (☯ (~> cadr ->inexact))))) From 620632cc3d03938bed8ec29c9164feb638ed8bfd Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 12:45:23 -0800 Subject: [PATCH 111/338] rename a makefile target for clarity --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index db2de22b7..b530c6c0d 100644 --- a/Makefile +++ b/Makefile @@ -175,7 +175,7 @@ profile-competitive: profile: profile-competitive profile-forms -report-benchmarks: +form-performance-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile report-benchmarks +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile form-performance-report From fa76571a681d513deee0a341e5dcef1f07648d7b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 12:54:26 -0800 Subject: [PATCH 112/338] make some scripts locally executable --- qi-sdk/profile/competitive.rkt | 1 + qi-sdk/profile/forms.rkt | 1 + qi-sdk/profile/report.rkt | 1 + 3 files changed, 3 insertions(+) mode change 100644 => 100755 qi-sdk/profile/competitive.rkt mode change 100644 => 100755 qi-sdk/profile/forms.rkt mode change 100644 => 100755 qi-sdk/profile/report.rkt diff --git a/qi-sdk/profile/competitive.rkt b/qi-sdk/profile/competitive.rkt old mode 100644 new mode 100755 index 3fde6766a..833e5bf80 --- a/qi-sdk/profile/competitive.rkt +++ b/qi-sdk/profile/competitive.rkt @@ -1,3 +1,4 @@ +#!/usr/bin/env racket #lang racket/base (require (only-in data/collection diff --git a/qi-sdk/profile/forms.rkt b/qi-sdk/profile/forms.rkt old mode 100644 new mode 100755 index 8add47ff0..bcd39cb9f --- a/qi-sdk/profile/forms.rkt +++ b/qi-sdk/profile/forms.rkt @@ -1,3 +1,4 @@ +#!/usr/bin/env racket #lang racket/base #| diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt old mode 100644 new mode 100755 index decf6e1a3..4cc86c0a7 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -1,3 +1,4 @@ +#!/usr/bin/env racket #lang cli (require From 00bde759fbe1a998dc5a8c93a57b9d3f6f69662f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 13:07:44 -0800 Subject: [PATCH 113/338] add help text for the performance scripts --- qi-sdk/profile/forms.rkt | 4 ++++ qi-sdk/profile/regression.rkt | 8 ++++---- qi-sdk/profile/report.rkt | 4 ++++ 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/qi-sdk/profile/forms.rkt b/qi-sdk/profile/forms.rkt index bcd39cb9f..ecad648c6 100755 --- a/qi-sdk/profile/forms.rkt +++ b/qi-sdk/profile/forms.rkt @@ -1038,6 +1038,10 @@ for the forms are run. (constraint (multi forms)) + (help + (usage (~a "Run benchmarks for individual Qi forms " + "(by default, all of them)."))) + (program (main) (let ([fs (~>> ((forms)) (only-if null? diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index 78f3447b0..91f811f00 100755 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -17,10 +17,6 @@ (λ (port) (read-json port)))) -(help - (usage (~a "Reports relative performance of forms between two sets of results\n" - "(e.g. run against two different commits)."))) - (define (parse-benchmarks filename) (make-hash (map (☯ (~> (-< (~> (hash-ref 'name) @@ -32,6 +28,10 @@ cons)) (parse-json-file filename)))) +(help + (usage (~a "Report relative performance of forms between two sets of results\n" + "(e.g. run against two different commits)."))) + (program (main [before-file "'before' file"] [after-file "'after' file"]) ;; before and after are expected to be JSON-formatted, as diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 4cc86c0a7..d3fa1b233 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -145,6 +145,10 @@ "apply" apply:run "clos" clos:run)) +(help + (usage (~a "Report on the performance of all of the forms " + "of the language, in JSON format."))) + (program (main) ;; TODO: could use try-order? with hash-keys if support is dropped for Racket 8.3 (define fs (~>> (env) hash-keys (sort <))) From c5b6e687a69f1aa326d7d392a4b28541fd0ea1dd Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 13:42:37 -0800 Subject: [PATCH 114/338] support csv output format in form performance report --- qi-sdk/info.rkt | 1 + qi-sdk/profile/report.rkt | 26 +++++++++++++++++++++++++- 2 files changed, 26 insertions(+), 1 deletion(-) diff --git a/qi-sdk/info.rkt b/qi-sdk/info.rkt index 8ee90a5ea..b79b9ef6c 100644 --- a/qi-sdk/info.rkt +++ b/qi-sdk/info.rkt @@ -9,6 +9,7 @@ "math-lib" "collections-lib" "relation-lib" + "csv-writing" "cover" "cover-coveralls")) (define build-deps '()) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index d3fa1b233..1f0158639 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -71,6 +71,7 @@ relation qi json + csv-writing (only-in "util.rkt" only-if for/call)) @@ -149,6 +150,22 @@ (usage (~a "Report on the performance of all of the forms " "of the language, in JSON format."))) +(flag (output-format #:param [output-format "json"] fmt) + ("-f" "--format" "Output format to use, either 'json' or 'csv'") + (output-format fmt)) + +(define (write-csv data) + (~> (data) + △ + (>< (~> (-< (hash-ref 'name) + (hash-ref 'unit) + (hash-ref 'value)) + ▽)) + (-< '(name unit value) + _) + ▽ + display-table)) + (program (main) ;; TODO: could use try-order? with hash-keys if support is dropped for Racket 8.3 (define fs (~>> (env) hash-keys (sort <))) @@ -158,6 +175,13 @@ (define require-data (list (hash 'name "(require qi)" 'unit "ms" 'value (time-module-ms "qi")))) - (write-json (append forms-data require-data))) + (let ([output (append forms-data require-data)]) + ;; Note: this is a case where declaring "constraints" on the CLI args + ;; would be useful, instead of using the ad hoc fallback `else` check here + ;; https://github.com/countvajhula/cli/issues/6 + (cond + [(equal? (output-format) "json") (write-json output)] + [(equal? (output-format) "csv") (write-csv output)] + [else (error "Unrecognized format!")]))) (run main) From 77919229cab29bf908db6ffc42e81c1b22de1c33 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 13:48:25 -0800 Subject: [PATCH 115/338] address todo re: try-order --- qi-sdk/profile/report.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 1f0158639..5ee2a63f1 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -167,8 +167,7 @@ display-table)) (program (main) - ;; TODO: could use try-order? with hash-keys if support is dropped for Racket 8.3 - (define fs (~>> (env) hash-keys (sort <))) + (define fs (hash-keys env #t)) (define forms-data (for/list ([f (in-list fs)]) (match-let ([(list name ms) ((hash-ref env f))]) (hash 'name name 'unit "ms" 'value ms)))) From 83760e911d5bc08026c4d55d8f2287d4497936f1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 14:06:56 -0800 Subject: [PATCH 116/338] remove commented code --- qi-sdk/profile/regression.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index 91f811f00..e7e48ff06 100755 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -58,7 +58,6 @@ ▽)) ▽ (sort > #:key (☯ (~> cadr ->inexact))))) - ;; (write-json results) (println results)) (run main) From 5ac618d820ea6f8fe75a7ed0b45e6e2e2adf4c36 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 14:16:40 -0800 Subject: [PATCH 117/338] improve error on unrecognized format --- qi-sdk/profile/report.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 5ee2a63f1..b8be27331 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -181,6 +181,6 @@ (cond [(equal? (output-format) "json") (write-json output)] [(equal? (output-format) "csv") (write-csv output)] - [else (error "Unrecognized format!")]))) + [else (error (~a "Unrecognized format: " (output-format) "!"))]))) (run main) From 006c0d174fe2db1c0aac6e1a44c159301d7eaaeb Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 14:30:31 -0800 Subject: [PATCH 118/338] use PACKAGE-NAME variable in makefile targets --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index b530c6c0d..c42ddced7 100644 --- a/Makefile +++ b/Makefile @@ -167,7 +167,7 @@ profile-forms: racket $(PACKAGE-NAME)-sdk/profile/forms.rkt profile-selected-forms: - @echo "Use 'racket qi-sdk/profile/forms.rkt' directly, with -f form-name for each form." + @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/forms.rkt' directly, with -f form-name for each form." profile-competitive: echo "Running competitive benchmarks..." From 3418505a43fa8f6289790e806ab9eedeb321e8fd Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 14:51:48 -0800 Subject: [PATCH 119/338] update help message --- qi-sdk/profile/report.rkt | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index b8be27331..86d333906 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -146,14 +146,6 @@ "apply" apply:run "clos" clos:run)) -(help - (usage (~a "Report on the performance of all of the forms " - "of the language, in JSON format."))) - -(flag (output-format #:param [output-format "json"] fmt) - ("-f" "--format" "Output format to use, either 'json' or 'csv'") - (output-format fmt)) - (define (write-csv data) (~> (data) △ @@ -166,6 +158,14 @@ ▽ display-table)) +(help + (usage (~a "Report on the performance of all of the forms " + "of the language, in a configurable output format."))) + +(flag (output-format #:param [output-format "json"] fmt) + ("-f" "--format" "Output format to use, either 'json' or 'csv'") + (output-format fmt)) + (program (main) (define fs (hash-keys env #t)) (define forms-data (for/list ([f (in-list fs)]) From dafb6a06a76ac902c3a30e05c719cff22cf55607 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 7 Jan 2023 14:52:02 -0800 Subject: [PATCH 120/338] update references to makefile target --- .github/workflows/benchmarks.yml | 2 +- Makefile | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/benchmarks.yml b/.github/workflows/benchmarks.yml index d3db3cd7c..f9974993e 100644 --- a/.github/workflows/benchmarks.yml +++ b/.github/workflows/benchmarks.yml @@ -25,7 +25,7 @@ jobs: run: make install-sdk - name: Run benchmark shell: 'bash --noprofile --norc -eo pipefail {0}' - run: make report-benchmarks | tee benchmarks.txt + run: make form-performance-report | tee benchmarks.txt - name: Store benchmark result uses: benchmark-action/github-action-benchmark@v1 with: diff --git a/Makefile b/Makefile index c42ddced7..389a08d99 100644 --- a/Makefile +++ b/Makefile @@ -39,7 +39,7 @@ help: @echo "profile-competitive - Run competitive benchmarks" @echo "profile-forms - Run benchmarks for individual Qi forms" @echo "profile-selected-forms - Run benchmarks for Qi forms by name (command only)" - @echo "report-benchmarks - Run benchmarks for Qi forms and produce results for use in CI" + @echo "form-performance-report - Run benchmarks for Qi forms and produce results for use in CI" # Primarily for use by CI. # Installs dependencies as well as linking this as a package. From 25b67ae5b9440bbc2275953c2f1bb3fac4929dd5 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 12 Jan 2023 13:14:45 -0800 Subject: [PATCH 121/338] improve amp performance --- qi-lib/flow/core/compiler.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 354542630..04b51637f 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -383,7 +383,9 @@ the DSL. [_:id #'(qi0->racket ==)] [(_ onex:clause) - #'(qi0->racket (loop onex))])) + #'(qi0->racket + (#%blanket-template + (map-values (qi0->racket onex) __)))])) (define (pass-parser stx) (syntax-parse stx From 24648e6e67dbc3cdfad3e8c7c9daa40e5b0ba7df Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 12 Jan 2023 13:17:02 -0800 Subject: [PATCH 122/338] try restoring original amp implementation --- qi-lib/flow/core/compiler.rkt | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 04b51637f..ce3a2026b 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -383,9 +383,7 @@ the DSL. [_:id #'(qi0->racket ==)] [(_ onex:clause) - #'(qi0->racket - (#%blanket-template - (map-values (qi0->racket onex) __)))])) + #'(curry map-values (qi0->racket onex))])) (define (pass-parser stx) (syntax-parse stx From 2cc0186ab82981778bc89fb872e6ed0c86d38549 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 12 Jan 2023 14:19:20 -0800 Subject: [PATCH 123/338] add a test for loop with multi-valued map flow --- qi-test/tests/flow.rkt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index d9875b610..5bf0f00fd 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1355,6 +1355,12 @@ + 0))) 1 2 3) 14) + (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) + (-< sqr sqr) + + + 0))) 1 2 3) + 28 + "loop with multi-valued map flow") (check-equal? ((☯ (~> (loop sqr) ▽)) 1 2 3) (list 1 4 9)) From 5c19cfecc03c1e65ccc4b2b6932e20996c86d0e6 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 13 Jan 2023 12:57:25 -0800 Subject: [PATCH 124/338] restore `not` implementation --- qi-lib/flow/core/compiler.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index ce3a2026b..b641a3edd 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -147,7 +147,7 @@ [((~datum or) onex:clause ...) #'(disjoin (qi0->racket onex) ...)] [((~datum not) onex:clause) ; NOTE: technically not core - #'(qi0->racket (~> onex NOT))] + #'(negate (qi0->racket onex))] ;; selection [e:select-form (select-parser #'e)] [e:block-form (block-parser #'e)] From 7b4bf3158fc8f6f03867de056b33781369c6f0e7 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 13 Jan 2023 13:01:19 -0800 Subject: [PATCH 125/338] remove extraneous threading forms in some tests --- qi-test/tests/flow.rkt | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 5bf0f00fd..61385b52f 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1350,23 +1350,23 @@ sqr) ▽)) 1 2 3) (list 1 4 9)) - (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) - sqr - + - 0))) 1 2 3) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + sqr + + + 0)) 1 2 3) 14) - (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) - (-< sqr sqr) - + - 0))) 1 2 3) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + (-< sqr sqr) + + + 0)) 1 2 3) 28 "loop with multi-valued map flow") (check-equal? ((☯ (~> (loop sqr) ▽)) 1 2 3) (list 1 4 9)) - (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) - sqr - +))) 1 2 3) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + sqr + +)) 1 2 3) 14) (check-equal? ((☯ (~> (-< (gen (☯ (~> ▽ (not null?))) sqr @@ -1379,14 +1379,14 @@ "identifier form of loop")) (test-suite "loop2" - (check-equal? ((☯ (~> (loop2 (~> 1> (not null?)) - sqr - cons))) + (check-equal? ((☯ (loop2 (~> 1> (not null?)) + sqr + cons)) (list 1 2 3) null) (list 9 4 1)) - (check-equal? ((☯ (~> (loop2 (~> 1> (not null?)) - sqr - +))) + (check-equal? ((☯ (loop2 (~> 1> (not null?)) + sqr + +)) (list 1 2 3) 0) 14)) From 86ed0dc407f2d21ecc1c17a68b009dfb10a0fcb4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 01:17:04 -0800 Subject: [PATCH 126/338] incorporate regression checking into form performance report --- qi-sdk/profile/regression.rkt | 31 +++++++++++-------------------- qi-sdk/profile/report.rkt | 29 +++++++++++++++++++++-------- 2 files changed, 32 insertions(+), 28 deletions(-) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index e7e48ff06..78ca2ccdf 100755 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -1,13 +1,14 @@ #!/usr/bin/env racket -#lang cli +#lang racket/base -(require qi - qi/probe) +(provide parse-json-file + parse-benchmarks + compute-regression) -(require relation +(require qi + relation json - racket/format - racket/port) + racket/format) (define LOWER-THRESHOLD 0.75) (define HIGHER-THRESHOLD 1.5) @@ -17,7 +18,7 @@ (λ (port) (read-json port)))) -(define (parse-benchmarks filename) +(define (parse-benchmarks benchmarks) (make-hash (map (☯ (~> (-< (~> (hash-ref 'name) (switch @@ -26,18 +27,9 @@ [else _])) (hash-ref 'value)) cons)) - (parse-json-file filename)))) - -(help - (usage (~a "Report relative performance of forms between two sets of results\n" - "(e.g. run against two different commits)."))) + benchmarks))) -(program (main [before-file "'before' file"] - [after-file "'after' file"]) - ;; before and after are expected to be JSON-formatted, as - ;; generated by report.rkt (e.g. via `make benchmarks-report`) - (define before (parse-benchmarks before-file)) - (define after (parse-benchmarks after-file)) +(define (compute-regression before after) (define-flow calculate-ratio (~> (-< (hash-ref after _) @@ -58,6 +50,5 @@ ▽)) ▽ (sort > #:key (☯ (~> cadr ->inexact))))) - (println results)) -(run main) + results) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 86d333906..214b1f4d2 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -64,7 +64,8 @@ (prefix-in apply: (submod "forms.rkt" apply)) (prefix-in clos: (submod "forms.rkt" clos))) -(require "loadlib.rkt") +(require "loadlib.rkt" + "regression.rkt") (require racket/match racket/format @@ -166,6 +167,19 @@ ("-f" "--format" "Output format to use, either 'json' or 'csv'") (output-format fmt)) +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(define (format-output output) + ;; Note: this is a case where declaring "constraints" on the CLI args + ;; would be useful, instead of using the ad hoc fallback `else` check here + ;; https://github.com/countvajhula/cli/issues/6 + (cond + [(equal? (output-format) "json") (write-json output)] + [(equal? (output-format) "csv") (write-csv output)] + [else (error (~a "Unrecognized format: " (output-format) "!"))])) + (program (main) (define fs (hash-keys env #t)) (define forms-data (for/list ([f (in-list fs)]) @@ -175,12 +189,11 @@ 'unit "ms" 'value (time-module-ms "qi")))) (let ([output (append forms-data require-data)]) - ;; Note: this is a case where declaring "constraints" on the CLI args - ;; would be useful, instead of using the ad hoc fallback `else` check here - ;; https://github.com/countvajhula/cli/issues/6 - (cond - [(equal? (output-format) "json") (write-json output)] - [(equal? (output-format) "csv") (write-csv output)] - [else (error (~a "Unrecognized format: " (output-format) "!"))]))) + + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (compute-regression before after)) + (format-output output)))) (run main) From 0e7344100acd6b76dba5533f2cd5f92efb2ef4c0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 01:29:40 -0800 Subject: [PATCH 127/338] regression module doesn't need to be executable anymore --- qi-sdk/profile/regression.rkt | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 qi-sdk/profile/regression.rkt diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt old mode 100755 new mode 100644 From a25fa51293425201066163c11bc8e1c7e0693d73 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 10:26:02 -0800 Subject: [PATCH 128/338] macro to create value definitions in the qi binding space (pairing..) --- qi-lib/flow/extended/forms.rkt | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 8901b4bda..e021f5386 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -12,12 +12,24 @@ (require (for-syntax racket/base syntax/parse (only-in racket/list make-list) + syntax/parse/lib/function-header "syntax.rkt" "../aux-syntax.rkt") + syntax/parse/define "expander.rkt" "../../macro.rkt" "impl.rkt") +(define-syntax-parser define-for-qi + [(_ name:id expr:expr) + #:with spaced-name ((make-interned-syntax-introducer 'qi) #'name) + #'(define spaced-name expr)] + [(_ (name:id . args:formals) + expr:expr ...) + #'(define-for-qi name + (lambda args + expr ...))]) + ;;; Predicates (define-qi-syntax-rule (one-of? v:expr ...) From 1bec00b8ae9f101923aa84acf3ac6a34a871e025 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 10:42:00 -0800 Subject: [PATCH 129/338] Prioritize qi functions over racket functions in the expander For unadorned identifiers to be treated as function identifiers, ensure that qi functions take precedence over racket functions. This allows us to define functions that may be treated as part of the language (and not be shadowed by calling-scope identifiers) without actually being syntactically part of the language as core forms or macros. --- qi-lib/flow/extended/expander.rkt | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index dee7f0821..928a1182b 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -196,7 +196,15 @@ (~> f:partial-application-form #'(#%partial-application f)) ;; literally indicated function identifier - (~> f:id #'(esc f))) + ;; + ;; functions defined in the Qi binding space take precedence over + ;; Racket definitions here, for cases of "library functions" like + ;; `count` that we don't include in the core language but which + ;; we'd like to treat as part of the language rather than as + ;; functions which could be shadowed. + (~> f:id + #:with spaced-f ((make-interned-syntax-introducer 'qi) #'f) + #'(esc spaced-f))) (nonterminal arg-stx (~datum _) From c5266cc618ecc97ea96a9f8ffad974f9478fae59 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 10:47:33 -0800 Subject: [PATCH 130/338] define `count` and `live?` as qi functions --- qi-lib/flow/extended/forms.rkt | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index e021f5386..51850f976 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -175,11 +175,12 @@ (if onex _ ⏚)) ;;; Common utilities -(define-qi-syntax-parser count - [_:id #'(~> (>< 1) +)]) -(define-qi-syntax-parser live? - [_:id #'(~> count (> 0))]) +(define-for-qi (count . args) + (length args)) + +(define-for-qi (live? . args) + (not (null? args))) (define-qi-syntax-rule (rectify v:expr ...) (if live? _ (gen v ...))) From 22d2cee6c2898dd4944c79a353e747add3b7849f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 10:47:56 -0800 Subject: [PATCH 131/338] define `all?` and `AND` as qi functions --- qi-lib/flow/core/compiler.rkt | 2 -- qi-lib/flow/extended/expander.rkt | 1 - qi-lib/flow/extended/forms.rkt | 7 ++++--- qi-lib/flow/extended/impl.rkt | 6 +++++- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index b641a3edd..89388c3ab 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -134,8 +134,6 @@ [(~or* (~datum ▽) (~datum collect)) #'list] ;; predicates - [(~or* (~datum AND) (~datum &)) ; NOTE: technically not core - #'(qi0->racket (>> (and (select 2) (select 1)) (gen #t)))] [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core #'(qi0->racket (<< (or (select 1) (select 2)) (gen #f)))] [(~or* (~datum NOT) (~datum !)) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 928a1182b..9679db530 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -95,7 +95,6 @@ sep (sep f:floe) collect - AND OR NOT XOR diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 51850f976..b5b80a7b0 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -32,6 +32,10 @@ ;;; Predicates +(define-for-qi all? ~all?) + +(define-for-qi AND ~all?) + (define-qi-syntax-rule (one-of? v:expr ...) (~> (member (list v ...)) ->boolean)) @@ -56,9 +60,6 @@ (define-qi-syntax-parser any? [_:id #'OR]) -(define-qi-syntax-parser all? - [_:id #'AND]) - (define-qi-syntax-parser none? [_:id #'(~> any? NOT)]) diff --git a/qi-lib/flow/extended/impl.rkt b/qi-lib/flow/extended/impl.rkt index 1ea6f566a..40349af77 100644 --- a/qi-lib/flow/extended/impl.rkt +++ b/qi-lib/flow/extended/impl.rkt @@ -5,7 +5,8 @@ (provide ->boolean true. - false.) + false. + ~all?) (define (->boolean v) (and v #t)) @@ -16,3 +17,6 @@ (define false. (procedure-rename (const #f) 'false.)) + +(define (~all? . args) + (for/and ([v (in-list args)]) v)) From b96d595b47bc16d0abf22bf1e059bc12f2fd820e Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 11:05:53 -0800 Subject: [PATCH 132/338] remove unused import --- qi-lib/flow/extended/forms.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index b5b80a7b0..ee0c9a658 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -10,7 +10,6 @@ [effect ε]))) (require (for-syntax racket/base - syntax/parse (only-in racket/list make-list) syntax/parse/lib/function-header "syntax.rkt" From ce28ff8eb68b367fff754470517174f82d159834 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 26 Jan 2023 11:11:11 -0800 Subject: [PATCH 133/338] put define-for-qi in a separate module for binding space provisions --- qi-lib/flow/extended/forms.rkt | 12 +----------- qi-lib/flow/space.rkt | 17 +++++++++++++++++ 2 files changed, 18 insertions(+), 11 deletions(-) create mode 100644 qi-lib/flow/space.rkt diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index ee0c9a658..10fd0c20b 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -11,24 +11,14 @@ (require (for-syntax racket/base (only-in racket/list make-list) - syntax/parse/lib/function-header "syntax.rkt" "../aux-syntax.rkt") syntax/parse/define "expander.rkt" "../../macro.rkt" + "../space.rkt" "impl.rkt") -(define-syntax-parser define-for-qi - [(_ name:id expr:expr) - #:with spaced-name ((make-interned-syntax-introducer 'qi) #'name) - #'(define spaced-name expr)] - [(_ (name:id . args:formals) - expr:expr ...) - #'(define-for-qi name - (lambda args - expr ...))]) - ;;; Predicates (define-for-qi all? ~all?) diff --git a/qi-lib/flow/space.rkt b/qi-lib/flow/space.rkt new file mode 100644 index 000000000..ecd6bd037 --- /dev/null +++ b/qi-lib/flow/space.rkt @@ -0,0 +1,17 @@ +#lang racket/base + +(provide define-for-qi) + +(require syntax/parse/define + (for-syntax racket/base + syntax/parse/lib/function-header)) + +(define-syntax-parser define-for-qi + [(_ name:id expr:expr) + #:with spaced-name ((make-interned-syntax-introducer 'qi) #'name) + #'(define spaced-name expr)] + [(_ (name:id . args:formals) + expr:expr ...) + #'(define-for-qi name + (lambda args + expr ...))]) From 8156eb0d0e3b943d8e47b870578ef09b291befd9 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 27 Jan 2023 02:38:47 -0800 Subject: [PATCH 134/338] restore OR and any? --- qi-lib/flow/core/compiler.rkt | 2 -- qi-lib/flow/extended/expander.rkt | 1 - qi-lib/flow/extended/forms.rkt | 7 ++++--- qi-lib/flow/extended/impl.rkt | 6 +++++- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 89388c3ab..6f574755a 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -134,8 +134,6 @@ [(~or* (~datum ▽) (~datum collect)) #'list] ;; predicates - [(~or* (~datum OR) (~datum ∥)) ; NOTE: technically not core - #'(qi0->racket (<< (or (select 1) (select 2)) (gen #f)))] [(~or* (~datum NOT) (~datum !)) #'not] [(~datum XOR) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 9679db530..b852c0e85 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -95,7 +95,6 @@ sep (sep f:floe) collect - OR NOT XOR (and f:floe ...) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 10fd0c20b..56bfe3bca 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -25,6 +25,10 @@ (define-for-qi AND ~all?) +(define-for-qi OR ~any?) + +(define-for-qi any? ~any?) + (define-qi-syntax-rule (one-of? v:expr ...) (~> (member (list v ...)) ->boolean)) @@ -46,9 +50,6 @@ (define-qi-syntax-parser XNOR [_:id #'(~> XOR NOT)]) -(define-qi-syntax-parser any? - [_:id #'OR]) - (define-qi-syntax-parser none? [_:id #'(~> any? NOT)]) diff --git a/qi-lib/flow/extended/impl.rkt b/qi-lib/flow/extended/impl.rkt index 40349af77..630f2cfd6 100644 --- a/qi-lib/flow/extended/impl.rkt +++ b/qi-lib/flow/extended/impl.rkt @@ -6,7 +6,8 @@ (provide ->boolean true. false. - ~all?) + ~all? + ~any?) (define (->boolean v) (and v #t)) @@ -20,3 +21,6 @@ (define (~all? . args) (for/and ([v (in-list args)]) v)) + +(define (~any? . args) + (for/or ([v (in-list args)]) v)) From c0531e75a5921847fcb669f9e1c09c37577d1270 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 27 Jan 2023 03:14:23 -0800 Subject: [PATCH 135/338] restore none? --- qi-lib/flow/extended/forms.rkt | 5 ++--- qi-lib/flow/extended/impl.rkt | 11 +++++++++-- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 56bfe3bca..4bdbe5f96 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -29,6 +29,8 @@ (define-for-qi any? ~any?) +(define-for-qi none? ~none?) + (define-qi-syntax-rule (one-of? v:expr ...) (~> (member (list v ...)) ->boolean)) @@ -50,9 +52,6 @@ (define-qi-syntax-parser XNOR [_:id #'(~> XOR NOT)]) -(define-qi-syntax-parser none? - [_:id #'(~> any? NOT)]) - (define-qi-syntax-rule (and% onex:conjux-clause ...) (~> (== onex.parsed ...) all?)) diff --git a/qi-lib/flow/extended/impl.rkt b/qi-lib/flow/extended/impl.rkt index 630f2cfd6..0ab872643 100644 --- a/qi-lib/flow/extended/impl.rkt +++ b/qi-lib/flow/extended/impl.rkt @@ -7,7 +7,8 @@ true. false. ~all? - ~any?) + ~any? + ~none?) (define (->boolean v) (and v #t)) @@ -22,5 +23,11 @@ (define (~all? . args) (for/and ([v (in-list args)]) v)) -(define (~any? . args) +(define (~any?-helper args) (for/or ([v (in-list args)]) v)) + +(define (~any? . args) + (~any?-helper args)) + +(define (~none? . args) + (not (~any?-helper args))) From 013a14af7bc4e9f99b420b0284ec177b44162221 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 23 Feb 2023 22:58:01 -0800 Subject: [PATCH 136/338] add an explanatory comment re: bindings in qi space --- qi-lib/flow/space.rkt | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/qi-lib/flow/space.rkt b/qi-lib/flow/space.rkt index ecd6bd037..17b42be48 100644 --- a/qi-lib/flow/space.rkt +++ b/qi-lib/flow/space.rkt @@ -6,6 +6,15 @@ (for-syntax racket/base syntax/parse/lib/function-header)) +;; Define variables in the qi binding space. +;; This allows us to define functions in the qi space which, when used in +;; qi contexts, would not be shadowed by bindings at the use site. This +;; gives us some of the benefits of core linguistic forms while also not +;; actually inflating the size of the core language nor incurring the +;; performance penalty it might if it were implemented as a macro +;; compiling to the core language. +;; See "A loophole in Qi space": +;; https://github.com/drym-org/qi/wiki/Qi-Compiler-Sync-Jan-26-2023 (define-syntax-parser define-for-qi [(_ name:id expr:expr) #:with spaced-name ((make-interned-syntax-introducer 'qi) #'name) From 0f615c53996a0ff9fc6a8424e853145cc62d2075 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 23 Feb 2023 23:09:18 -0800 Subject: [PATCH 137/338] reinstate `all` and `any` as core forms --- qi-lib/flow/core/compiler.rkt | 5 +++++ qi-lib/flow/extended/expander.rkt | 2 ++ qi-lib/flow/extended/forms.rkt | 6 ------ 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 6f574755a..c71f483a4 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -144,6 +144,11 @@ #'(disjoin (qi0->racket onex) ...)] [((~datum not) onex:clause) ; NOTE: technically not core #'(negate (qi0->racket onex))] + [((~datum all) onex:clause) + #`(give (curry andmap (qi0->racket onex)))] + [((~datum any) onex:clause) + #'(give (curry ormap (qi0->racket onex)))] + ;; selection [e:select-form (select-parser #'e)] [e:block-form (block-parser #'e)] diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index b852c0e85..27527be30 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -100,6 +100,8 @@ (and f:floe ...) (or f:floe ...) (not f:floe) + (all f:floe) + (any f:floe) (select n:number ...) (~>/form (select arg ...) (report-syntax-error this-syntax diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 4bdbe5f96..fb494bc33 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -34,12 +34,6 @@ (define-qi-syntax-rule (one-of? v:expr ...) (~> (member (list v ...)) ->boolean)) -(define-qi-syntax-rule (all onex:clause) - (~> (>< onex) AND)) - -(define-qi-syntax-rule (any onex:clause) - (~> (>< onex) OR)) - (define-qi-syntax-rule (none onex:clause) (not (any onex))) From 59986c8a7ef2c48f1d5ba786b257c41685c55f7c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 23 Feb 2023 23:13:57 -0800 Subject: [PATCH 138/338] restore original `pass` implementation --- qi-lib/flow/core/compiler.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index c71f483a4..e1c841fae 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -389,10 +389,9 @@ the DSL. (define (pass-parser stx) (syntax-parse stx [_:id - #'(qi0->racket (~> (group 1 (clos (if _ ⏚)) _) - ><))] + #'filter-values] [(_ onex:clause) - #'(qi0->racket (>< (if onex _ ⏚)))])) + #'(curry filter-values (qi0->racket onex))])) (define (fold-left-parser stx) (syntax-parse stx From c991c4d2d9ab5df26613b90c18ab7138d96b23c3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 23 Feb 2023 23:42:30 -0800 Subject: [PATCH 139/338] reinstate `fanout` as a core form, for now --- qi-lib/flow/core/compiler.rkt | 20 ++++++++++++++++++++ qi-lib/flow/core/syntax.rkt | 7 +++++++ qi-lib/flow/extended/expander.rkt | 2 ++ qi-lib/flow/extended/forms.rkt | 12 ------------ 4 files changed, 29 insertions(+), 12 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index e1c841fae..e9816f0f1 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -5,9 +5,11 @@ (require (for-syntax racket/base syntax/parse racket/match + (only-in racket/list make-list) "syntax.rkt" "../aux-syntax.rkt") "impl.rkt" + (only-in racket/list make-list) racket/function racket/undefined (prefix-in fancy: fancy-app)) @@ -161,6 +163,8 @@ ;; folds [e:fold-left-form (fold-left-parser #'e)] [e:fold-right-form (fold-right-parser #'e)] + ;; high-level routing + [e:fanout-form (fanout-parser #'e)] ;; looping [e:feedback-form (feedback-parser #'e)] [e:loop-form (loop-parser #'e)] @@ -321,6 +325,22 @@ the DSL. (apply (qi0->racket consequent) args) (apply (qi0->racket alternative) args)))])) + (define (fanout-parser stx) + (syntax-parse stx + [_:id #'repeat-values] + [(_ n:number) + ;; a slightly more efficient compile-time implementation + ;; for literally indicated N + ;; TODO: implement this as an optimization instead + #`(λ args + (apply values + (append #,@(make-list (syntax->datum #'n) #'args))) )] + [(_ n:expr) + #'(lambda args + (apply values + (apply append + (make-list n args))))])) + (define (feedback-parser stx) (syntax-parse stx [(_ ((~datum while) tilex:clause) diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 8fead4de9..947107d26 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -10,6 +10,7 @@ amp-form relay-form tee-form + fanout-form if-form pass-form fold-left-form @@ -66,6 +67,12 @@ See comments in flow.rkt for more details. (pattern ((~datum if) arg ...))) +(define-syntax-class fanout-form + (pattern + (~datum fanout)) + (pattern + ((~datum fanout) arg ...))) + (define-syntax-class feedback-form (pattern (~datum feedback)) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 27527be30..20277b0d1 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -110,6 +110,8 @@ (~>/form (block arg ...) (report-syntax-error this-syntax "(block ...)")) + fanout + (fanout n:racket-expr) (group n:racket-expr e1:floe e2:floe) group (~>/form (group arg ...) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index fb494bc33..03b1fb585 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -191,18 +191,6 @@ (define-qi-syntax-parser 9> [_:id #'(select 9)]) -;; high level routing -(define-qi-syntax-parser fanout - [_:id #'-<] - [(_ n:number) - ;; a slightly more efficient compile-time implementation - ;; for literally indicated N - ;; TODO: move this to a compiler optimization - #:with list-of-n-blanks #`#,(make-list (syntax->datum #'n) #'_) - #'(-< . list-of-n-blanks)] - [(_ n:expr) - #'(~> (-< (gen n) _) -<)]) - (define-qi-syntax-parser inverter [_:id #'(>< NOT)]) From d2a117df5e837b21931b7466307c07528b508ebd Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 24 Feb 2023 01:25:36 -0800 Subject: [PATCH 140/338] reinstate `partition` as core for now --- qi-lib/flow/core/compiler.rkt | 11 +++++++++++ qi-lib/flow/core/syntax.rkt | 5 +++++ qi-lib/flow/extended/expander.rkt | 4 +++- qi-lib/flow/extended/forms.rkt | 8 -------- 4 files changed, 19 insertions(+), 9 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index e9816f0f1..7185a69f2 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -158,6 +158,7 @@ ;; conditionals [e:if-form (if-parser #'e)] [e:sieve-form (sieve-parser #'e)] + [e:partition-form (partition-parser #'e)] ;; exceptions [e:try-form (try-parser #'e)] ;; folds @@ -295,6 +296,16 @@ the DSL. (~> (pass (not (esc condition))) (esc ronex)))) args))])) + (define (partition-parser stx) + (syntax-parse stx + [(_:id) + #'(qi0->racket ground)] + [(_ [cond:clause body:clause]) + #'(qi0->racket (~> (pass cond) body))] + [(_ [cond:clause body:clause] ...+) + #:with c+bs #'(list (cons (qi0->racket cond) (qi0->racket body)) ...) + #'(qi0->racket (~> (#%blanket-template (partition-values c+bs __))))])) + (define (try-parser stx) (syntax-parse stx [(_ flo diff --git a/qi-lib/flow/core/syntax.rkt b/qi-lib/flow/core/syntax.rkt index 947107d26..2cf8a0ca8 100644 --- a/qi-lib/flow/core/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -5,6 +5,7 @@ block-form group-form sieve-form + partition-form try-form feedback-form amp-form @@ -59,6 +60,10 @@ See comments in flow.rkt for more details. (pattern ((~datum sieve) arg ...))) +(define-syntax-class partition-form + (pattern + ({~datum partition} arg ...))) + (define-syntax-class try-form (pattern ((~datum try) arg ...))) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 20277b0d1..538a456d7 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -110,8 +110,8 @@ (~>/form (block arg ...) (report-syntax-error this-syntax "(block ...)")) - fanout (fanout n:racket-expr) + fanout (group n:racket-expr e1:floe e2:floe) group (~>/form (group arg ...) @@ -129,6 +129,8 @@ (~>/form (sieve arg ...) (report-syntax-error this-syntax "(sieve )")) + (partition) + (partition [cond:floe body:floe] ...+) (try flo:floe [error-condition-flo:floe error-handler-flo:floe] ...+) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 03b1fb585..0ffe9db5f 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -147,14 +147,6 @@ [condition consequent] ...))]) -(define-qi-syntax-parser partition - [(_:id) - #'ground] - [(_ [cond:clause body:clause]) - #'(~> (pass cond) body)] - [(_ [cond:clause body:clause] [conds:clause bodies:clause] ...+) - #'(sieve cond body (partition [conds bodies] ...))]) - (define-qi-syntax-rule (gate onex:clause) (if onex _ ⏚)) From 7b1560079e358dcf20966b6b06e7527e5113e60f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Feb 2023 17:05:39 -0800 Subject: [PATCH 141/338] remove extraneous wrapping thread in `partition` --- qi-lib/flow/core/compiler.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 7185a69f2..fbd0d08b0 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -304,7 +304,7 @@ the DSL. #'(qi0->racket (~> (pass cond) body))] [(_ [cond:clause body:clause] ...+) #:with c+bs #'(list (cons (qi0->racket cond) (qi0->racket body)) ...) - #'(qi0->racket (~> (#%blanket-template (partition-values c+bs __))))])) + #'(qi0->racket (#%blanket-template (partition-values c+bs __)))])) (define (try-parser stx) (syntax-parse stx @@ -503,5 +503,6 @@ the DSL. [((~datum #%blanket-template) (natex (~datum __) prarg-post ...+)) #'(curryr natex prarg-post ...)] + ;; TODO: this should be a compiler optimization [((~datum #%blanket-template) (natex (~datum __))) #'natex]))) From 6a72886e02a9330710180e584f630a9934594006 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Feb 2023 17:08:10 -0800 Subject: [PATCH 142/338] make thresholds configurable in regression report --- qi-sdk/profile/regression.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index 78ca2ccdf..d27ddedd9 100644 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -29,13 +29,16 @@ cons)) benchmarks))) -(define (compute-regression before after) +(define (compute-regression before + after + [low LOWER-THRESHOLD] + [high HIGHER-THRESHOLD]) (define-flow calculate-ratio (~> (-< (hash-ref after _) (hash-ref before _)) / - (if (< LOWER-THRESHOLD _ HIGHER-THRESHOLD) + (if (< low _ high) 1 (~r #:precision 2)))) From ace9c92d8fa7a74afb0699ce2e3cb6238975a522 Mon Sep 17 00:00:00 2001 From: Old Abe Date: Thu, 2 Mar 2023 22:21:21 -0800 Subject: [PATCH 143/338] improve performance of `feedback` --- qi-lib/flow/core/impl.rkt | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 85e5eb9de..658778d96 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -14,7 +14,6 @@ except-args call repeat-values - power foldl-values foldr-values values->list @@ -24,7 +23,8 @@ (require racket/match (only-in racket/function - negate) + negate + thunk) racket/bool racket/list racket/format @@ -208,9 +208,6 @@ (define (repeat-values n . vs) (apply values (apply append (make-list n vs)))) -(define (power n f) - (apply compose (make-list n f))) - (define (fold-values f init vs) (let loop ([vs vs] [accs (values->list (init))]) @@ -225,7 +222,11 @@ (fold-values f init (reverse vs))) (define (feedback-times f n then-f) - (compose then-f (power n f))) + (λ args + (if (= n 0) + (apply then-f args) + (call-with-values (thunk (apply f args)) + (feedback-times f (sub1 n) then-f))))) (define (feedback-while f condition then-f) (λ args From 6399e18405464832a6a9c82b1e0ac61f11a925c3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 6 Mar 2023 16:21:58 -0800 Subject: [PATCH 144/338] document SDK makefile targets --- Makefile | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Makefile b/Makefile index 389a08d99..6c788a05d 100644 --- a/Makefile +++ b/Makefile @@ -7,12 +7,15 @@ DEPS-FLAGS=--check-pkg-deps --unused-pkg-deps help: @echo "install - install package along with dependencies" + @echo "install-sdk - install the SDK which includes developer tools" @echo "remove - remove package" + @echo "remove-sdk - remove SDK; this will not remove SDK dependencies" @echo "build - Compile libraries" @echo "build-docs - Build docs" @echo "build-standalone-docs - Build self-contained docs that could be hosted somewhere" @echo "build-all - Compile libraries, build docs, and check dependencies" @echo "clean - remove all build artifacts" + @echo "clean-sdk - remove all build artifacts in SDK paths" @echo "check-deps - check dependencies" @echo "test - run tests" @echo "test-with-errortrace - run tests with error tracing" From 2c064a8bfa88379fafd698737b26d0898fa6a3a9 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 11:41:58 -0800 Subject: [PATCH 145/338] makefile target for performance regression report --- Makefile | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 6c788a05d..3a94763a8 100644 --- a/Makefile +++ b/Makefile @@ -42,7 +42,11 @@ help: @echo "profile-competitive - Run competitive benchmarks" @echo "profile-forms - Run benchmarks for individual Qi forms" @echo "profile-selected-forms - Run benchmarks for Qi forms by name (command only)" - @echo "form-performance-report - Run benchmarks for Qi forms and produce results for use in CI" + @echo "form-performance-report - Run benchmarks for Qi forms and produce results for use in CI and for measuring regression" + @echo " For use in regression: make form-performance-report > /path/to/before.json" + @echo "performance-regression-report - Run benchmarks for Qi forms against a reference report." + @echo " make performance-regression-report REF=/path/to/before.json" + # Primarily for use by CI. # Installs dependencies as well as linking this as a package. @@ -181,4 +185,7 @@ profile: profile-competitive profile-forms form-performance-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile form-performance-report +performance-regression-report: + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) + +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile form-performance-report performance-regression-report From a38c2dc607e4a90a6dc4dc95eb7386d41b6c403a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 18:17:35 -0800 Subject: [PATCH 146/338] Refactor benchmarks to unify form-related ones --- .../{forms-base.rkt => forms/base.rkt} | 6 +- .../{forms.rkt => forms/benchmarks.rkt} | 290 ++++-------------- qi-sdk/profile/{ => forms}/loadlib.rkt | 0 qi-sdk/profile/{ => forms}/regression.rkt | 0 qi-sdk/profile/forms/report.rkt | 246 +++++++++++++++ qi-sdk/profile/report.rkt | 199 ------------ 6 files changed, 309 insertions(+), 432 deletions(-) rename qi-sdk/profile/{forms-base.rkt => forms/base.rkt} (69%) rename qi-sdk/profile/{forms.rkt => forms/benchmarks.rkt} (68%) rename qi-sdk/profile/{ => forms}/loadlib.rkt (100%) rename qi-sdk/profile/{ => forms}/regression.rkt (100%) create mode 100755 qi-sdk/profile/forms/report.rkt delete mode 100755 qi-sdk/profile/report.rkt diff --git a/qi-sdk/profile/forms-base.rkt b/qi-sdk/profile/forms/base.rkt similarity index 69% rename from qi-sdk/profile/forms-base.rkt rename to qi-sdk/profile/forms/base.rkt index 707bc19a3..7431b112f 100644 --- a/qi-sdk/profile/forms-base.rkt +++ b/qi-sdk/profile/forms/base.rkt @@ -2,11 +2,9 @@ (provide (all-from-out racket/base) (all-from-out qi) - (all-from-out "util.rkt") + (all-from-out "../util.rkt") sqr) (require qi - "util.rkt" + "../util.rkt" (only-in math sqr)) - - diff --git a/qi-sdk/profile/forms.rkt b/qi-sdk/profile/forms/benchmarks.rkt similarity index 68% rename from qi-sdk/profile/forms.rkt rename to qi-sdk/profile/forms/benchmarks.rkt index ecad648c6..593e1eba1 100755 --- a/qi-sdk/profile/forms.rkt +++ b/qi-sdk/profile/forms/benchmarks.rkt @@ -21,7 +21,7 @@ submodule. This will ensure that it gets picked up when the benchmarks for the forms are run. |# -(module one-of? "forms-base.rkt" +(module one-of? "base.rkt" (provide run) (define (~one-of? v) @@ -33,7 +33,7 @@ for the forms are run. check-value 100000))) -(module and "forms-base.rkt" +(module and "base.rkt" (provide run) (define (~and v) @@ -45,7 +45,7 @@ for the forms are run. check-value 200000))) -(module or "forms-base.rkt" +(module or "base.rkt" (provide run) (define (~or v) @@ -57,7 +57,7 @@ for the forms are run. check-value 200000))) -(module not "forms-base.rkt" +(module not "base.rkt" (provide run) (define (~not v) @@ -69,7 +69,7 @@ for the forms are run. check-value 200000))) -(module and% "forms-base.rkt" +(module and% "base.rkt" (provide run) (define (~and% a b) @@ -81,7 +81,7 @@ for the forms are run. check-two-values 200000))) -(module or% "forms-base.rkt" +(module or% "base.rkt" (provide run) (define (~or% a b) @@ -93,7 +93,7 @@ for the forms are run. check-two-values 200000))) -(module group "forms-base.rkt" +(module group "base.rkt" (provide run) (define (~group . vs) @@ -109,7 +109,7 @@ for the forms are run. check-values 200000))) -(module count "forms-base.rkt" +(module count "base.rkt" (provide run) (define (~count . vs) @@ -122,7 +122,7 @@ for the forms are run. check-values 1000000))) -(module relay "forms-base.rkt" +(module relay "base.rkt" (provide run) (define (~relay . vs) @@ -144,7 +144,7 @@ for the forms are run. check-values 50000))) -(module relay* "forms-base.rkt" +(module relay* "base.rkt" (provide run) (define (~relay* . vs) @@ -160,7 +160,7 @@ for the forms are run. check-values 50000))) -(module amp "forms-base.rkt" +(module amp "base.rkt" (provide run) (define (~amp . vs) @@ -173,7 +173,7 @@ for the forms are run. check-values 300000))) -(module ground "forms-base.rkt" +(module ground "base.rkt" (provide run) (define (~ground . vs) @@ -186,7 +186,7 @@ for the forms are run. check-values 200000))) -(module thread "forms-base.rkt" +(module thread "base.rkt" (provide run) (define (~thread . vs) @@ -209,7 +209,7 @@ for the forms are run. check-values 200000))) -(module thread-right "forms-base.rkt" +(module thread-right "base.rkt" (provide run) (define (~thread-right . vs) @@ -232,7 +232,7 @@ for the forms are run. check-values 200000))) -(module crossover "forms-base.rkt" +(module crossover "base.rkt" (provide run) (define (~crossover . vs) @@ -245,7 +245,7 @@ for the forms are run. check-values 200000))) -(module all "forms-base.rkt" +(module all "base.rkt" (provide run) (define (~all . vs) @@ -258,7 +258,7 @@ for the forms are run. check-values 200000))) -(module any "forms-base.rkt" +(module any "base.rkt" (provide run) (define (~any . vs) @@ -271,7 +271,7 @@ for the forms are run. check-values 200000))) -(module none "forms-base.rkt" +(module none "base.rkt" (provide run) (define (~none . vs) @@ -284,7 +284,7 @@ for the forms are run. check-values 200000))) -(module all? "forms-base.rkt" +(module all? "base.rkt" (provide run) (define (~all? . vs) @@ -297,7 +297,7 @@ for the forms are run. check-values 200000))) -(module any? "forms-base.rkt" +(module any? "base.rkt" (provide run) (define (~any? . vs) @@ -310,7 +310,7 @@ for the forms are run. check-values 200000))) -(module none? "forms-base.rkt" +(module none? "base.rkt" (provide run) (define (~none? . vs) @@ -323,7 +323,7 @@ for the forms are run. check-values 200000))) -(module collect "forms-base.rkt" +(module collect "base.rkt" (provide run) (define (~collect . vs) @@ -336,7 +336,7 @@ for the forms are run. check-values 1000000))) -(module sep "forms-base.rkt" +(module sep "base.rkt" (provide run) (define (~sep v) @@ -348,7 +348,7 @@ for the forms are run. check-list 1000000))) -(module gen "forms-base.rkt" +(module gen "base.rkt" (provide run) (define (~gen . vs) @@ -361,7 +361,7 @@ for the forms are run. check-values 1000000))) -(module esc "forms-base.rkt" +(module esc "base.rkt" (provide run) (define (~esc . vs) @@ -374,7 +374,7 @@ for the forms are run. check-values 1000000))) -(module AND "forms-base.rkt" +(module AND "base.rkt" (provide run) (define (~AND . vs) @@ -387,7 +387,7 @@ for the forms are run. check-values 200000))) -(module OR "forms-base.rkt" +(module OR "base.rkt" (provide run) (define (~OR . vs) @@ -400,7 +400,7 @@ for the forms are run. check-values 200000))) -(module NOT "forms-base.rkt" +(module NOT "base.rkt" (provide run) (define (~NOT v) @@ -412,7 +412,7 @@ for the forms are run. check-value 200000))) -(module NAND "forms-base.rkt" +(module NAND "base.rkt" (provide run) (define (~NAND . vs) @@ -425,7 +425,7 @@ for the forms are run. check-values 200000))) -(module NOR "forms-base.rkt" +(module NOR "base.rkt" (provide run) (define (~NOR . vs) @@ -438,7 +438,7 @@ for the forms are run. check-values 200000))) -(module XOR "forms-base.rkt" +(module XOR "base.rkt" (provide run) (define (~XOR . vs) @@ -451,7 +451,7 @@ for the forms are run. check-values 200000))) -(module XNOR "forms-base.rkt" +(module XNOR "base.rkt" (provide run) (define (~XNOR . vs) @@ -464,7 +464,7 @@ for the forms are run. check-values 200000))) -(module tee "forms-base.rkt" +(module tee "base.rkt" (provide run) (define (~tee v) @@ -476,7 +476,7 @@ for the forms are run. check-value 200000))) -(module try "forms-base.rkt" +(module try "base.rkt" (provide run) (define (try-happy . vs) @@ -499,7 +499,7 @@ for the forms are run. (try-happy check-values 20000) (try-error check-values 20000)))) -(module currying "forms-base.rkt" +(module currying "base.rkt" (provide run) (define (currying . vs) @@ -510,7 +510,7 @@ for the forms are run. check-values 200000))) -(module template "forms-base.rkt" +(module template "base.rkt" (provide run) (define (template . vs) @@ -521,7 +521,7 @@ for the forms are run. check-values 200000))) -(module catchall-template "forms-base.rkt" +(module catchall-template "base.rkt" (provide run) (define (catchall-template . vs) @@ -532,7 +532,7 @@ for the forms are run. check-values 200000))) -(module if "forms-base.rkt" +(module if "base.rkt" (provide run) (define (~if . vs) @@ -544,7 +544,7 @@ for the forms are run. check-values 500000))) -(module when "forms-base.rkt" +(module when "base.rkt" (provide run) (define (~when . vs) @@ -556,7 +556,7 @@ for the forms are run. check-values 500000))) -(module unless "forms-base.rkt" +(module unless "base.rkt" (provide run) (define (~unless . vs) @@ -568,7 +568,7 @@ for the forms are run. check-values 500000))) -(module switch "forms-base.rkt" +(module switch "base.rkt" (provide run) (define (switch-basic . vs) @@ -596,7 +596,7 @@ for the forms are run. (switch-else check-values 200000) (switch-divert check-values 200000)))) -(module sieve "forms-base.rkt" +(module sieve "base.rkt" (provide run) (define (~sieve . vs) @@ -608,7 +608,7 @@ for the forms are run. check-values 100000))) -(module partition "forms-base.rkt" +(module partition "base.rkt" (provide run) (define (~partition . vs) (apply (flow (partition [negative? *] @@ -618,7 +618,7 @@ for the forms are run. (define (run) (run-benchmark ~partition check-values 100000))) -(module gate "forms-base.rkt" +(module gate "base.rkt" (provide run) (define (~gate . vs) @@ -630,7 +630,7 @@ for the forms are run. check-values 500000))) -(module input-aliases "forms-base.rkt" +(module input-aliases "base.rkt" (provide run) (define (input-alias-1 . vs) @@ -658,7 +658,7 @@ for the forms are run. check-values 100000)))) -(module fanout "forms-base.rkt" +(module fanout "base.rkt" (provide run) (define (fanout-small-n . vs) @@ -679,7 +679,7 @@ for the forms are run. check-values 20000)))) -(module inverter "forms-base.rkt" +(module inverter "base.rkt" (provide run) (define (~inverter . vs) @@ -691,7 +691,7 @@ for the forms are run. check-values 200000))) -(module feedback "forms-base.rkt" +(module feedback "base.rkt" (provide run) (define (feedback-number . vs) @@ -720,7 +720,7 @@ for the forms are run. check-value 70000)))) -(module select "forms-base.rkt" +(module select "base.rkt" (provide run) (define (~select . vs) @@ -732,7 +732,7 @@ for the forms are run. check-values 20000))) -(module block "forms-base.rkt" +(module block "base.rkt" (provide run) (define (~block . vs) @@ -744,7 +744,7 @@ for the forms are run. check-values 20000))) -(module bundle "forms-base.rkt" +(module bundle "base.rkt" (provide run) (define (~bundle . vs) @@ -756,7 +756,7 @@ for the forms are run. check-values 20000))) -(module effect "forms-base.rkt" +(module effect "base.rkt" (provide run) (define (~effect . vs) @@ -768,7 +768,7 @@ for the forms are run. check-values 200000))) -(module live? "forms-base.rkt" +(module live? "base.rkt" (provide run) (define (~live? . vs) @@ -780,7 +780,7 @@ for the forms are run. check-values 500000))) -(module rectify "forms-base.rkt" +(module rectify "base.rkt" (provide run) (define (~rectify . vs) @@ -792,7 +792,7 @@ for the forms are run. check-values 500000))) -(module pass "forms-base.rkt" +(module pass "base.rkt" (provide run) (define (~pass . vs) @@ -804,7 +804,7 @@ for the forms are run. check-values 200000))) -(module foldl "forms-base.rkt" +(module foldl "base.rkt" (provide run) (define (~foldl . vs) @@ -816,7 +816,7 @@ for the forms are run. check-values 200000))) -(module foldr "forms-base.rkt" +(module foldr "base.rkt" (provide run) (define (~foldr . vs) @@ -828,7 +828,7 @@ for the forms are run. check-values 200000))) -(module loop "forms-base.rkt" +(module loop "base.rkt" (provide run) (define (~loop . vs) @@ -840,7 +840,7 @@ for the forms are run. check-values 100000))) -(module loop2 "forms-base.rkt" +(module loop2 "base.rkt" (provide run) (define (~loop2 . vs) @@ -855,7 +855,7 @@ for the forms are run. check-values 100000))) -(module apply "forms-base.rkt" +(module apply "base.rkt" (provide run) (require (only-in racket/base @@ -870,7 +870,7 @@ for the forms are run. check-values 300000))) -(module clos "forms-base.rkt" +(module clos "base.rkt" (provide run) ;; TODO: this uses a lot of other things besides `clos` and is @@ -884,171 +884,3 @@ for the forms are run. (run-benchmark ~clos check-values 100000))) - -;; To run benchmarks for a form interactively, use e.g.: -;; (require (submod "." fanout)) -;; (run) - -(module* main cli - - (require - (prefix-in one-of?: (submod ".." one-of?)) - (prefix-in and: (submod ".." and)) - (prefix-in or: (submod ".." or)) - (prefix-in not: (submod ".." not)) - (prefix-in and%: (submod ".." and%)) - (prefix-in or%: (submod ".." or%)) - (prefix-in group: (submod ".." group)) - (prefix-in count: (submod ".." count)) - (prefix-in relay: (submod ".." relay)) - (prefix-in relay*: (submod ".." relay*)) - (prefix-in amp: (submod ".." amp)) - (prefix-in ground: (submod ".." ground)) - (prefix-in thread: (submod ".." thread)) - (prefix-in thread-right: (submod ".." thread-right)) - (prefix-in crossover: (submod ".." crossover)) - (prefix-in all: (submod ".." all)) - (prefix-in any: (submod ".." any)) - (prefix-in none: (submod ".." none)) - (prefix-in all?: (submod ".." all?)) - (prefix-in any?: (submod ".." any?)) - (prefix-in none?: (submod ".." none?)) - (prefix-in collect: (submod ".." collect)) - (prefix-in sep: (submod ".." sep)) - (prefix-in gen: (submod ".." gen)) - (prefix-in esc: (submod ".." esc)) - (prefix-in AND: (submod ".." AND)) - (prefix-in OR: (submod ".." OR)) - (prefix-in NOT: (submod ".." NOT)) - (prefix-in NAND: (submod ".." NAND)) - (prefix-in NOR: (submod ".." NOR)) - (prefix-in XOR: (submod ".." XOR)) - (prefix-in XNOR: (submod ".." XNOR)) - (prefix-in tee: (submod ".." tee)) - (prefix-in try: (submod ".." try)) - (prefix-in currying: (submod ".." currying)) - (prefix-in template: (submod ".." template)) - (prefix-in catchall-template: (submod ".." catchall-template)) - (prefix-in if: (submod ".." if)) - (prefix-in when: (submod ".." when)) - (prefix-in unless: (submod ".." unless)) - (prefix-in switch: (submod ".." switch)) - (prefix-in sieve: (submod ".." sieve)) - (prefix-in partition: (submod ".." partition)) - (prefix-in gate: (submod ".." gate)) - (prefix-in input-aliases: (submod ".." input-aliases)) - (prefix-in fanout: (submod ".." fanout)) - (prefix-in inverter: (submod ".." inverter)) - (prefix-in feedback: (submod ".." feedback)) - (prefix-in select: (submod ".." select)) - (prefix-in block: (submod ".." block)) - (prefix-in bundle: (submod ".." bundle)) - (prefix-in effect: (submod ".." effect)) - (prefix-in live?: (submod ".." live?)) - (prefix-in rectify: (submod ".." rectify)) - (prefix-in pass: (submod ".." pass)) - (prefix-in foldl: (submod ".." foldl)) - (prefix-in foldr: (submod ".." foldr)) - (prefix-in loop: (submod ".." loop)) - (prefix-in loop2: (submod ".." loop2)) - (prefix-in apply: (submod ".." apply)) - (prefix-in clos: (submod ".." clos))) - - (require racket/match - racket/format - relation - qi - (only-in "util.rkt" - only-if - for/call)) - - ;; It would be great if we could get the value of a variable - ;; by using its (string) name, but (eval (string->symbol name)) - ;; doesn't find it. So instead, we reify the "lexical environment" - ;; here manually, so that the values can be looked up at runtime - ;; based on the string names (note that the value is always the key - ;; + ":" + "run") - (define env - (hash - "one-of?" one-of?:run - "and" and:run - "or" or:run - "not" not:run - "and%" and%:run - "or%" or%:run - "group" group:run - "count" count:run - "relay" relay:run - "relay*" relay*:run - "amp" amp:run - "ground" ground:run - "thread" thread:run - "thread-right" thread-right:run - "crossover" crossover:run - "all" all:run - "any" any:run - "none" none:run - "all?" all?:run - "any?" any?:run - "none?" none?:run - "collect" collect:run - "sep" sep:run - "gen" gen:run - "esc" esc:run - "AND" AND:run - "OR" OR:run - "NOT" NOT:run - "NAND" NAND:run - "NOR" NOR:run - "XOR" XOR:run - "XNOR" XNOR:run - "tee" tee:run - "try" try:run - "currying" currying:run - "template" template:run - "catchall-template" catchall-template:run - "if" if:run - "when" when:run - "unless" unless:run - "switch" switch:run - "sieve" sieve:run - "partition" partition:run - "gate" gate:run - "input-aliases" input-aliases:run - "fanout" fanout:run - "inverter" inverter:run - "feedback" feedback:run - "select" select:run - "block" block:run - "bundle" bundle:run - "effect" effect:run - "live?" live?:run - "rectify" rectify:run - "pass" pass:run - "foldl" foldl:run - "foldr" foldr:run - "loop" loop:run - "loop2" loop2:run - "apply" apply:run - "clos" clos:run)) - - (flag (forms #:param [forms null] name) - ("-f" "--form" "Forms to benchmark") - (forms (cons name (forms)))) - - (constraint (multi forms)) - - (help - (usage (~a "Run benchmarks for individual Qi forms " - "(by default, all of them)."))) - - (program (main) - (let ([fs (~>> ((forms)) - (only-if null? - (gen (hash-keys env))) - (sort <))]) - (for ([f fs]) - (match-let ([(list name ms) ((hash-ref env f))]) - (displayln (~a name ": " ms " ms")))))) - - (run main)) diff --git a/qi-sdk/profile/loadlib.rkt b/qi-sdk/profile/forms/loadlib.rkt similarity index 100% rename from qi-sdk/profile/loadlib.rkt rename to qi-sdk/profile/forms/loadlib.rkt diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/forms/regression.rkt similarity index 100% rename from qi-sdk/profile/regression.rkt rename to qi-sdk/profile/forms/regression.rkt diff --git a/qi-sdk/profile/forms/report.rkt b/qi-sdk/profile/forms/report.rkt new file mode 100755 index 000000000..e32073740 --- /dev/null +++ b/qi-sdk/profile/forms/report.rkt @@ -0,0 +1,246 @@ +#!/usr/bin/env racket +#lang cli + +#| +To add a benchmark for a new form: + +1. Add a submodule for it in benchmarks.rkt which provides a `run` +function taking no arguments. This function will be expected to +exercise the new form and return a time taken. The `run` function +typically uses one of the utility macros `run-benchmark` or +`run-summary-benchmark`, and provides it one of the helper functions +`check-value` (to invoke the form with a single value each time during +benchmarking) or `check-values` (to invoke the form with multiple +values each time during benchmarking). Note that at the moment, as a +hack for convenience, `run-benchmark` expects a function with the name +of the form being benchmarked _prefixed with tilde_. This is to avoid +name collisions between this function and the Qi form with the same +name. Basically, just follow one of the numerous examples in this +module to see what this is referring to. + +2. Require the submodule in the present module with an appropriate +prefix (see other examples) + +3. Add the required `run` function to the `env` hash below. This will +ensure that it gets picked up when the benchmarks for the forms are +run. +|# + +(require + (prefix-in one-of?: (submod "benchmarks.rkt" one-of?)) + (prefix-in and: (submod "benchmarks.rkt" and)) + (prefix-in or: (submod "benchmarks.rkt" or)) + (prefix-in not: (submod "benchmarks.rkt" not)) + (prefix-in and%: (submod "benchmarks.rkt" and%)) + (prefix-in or%: (submod "benchmarks.rkt" or%)) + (prefix-in group: (submod "benchmarks.rkt" group)) + (prefix-in count: (submod "benchmarks.rkt" count)) + (prefix-in relay: (submod "benchmarks.rkt" relay)) + (prefix-in relay*: (submod "benchmarks.rkt" relay*)) + (prefix-in amp: (submod "benchmarks.rkt" amp)) + (prefix-in ground: (submod "benchmarks.rkt" ground)) + (prefix-in thread: (submod "benchmarks.rkt" thread)) + (prefix-in thread-right: (submod "benchmarks.rkt" thread-right)) + (prefix-in crossover: (submod "benchmarks.rkt" crossover)) + (prefix-in all: (submod "benchmarks.rkt" all)) + (prefix-in any: (submod "benchmarks.rkt" any)) + (prefix-in none: (submod "benchmarks.rkt" none)) + (prefix-in all?: (submod "benchmarks.rkt" all?)) + (prefix-in any?: (submod "benchmarks.rkt" any?)) + (prefix-in none?: (submod "benchmarks.rkt" none?)) + (prefix-in collect: (submod "benchmarks.rkt" collect)) + (prefix-in sep: (submod "benchmarks.rkt" sep)) + (prefix-in gen: (submod "benchmarks.rkt" gen)) + (prefix-in esc: (submod "benchmarks.rkt" esc)) + (prefix-in AND: (submod "benchmarks.rkt" AND)) + (prefix-in OR: (submod "benchmarks.rkt" OR)) + (prefix-in NOT: (submod "benchmarks.rkt" NOT)) + (prefix-in NAND: (submod "benchmarks.rkt" NAND)) + (prefix-in NOR: (submod "benchmarks.rkt" NOR)) + (prefix-in XOR: (submod "benchmarks.rkt" XOR)) + (prefix-in XNOR: (submod "benchmarks.rkt" XNOR)) + (prefix-in tee: (submod "benchmarks.rkt" tee)) + (prefix-in try: (submod "benchmarks.rkt" try)) + (prefix-in currying: (submod "benchmarks.rkt" currying)) + (prefix-in template: (submod "benchmarks.rkt" template)) + (prefix-in catchall-template: (submod "benchmarks.rkt" catchall-template)) + (prefix-in if: (submod "benchmarks.rkt" if)) + (prefix-in when: (submod "benchmarks.rkt" when)) + (prefix-in unless: (submod "benchmarks.rkt" unless)) + (prefix-in switch: (submod "benchmarks.rkt" switch)) + (prefix-in sieve: (submod "benchmarks.rkt" sieve)) + (prefix-in partition: (submod "benchmarks.rkt" partition)) + (prefix-in gate: (submod "benchmarks.rkt" gate)) + (prefix-in input-aliases: (submod "benchmarks.rkt" input-aliases)) + (prefix-in fanout: (submod "benchmarks.rkt" fanout)) + (prefix-in inverter: (submod "benchmarks.rkt" inverter)) + (prefix-in feedback: (submod "benchmarks.rkt" feedback)) + (prefix-in select: (submod "benchmarks.rkt" select)) + (prefix-in block: (submod "benchmarks.rkt" block)) + (prefix-in bundle: (submod "benchmarks.rkt" bundle)) + (prefix-in effect: (submod "benchmarks.rkt" effect)) + (prefix-in live?: (submod "benchmarks.rkt" live?)) + (prefix-in rectify: (submod "benchmarks.rkt" rectify)) + (prefix-in pass: (submod "benchmarks.rkt" pass)) + (prefix-in foldl: (submod "benchmarks.rkt" foldl)) + (prefix-in foldr: (submod "benchmarks.rkt" foldr)) + (prefix-in loop: (submod "benchmarks.rkt" loop)) + (prefix-in loop2: (submod "benchmarks.rkt" loop2)) + (prefix-in apply: (submod "benchmarks.rkt" apply)) + (prefix-in clos: (submod "benchmarks.rkt" clos))) + +(require "loadlib.rkt" + "regression.rkt") + +(require racket/match + racket/format + relation + qi + json + csv-writing + (only-in "../util.rkt" + only-if + for/call)) + +;; It would be great if we could get the value of a variable +;; by using its (string) name, but (eval (string->symbol name)) +;; doesn't find it. So instead, we reify the "lexical environment" +;; here manually, so that the values can be looked up at runtime +;; based on the string names (note that the value is always the key +;; + ":" + "run") +(define env + (hash + "one-of?" one-of?:run + "and" and:run + "or" or:run + "not" not:run + "and%" and%:run + "or%" or%:run + "group" group:run + "count" count:run + "relay" relay:run + "relay*" relay*:run + "amp" amp:run + "ground" ground:run + "thread" thread:run + "thread-right" thread-right:run + "crossover" crossover:run + "all" all:run + "any" any:run + "none" none:run + "all?" all?:run + "any?" any?:run + "none?" none?:run + "collect" collect:run + "sep" sep:run + "gen" gen:run + "esc" esc:run + "AND" AND:run + "OR" OR:run + "NOT" NOT:run + "NAND" NAND:run + "NOR" NOR:run + "XOR" XOR:run + "XNOR" XNOR:run + "tee" tee:run + "try" try:run + "currying" currying:run + "template" template:run + "catchall-template" catchall-template:run + "if" if:run + "when" when:run + "unless" unless:run + "switch" switch:run + "sieve" sieve:run + "partition" partition:run + "gate" gate:run + "input-aliases" input-aliases:run + "fanout" fanout:run + "inverter" inverter:run + "feedback" feedback:run + "select" select:run + "block" block:run + "bundle" bundle:run + "effect" effect:run + "live?" live?:run + "rectify" rectify:run + "pass" pass:run + "foldl" foldl:run + "foldr" foldr:run + "loop" loop:run + "loop2" loop2:run + "apply" apply:run + "clos" clos:run)) + +(define (write-csv data) + (~> (data) + △ + (>< (~> (-< (hash-ref 'name) + (hash-ref 'unit) + (hash-ref 'value)) + ▽)) + (-< '(name unit value) + _) + ▽ + display-table)) + +(flag (forms #:param [forms null] name) + ("-f" "--form" "Forms to benchmark") + (forms (cons name (forms)))) + +(constraint (multi forms)) + +(help + (usage + (~a "Run benchmarks for individual Qi forms " + "(by default, all of them), reporting the results " + "in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-o" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(define (format-output output) + ;; Note: this is a case where declaring "constraints" on the CLI args + ;; would be useful, instead of using the ad hoc fallback `else` check here + ;; https://github.com/countvajhula/cli/issues/6 + (cond + [(equal? (output-format) "json") (write-json output)] + [(equal? (output-format) "csv") (write-csv output)] + [(equal? (output-format) "") (values)] + [else (error (~a "Unrecognized format: " (output-format) "!"))])) + +(program (main) + (define fs (~>> ((forms)) + (only-if null? + (gen (hash-keys env))) + (sort <))) + (define forms-data (for/list ([f (in-list fs)]) + (match-let ([(list name ms) ((hash-ref env f))]) + ;; Print results "live" to STDERR, with + ;; only the actual output (if desired) + ;; going to STDOUT at the end. + (displayln (~a name ": " ms " ms") + (current-error-port)) + (hash 'name name 'unit "ms" 'value ms)))) + (define require-data (list (hash 'name "(require qi)" + 'unit "ms" + 'value (time-module-ms "qi")))) + (let ([output (append forms-data require-data)]) + + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (compute-regression before after)) + (format-output output)))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-f" "fanout")) + +(run main) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt deleted file mode 100755 index 214b1f4d2..000000000 --- a/qi-sdk/profile/report.rkt +++ /dev/null @@ -1,199 +0,0 @@ -#!/usr/bin/env racket -#lang cli - -(require - (prefix-in one-of?: (submod "forms.rkt" one-of?)) - (prefix-in and: (submod "forms.rkt" and)) - (prefix-in or: (submod "forms.rkt" or)) - (prefix-in not: (submod "forms.rkt" not)) - (prefix-in and%: (submod "forms.rkt" and%)) - (prefix-in or%: (submod "forms.rkt" or%)) - (prefix-in group: (submod "forms.rkt" group)) - (prefix-in count: (submod "forms.rkt" count)) - (prefix-in relay: (submod "forms.rkt" relay)) - (prefix-in relay*: (submod "forms.rkt" relay*)) - (prefix-in amp: (submod "forms.rkt" amp)) - (prefix-in ground: (submod "forms.rkt" ground)) - (prefix-in thread: (submod "forms.rkt" thread)) - (prefix-in thread-right: (submod "forms.rkt" thread-right)) - (prefix-in crossover: (submod "forms.rkt" crossover)) - (prefix-in all: (submod "forms.rkt" all)) - (prefix-in any: (submod "forms.rkt" any)) - (prefix-in none: (submod "forms.rkt" none)) - (prefix-in all?: (submod "forms.rkt" all?)) - (prefix-in any?: (submod "forms.rkt" any?)) - (prefix-in none?: (submod "forms.rkt" none?)) - (prefix-in collect: (submod "forms.rkt" collect)) - (prefix-in sep: (submod "forms.rkt" sep)) - (prefix-in gen: (submod "forms.rkt" gen)) - (prefix-in esc: (submod "forms.rkt" esc)) - (prefix-in AND: (submod "forms.rkt" AND)) - (prefix-in OR: (submod "forms.rkt" OR)) - (prefix-in NOT: (submod "forms.rkt" NOT)) - (prefix-in NAND: (submod "forms.rkt" NAND)) - (prefix-in NOR: (submod "forms.rkt" NOR)) - (prefix-in XOR: (submod "forms.rkt" XOR)) - (prefix-in XNOR: (submod "forms.rkt" XNOR)) - (prefix-in tee: (submod "forms.rkt" tee)) - (prefix-in try: (submod "forms.rkt" try)) - (prefix-in currying: (submod "forms.rkt" currying)) - (prefix-in template: (submod "forms.rkt" template)) - (prefix-in catchall-template: (submod "forms.rkt" catchall-template)) - (prefix-in if: (submod "forms.rkt" if)) - (prefix-in when: (submod "forms.rkt" when)) - (prefix-in unless: (submod "forms.rkt" unless)) - (prefix-in switch: (submod "forms.rkt" switch)) - (prefix-in sieve: (submod "forms.rkt" sieve)) - (prefix-in partition: (submod "forms.rkt" partition)) - (prefix-in gate: (submod "forms.rkt" gate)) - (prefix-in input-aliases: (submod "forms.rkt" input-aliases)) - (prefix-in fanout: (submod "forms.rkt" fanout)) - (prefix-in inverter: (submod "forms.rkt" inverter)) - (prefix-in feedback: (submod "forms.rkt" feedback)) - (prefix-in select: (submod "forms.rkt" select)) - (prefix-in block: (submod "forms.rkt" block)) - (prefix-in bundle: (submod "forms.rkt" bundle)) - (prefix-in effect: (submod "forms.rkt" effect)) - (prefix-in live?: (submod "forms.rkt" live?)) - (prefix-in rectify: (submod "forms.rkt" rectify)) - (prefix-in pass: (submod "forms.rkt" pass)) - (prefix-in foldl: (submod "forms.rkt" foldl)) - (prefix-in foldr: (submod "forms.rkt" foldr)) - (prefix-in loop: (submod "forms.rkt" loop)) - (prefix-in loop2: (submod "forms.rkt" loop2)) - (prefix-in apply: (submod "forms.rkt" apply)) - (prefix-in clos: (submod "forms.rkt" clos))) - -(require "loadlib.rkt" - "regression.rkt") - -(require racket/match - racket/format - relation - qi - json - csv-writing - (only-in "util.rkt" - only-if - for/call)) - -;; It would be great if we could get the value of a variable -;; by using its (string) name, but (eval (string->symbol name)) -;; doesn't find it. So instead, we reify the "lexical environment" -;; here manually, so that the values can be looked up at runtime -;; based on the string names (note that the value is always the key -;; + ":" + "run") -(define env - (hash - "one-of?" one-of?:run - "and" and:run - "or" or:run - "not" not:run - "and%" and%:run - "or%" or%:run - "group" group:run - "count" count:run - "relay" relay:run - "relay*" relay*:run - "amp" amp:run - "ground" ground:run - "thread" thread:run - "thread-right" thread-right:run - "crossover" crossover:run - "all" all:run - "any" any:run - "none" none:run - "all?" all?:run - "any?" any?:run - "none?" none?:run - "collect" collect:run - "sep" sep:run - "gen" gen:run - "esc" esc:run - "AND" AND:run - "OR" OR:run - "NOT" NOT:run - "NAND" NAND:run - "NOR" NOR:run - "XOR" XOR:run - "XNOR" XNOR:run - "tee" tee:run - "try" try:run - "currying" currying:run - "template" template:run - "catchall-template" catchall-template:run - "if" if:run - "when" when:run - "unless" unless:run - "switch" switch:run - "sieve" sieve:run - "partition" partition:run - "gate" gate:run - "input-aliases" input-aliases:run - "fanout" fanout:run - "inverter" inverter:run - "feedback" feedback:run - "select" select:run - "block" block:run - "bundle" bundle:run - "effect" effect:run - "live?" live?:run - "rectify" rectify:run - "pass" pass:run - "foldl" foldl:run - "foldr" foldr:run - "loop" loop:run - "loop2" loop2:run - "apply" apply:run - "clos" clos:run)) - -(define (write-csv data) - (~> (data) - △ - (>< (~> (-< (hash-ref 'name) - (hash-ref 'unit) - (hash-ref 'value)) - ▽)) - (-< '(name unit value) - _) - ▽ - display-table)) - -(help - (usage (~a "Report on the performance of all of the forms " - "of the language, in a configurable output format."))) - -(flag (output-format #:param [output-format "json"] fmt) - ("-f" "--format" "Output format to use, either 'json' or 'csv'") - (output-format fmt)) - -(flag (regression-file #:param [regression-file #f] reg-file) - ("-r" "--regression" "'Before' data to compute regression against") - (regression-file reg-file)) - -(define (format-output output) - ;; Note: this is a case where declaring "constraints" on the CLI args - ;; would be useful, instead of using the ad hoc fallback `else` check here - ;; https://github.com/countvajhula/cli/issues/6 - (cond - [(equal? (output-format) "json") (write-json output)] - [(equal? (output-format) "csv") (write-csv output)] - [else (error (~a "Unrecognized format: " (output-format) "!"))])) - -(program (main) - (define fs (hash-keys env #t)) - (define forms-data (for/list ([f (in-list fs)]) - (match-let ([(list name ms) ((hash-ref env f))]) - (hash 'name name 'unit "ms" 'value ms)))) - (define require-data (list (hash 'name "(require qi)" - 'unit "ms" - 'value (time-module-ms "qi")))) - (let ([output (append forms-data require-data)]) - - (if (regression-file) - (let ([before (parse-benchmarks (parse-json-file (regression-file)))] - [after (parse-benchmarks output)]) - (compute-regression before after)) - (format-output output)))) - -(run main) From 80aba31102dee86a5ff1b066645ce67a2ea8c9ff Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 18:47:34 -0800 Subject: [PATCH 147/338] start to separate form benchmarks from other benchmarks --- qi-sdk/profile/forms/benchmarks.rkt | 170 +++++++++++- qi-sdk/profile/forms/report.rkt | 246 ------------------ qi-sdk/profile/{forms => loading}/loadlib.rkt | 0 qi-sdk/profile/report.rkt | 79 ++++++ 4 files changed, 247 insertions(+), 248 deletions(-) delete mode 100755 qi-sdk/profile/forms/report.rkt rename qi-sdk/profile/{forms => loading}/loadlib.rkt (100%) create mode 100755 qi-sdk/profile/report.rkt diff --git a/qi-sdk/profile/forms/benchmarks.rkt b/qi-sdk/profile/forms/benchmarks.rkt index 593e1eba1..84e8d0713 100755 --- a/qi-sdk/profile/forms/benchmarks.rkt +++ b/qi-sdk/profile/forms/benchmarks.rkt @@ -11,13 +11,18 @@ utility macros `run-benchmark` or `run-summary-benchmark`, and provides it one of the helper functions `check-value` (to invoke the form with a single value each time during benchmarking) or `check-values` (to invoke the form with multiple values each time -during benchmarking). +during benchmarking). Note that at the moment, as a hack for +convenience, `run-benchmark` expects a function with the name of the +form being benchmarked _prefixed with tilde_. This is to avoid name +collisions between this function and the Qi form with the same +name. Basically, just follow one of the numerous examples in this +module to see what this is referring to. 2. Require the submodule in the `main` submodule with an appropriate prefix (see other examples) 3. Add the required `run` function to the `env` hash in the main -submodule. This will ensure that it gets picked up when the benchmarks +submodule. This will ensure that it gets picked up when the benchmarks for the forms are run. |# @@ -884,3 +889,164 @@ for the forms are run. (run-benchmark ~clos check-values 100000))) + +(module main racket/base + + (provide benchmark) + + (require racket/match + racket/format + relation + qi + json + csv-writing + (only-in "../util.rkt" + only-if + for/call)) + (require + (prefix-in one-of?: (submod ".." one-of?)) + (prefix-in and: (submod ".." and)) + (prefix-in or: (submod ".." or)) + (prefix-in not: (submod ".." not)) + (prefix-in and%: (submod ".." and%)) + (prefix-in or%: (submod ".." or%)) + (prefix-in group: (submod ".." group)) + (prefix-in count: (submod ".." count)) + (prefix-in relay: (submod ".." relay)) + (prefix-in relay*: (submod ".." relay*)) + (prefix-in amp: (submod ".." amp)) + (prefix-in ground: (submod ".." ground)) + (prefix-in thread: (submod ".." thread)) + (prefix-in thread-right: (submod ".." thread-right)) + (prefix-in crossover: (submod ".." crossover)) + (prefix-in all: (submod ".." all)) + (prefix-in any: (submod ".." any)) + (prefix-in none: (submod ".." none)) + (prefix-in all?: (submod ".." all?)) + (prefix-in any?: (submod ".." any?)) + (prefix-in none?: (submod ".." none?)) + (prefix-in collect: (submod ".." collect)) + (prefix-in sep: (submod ".." sep)) + (prefix-in gen: (submod ".." gen)) + (prefix-in esc: (submod ".." esc)) + (prefix-in AND: (submod ".." AND)) + (prefix-in OR: (submod ".." OR)) + (prefix-in NOT: (submod ".." NOT)) + (prefix-in NAND: (submod ".." NAND)) + (prefix-in NOR: (submod ".." NOR)) + (prefix-in XOR: (submod ".." XOR)) + (prefix-in XNOR: (submod ".." XNOR)) + (prefix-in tee: (submod ".." tee)) + (prefix-in try: (submod ".." try)) + (prefix-in currying: (submod ".." currying)) + (prefix-in template: (submod ".." template)) + (prefix-in catchall-template: (submod ".." catchall-template)) + (prefix-in if: (submod ".." if)) + (prefix-in when: (submod ".." when)) + (prefix-in unless: (submod ".." unless)) + (prefix-in switch: (submod ".." switch)) + (prefix-in sieve: (submod ".." sieve)) + (prefix-in partition: (submod ".." partition)) + (prefix-in gate: (submod ".." gate)) + (prefix-in input-aliases: (submod ".." input-aliases)) + (prefix-in fanout: (submod ".." fanout)) + (prefix-in inverter: (submod ".." inverter)) + (prefix-in feedback: (submod ".." feedback)) + (prefix-in select: (submod ".." select)) + (prefix-in block: (submod ".." block)) + (prefix-in bundle: (submod ".." bundle)) + (prefix-in effect: (submod ".." effect)) + (prefix-in live?: (submod ".." live?)) + (prefix-in rectify: (submod ".." rectify)) + (prefix-in pass: (submod ".." pass)) + (prefix-in foldl: (submod ".." foldl)) + (prefix-in foldr: (submod ".." foldr)) + (prefix-in loop: (submod ".." loop)) + (prefix-in loop2: (submod ".." loop2)) + (prefix-in apply: (submod ".." apply)) + (prefix-in clos: (submod ".." clos))) + + ;; It would be great if we could get the value of a variable + ;; by using its (string) name, but (eval (string->symbol name)) + ;; doesn't find it. So instead, we reify the "lexical environment" + ;; here manually, so that the values can be looked up at runtime + ;; based on the string names (note that the value is always the key + ;; + ":" + "run") + (define env + (hash + "one-of?" one-of?:run + "and" and:run + "or" or:run + "not" not:run + "and%" and%:run + "or%" or%:run + "group" group:run + "count" count:run + "relay" relay:run + "relay*" relay*:run + "amp" amp:run + "ground" ground:run + "thread" thread:run + "thread-right" thread-right:run + "crossover" crossover:run + "all" all:run + "any" any:run + "none" none:run + "all?" all?:run + "any?" any?:run + "none?" none?:run + "collect" collect:run + "sep" sep:run + "gen" gen:run + "esc" esc:run + "AND" AND:run + "OR" OR:run + "NOT" NOT:run + "NAND" NAND:run + "NOR" NOR:run + "XOR" XOR:run + "XNOR" XNOR:run + "tee" tee:run + "try" try:run + "currying" currying:run + "template" template:run + "catchall-template" catchall-template:run + "if" if:run + "when" when:run + "unless" unless:run + "switch" switch:run + "sieve" sieve:run + "partition" partition:run + "gate" gate:run + "input-aliases" input-aliases:run + "fanout" fanout:run + "inverter" inverter:run + "feedback" feedback:run + "select" select:run + "block" block:run + "bundle" bundle:run + "effect" effect:run + "live?" live?:run + "rectify" rectify:run + "pass" pass:run + "foldl" foldl:run + "foldr" foldr:run + "loop" loop:run + "loop2" loop2:run + "apply" apply:run + "clos" clos:run)) + + (define (benchmark forms) + (define fs (~>> (forms) + (only-if null? + (gen (hash-keys env))) + (sort <))) + (define forms-data (for/list ([f (in-list fs)]) + (match-let ([(list name ms) ((hash-ref env f))]) + ;; Print results "live" to STDERR, with + ;; only the actual output (if desired) + ;; going to STDOUT at the end. + (displayln (~a name ": " ms " ms") + (current-error-port)) + (hash 'name name 'unit "ms" 'value ms)))) + forms-data)) diff --git a/qi-sdk/profile/forms/report.rkt b/qi-sdk/profile/forms/report.rkt deleted file mode 100755 index e32073740..000000000 --- a/qi-sdk/profile/forms/report.rkt +++ /dev/null @@ -1,246 +0,0 @@ -#!/usr/bin/env racket -#lang cli - -#| -To add a benchmark for a new form: - -1. Add a submodule for it in benchmarks.rkt which provides a `run` -function taking no arguments. This function will be expected to -exercise the new form and return a time taken. The `run` function -typically uses one of the utility macros `run-benchmark` or -`run-summary-benchmark`, and provides it one of the helper functions -`check-value` (to invoke the form with a single value each time during -benchmarking) or `check-values` (to invoke the form with multiple -values each time during benchmarking). Note that at the moment, as a -hack for convenience, `run-benchmark` expects a function with the name -of the form being benchmarked _prefixed with tilde_. This is to avoid -name collisions between this function and the Qi form with the same -name. Basically, just follow one of the numerous examples in this -module to see what this is referring to. - -2. Require the submodule in the present module with an appropriate -prefix (see other examples) - -3. Add the required `run` function to the `env` hash below. This will -ensure that it gets picked up when the benchmarks for the forms are -run. -|# - -(require - (prefix-in one-of?: (submod "benchmarks.rkt" one-of?)) - (prefix-in and: (submod "benchmarks.rkt" and)) - (prefix-in or: (submod "benchmarks.rkt" or)) - (prefix-in not: (submod "benchmarks.rkt" not)) - (prefix-in and%: (submod "benchmarks.rkt" and%)) - (prefix-in or%: (submod "benchmarks.rkt" or%)) - (prefix-in group: (submod "benchmarks.rkt" group)) - (prefix-in count: (submod "benchmarks.rkt" count)) - (prefix-in relay: (submod "benchmarks.rkt" relay)) - (prefix-in relay*: (submod "benchmarks.rkt" relay*)) - (prefix-in amp: (submod "benchmarks.rkt" amp)) - (prefix-in ground: (submod "benchmarks.rkt" ground)) - (prefix-in thread: (submod "benchmarks.rkt" thread)) - (prefix-in thread-right: (submod "benchmarks.rkt" thread-right)) - (prefix-in crossover: (submod "benchmarks.rkt" crossover)) - (prefix-in all: (submod "benchmarks.rkt" all)) - (prefix-in any: (submod "benchmarks.rkt" any)) - (prefix-in none: (submod "benchmarks.rkt" none)) - (prefix-in all?: (submod "benchmarks.rkt" all?)) - (prefix-in any?: (submod "benchmarks.rkt" any?)) - (prefix-in none?: (submod "benchmarks.rkt" none?)) - (prefix-in collect: (submod "benchmarks.rkt" collect)) - (prefix-in sep: (submod "benchmarks.rkt" sep)) - (prefix-in gen: (submod "benchmarks.rkt" gen)) - (prefix-in esc: (submod "benchmarks.rkt" esc)) - (prefix-in AND: (submod "benchmarks.rkt" AND)) - (prefix-in OR: (submod "benchmarks.rkt" OR)) - (prefix-in NOT: (submod "benchmarks.rkt" NOT)) - (prefix-in NAND: (submod "benchmarks.rkt" NAND)) - (prefix-in NOR: (submod "benchmarks.rkt" NOR)) - (prefix-in XOR: (submod "benchmarks.rkt" XOR)) - (prefix-in XNOR: (submod "benchmarks.rkt" XNOR)) - (prefix-in tee: (submod "benchmarks.rkt" tee)) - (prefix-in try: (submod "benchmarks.rkt" try)) - (prefix-in currying: (submod "benchmarks.rkt" currying)) - (prefix-in template: (submod "benchmarks.rkt" template)) - (prefix-in catchall-template: (submod "benchmarks.rkt" catchall-template)) - (prefix-in if: (submod "benchmarks.rkt" if)) - (prefix-in when: (submod "benchmarks.rkt" when)) - (prefix-in unless: (submod "benchmarks.rkt" unless)) - (prefix-in switch: (submod "benchmarks.rkt" switch)) - (prefix-in sieve: (submod "benchmarks.rkt" sieve)) - (prefix-in partition: (submod "benchmarks.rkt" partition)) - (prefix-in gate: (submod "benchmarks.rkt" gate)) - (prefix-in input-aliases: (submod "benchmarks.rkt" input-aliases)) - (prefix-in fanout: (submod "benchmarks.rkt" fanout)) - (prefix-in inverter: (submod "benchmarks.rkt" inverter)) - (prefix-in feedback: (submod "benchmarks.rkt" feedback)) - (prefix-in select: (submod "benchmarks.rkt" select)) - (prefix-in block: (submod "benchmarks.rkt" block)) - (prefix-in bundle: (submod "benchmarks.rkt" bundle)) - (prefix-in effect: (submod "benchmarks.rkt" effect)) - (prefix-in live?: (submod "benchmarks.rkt" live?)) - (prefix-in rectify: (submod "benchmarks.rkt" rectify)) - (prefix-in pass: (submod "benchmarks.rkt" pass)) - (prefix-in foldl: (submod "benchmarks.rkt" foldl)) - (prefix-in foldr: (submod "benchmarks.rkt" foldr)) - (prefix-in loop: (submod "benchmarks.rkt" loop)) - (prefix-in loop2: (submod "benchmarks.rkt" loop2)) - (prefix-in apply: (submod "benchmarks.rkt" apply)) - (prefix-in clos: (submod "benchmarks.rkt" clos))) - -(require "loadlib.rkt" - "regression.rkt") - -(require racket/match - racket/format - relation - qi - json - csv-writing - (only-in "../util.rkt" - only-if - for/call)) - -;; It would be great if we could get the value of a variable -;; by using its (string) name, but (eval (string->symbol name)) -;; doesn't find it. So instead, we reify the "lexical environment" -;; here manually, so that the values can be looked up at runtime -;; based on the string names (note that the value is always the key -;; + ":" + "run") -(define env - (hash - "one-of?" one-of?:run - "and" and:run - "or" or:run - "not" not:run - "and%" and%:run - "or%" or%:run - "group" group:run - "count" count:run - "relay" relay:run - "relay*" relay*:run - "amp" amp:run - "ground" ground:run - "thread" thread:run - "thread-right" thread-right:run - "crossover" crossover:run - "all" all:run - "any" any:run - "none" none:run - "all?" all?:run - "any?" any?:run - "none?" none?:run - "collect" collect:run - "sep" sep:run - "gen" gen:run - "esc" esc:run - "AND" AND:run - "OR" OR:run - "NOT" NOT:run - "NAND" NAND:run - "NOR" NOR:run - "XOR" XOR:run - "XNOR" XNOR:run - "tee" tee:run - "try" try:run - "currying" currying:run - "template" template:run - "catchall-template" catchall-template:run - "if" if:run - "when" when:run - "unless" unless:run - "switch" switch:run - "sieve" sieve:run - "partition" partition:run - "gate" gate:run - "input-aliases" input-aliases:run - "fanout" fanout:run - "inverter" inverter:run - "feedback" feedback:run - "select" select:run - "block" block:run - "bundle" bundle:run - "effect" effect:run - "live?" live?:run - "rectify" rectify:run - "pass" pass:run - "foldl" foldl:run - "foldr" foldr:run - "loop" loop:run - "loop2" loop2:run - "apply" apply:run - "clos" clos:run)) - -(define (write-csv data) - (~> (data) - △ - (>< (~> (-< (hash-ref 'name) - (hash-ref 'unit) - (hash-ref 'value)) - ▽)) - (-< '(name unit value) - _) - ▽ - display-table)) - -(flag (forms #:param [forms null] name) - ("-f" "--form" "Forms to benchmark") - (forms (cons name (forms)))) - -(constraint (multi forms)) - -(help - (usage - (~a "Run benchmarks for individual Qi forms " - "(by default, all of them), reporting the results " - "in a configurable output format."))) - -(flag (output-format #:param [output-format ""] fmt) - ("-o" - "--format" - "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") - (output-format fmt)) - -(flag (regression-file #:param [regression-file #f] reg-file) - ("-r" "--regression" "'Before' data to compute regression against") - (regression-file reg-file)) - -(define (format-output output) - ;; Note: this is a case where declaring "constraints" on the CLI args - ;; would be useful, instead of using the ad hoc fallback `else` check here - ;; https://github.com/countvajhula/cli/issues/6 - (cond - [(equal? (output-format) "json") (write-json output)] - [(equal? (output-format) "csv") (write-csv output)] - [(equal? (output-format) "") (values)] - [else (error (~a "Unrecognized format: " (output-format) "!"))])) - -(program (main) - (define fs (~>> ((forms)) - (only-if null? - (gen (hash-keys env))) - (sort <))) - (define forms-data (for/list ([f (in-list fs)]) - (match-let ([(list name ms) ((hash-ref env f))]) - ;; Print results "live" to STDERR, with - ;; only the actual output (if desired) - ;; going to STDOUT at the end. - (displayln (~a name ": " ms " ms") - (current-error-port)) - (hash 'name name 'unit "ms" 'value ms)))) - (define require-data (list (hash 'name "(require qi)" - 'unit "ms" - 'value (time-module-ms "qi")))) - (let ([output (append forms-data require-data)]) - - (if (regression-file) - (let ([before (parse-benchmarks (parse-json-file (regression-file)))] - [after (parse-benchmarks output)]) - (compute-regression before after)) - (format-output output)))) - -;; To run benchmarks for a form interactively, use e.g.: -;; (run main #("-f" "fanout")) - -(run main) diff --git a/qi-sdk/profile/forms/loadlib.rkt b/qi-sdk/profile/loading/loadlib.rkt similarity index 100% rename from qi-sdk/profile/forms/loadlib.rkt rename to qi-sdk/profile/loading/loadlib.rkt diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt new file mode 100755 index 000000000..72a3e3edd --- /dev/null +++ b/qi-sdk/profile/report.rkt @@ -0,0 +1,79 @@ +#!/usr/bin/env racket +#lang cli + +(require "loading/loadlib.rkt" + "forms/regression.rkt") + +(require racket/match + racket/format + relation + qi + json + csv-writing + (only-in "util.rkt" + only-if + for/call)) +(require + (submod "forms/benchmarks.rkt" main)) + +(define (write-csv data) + (~> (data) + △ + (>< (~> (-< (hash-ref 'name) + (hash-ref 'unit) + (hash-ref 'value)) + ▽)) + (-< '(name unit value) + _) + ▽ + display-table)) + +(flag (forms #:param [forms null] name) + ("-f" "--form" "Forms to benchmark") + (forms (cons name (forms)))) + +(constraint (multi forms)) + +(help + (usage + (~a "Run benchmarks for individual Qi forms " + "(by default, all of them), reporting the results " + "in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-o" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(define (format-output output) + ;; Note: this is a case where declaring "constraints" on the CLI args + ;; would be useful, instead of using the ad hoc fallback `else` check here + ;; https://github.com/countvajhula/cli/issues/6 + (cond + [(equal? (output-format) "json") (write-json output)] + [(equal? (output-format) "csv") (write-csv output)] + [(equal? (output-format) "") (values)] + [else (error (~a "Unrecognized format: " (output-format) "!"))])) + +(program (main) + (define forms-data (benchmark (forms))) + (define require-data (list (hash 'name "(require qi)" + 'unit "ms" + 'value (time-module-ms "qi")))) + (let ([output (append forms-data require-data)]) + + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (compute-regression before after)) + (format-output output)))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-f" "fanout")) + +(run main) From 3c0ebcfe50630d3c6ead866f43b8cd06ccf1cb7d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 20:05:40 -0800 Subject: [PATCH 148/338] Organize scripts to generate performance reports Have separate scripts to generate reports of different aspects, to preserve separation of concerns. This results in some duplication of configuration, though, which is probably best avoided via some improvements to the cli library. Follow the general pattern of echoing live results to STDERR and actual formatted output to STDOUT. --- .github/workflows/benchmarks.yml | 2 +- Makefile | 18 +++++--- qi-sdk/profile/forms/report.rkt | 51 +++++++++++++++++++++ qi-sdk/profile/loading/loadlib.rkt | 12 ++++- qi-sdk/profile/loading/report.rkt | 39 ++++++++++++++++ qi-sdk/profile/{forms => }/regression.rkt | 0 qi-sdk/profile/report.rkt | 55 +++++++++-------------- qi-sdk/profile/util.rkt | 29 +++++++++++- 8 files changed, 162 insertions(+), 44 deletions(-) create mode 100755 qi-sdk/profile/forms/report.rkt create mode 100755 qi-sdk/profile/loading/report.rkt rename qi-sdk/profile/{forms => }/regression.rkt (100%) diff --git a/.github/workflows/benchmarks.yml b/.github/workflows/benchmarks.yml index f9974993e..a8645f324 100644 --- a/.github/workflows/benchmarks.yml +++ b/.github/workflows/benchmarks.yml @@ -25,7 +25,7 @@ jobs: run: make install-sdk - name: Run benchmark shell: 'bash --noprofile --norc -eo pipefail {0}' - run: make form-performance-report | tee benchmarks.txt + run: make performance-report | tee benchmarks.txt - name: Store benchmark result uses: benchmark-action/github-action-benchmark@v1 with: diff --git a/Makefile b/Makefile index 3a94763a8..102bb2aab 100644 --- a/Makefile +++ b/Makefile @@ -42,8 +42,8 @@ help: @echo "profile-competitive - Run competitive benchmarks" @echo "profile-forms - Run benchmarks for individual Qi forms" @echo "profile-selected-forms - Run benchmarks for Qi forms by name (command only)" - @echo "form-performance-report - Run benchmarks for Qi forms and produce results for use in CI and for measuring regression" - @echo " For use in regression: make form-performance-report > /path/to/before.json" + @echo "performance-report - Run benchmarks for Qi forms and produce results for use in CI and for measuring regression" + @echo " For use in regression: make performance-report > /path/to/before.json" @echo "performance-regression-report - Run benchmarks for Qi forms against a reference report." @echo " make performance-regression-report REF=/path/to/before.json" @@ -171,10 +171,14 @@ cover-coveralls: profile-forms: echo "Profiling forms..." - racket $(PACKAGE-NAME)-sdk/profile/forms.rkt + racket $(PACKAGE-NAME)-sdk/profile/forms/report.rkt + +profile-loading: + echo "Profiling module loading..." + racket $(PACKAGE-NAME)-sdk/profile/loading/report.rkt profile-selected-forms: - @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/forms.rkt' directly, with -f form-name for each form." + @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/forms/report.rkt' directly, with -f form-name for each form." profile-competitive: echo "Running competitive benchmarks..." @@ -182,10 +186,10 @@ profile-competitive: profile: profile-competitive profile-forms -form-performance-report: - @racket $(PACKAGE-NAME)-sdk/profile/report.rkt +performance-report: + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -o json performance-regression-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile form-performance-report performance-regression-report +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile performance-report performance-regression-report diff --git a/qi-sdk/profile/forms/report.rkt b/qi-sdk/profile/forms/report.rkt new file mode 100755 index 000000000..753a8166d --- /dev/null +++ b/qi-sdk/profile/forms/report.rkt @@ -0,0 +1,51 @@ +#!/usr/bin/env racket +#lang cli + +(require "../regression.rkt") + +(require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call + write-csv + format-output)) +(require + (submod "benchmarks.rkt" main)) + +(flag (forms #:param [forms null] name) + ("-f" "--form" "Forms to benchmark") + (forms (cons name (forms)))) + +(constraint (multi forms)) + +(help + (usage + (~a "Run benchmarks for individual Qi forms " + "(by default, all of them), reporting the results " + "in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-o" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(program (main) + (let ([output (benchmark (forms))]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (compute-regression before after)) + (format-output output (output-format))))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-f" "fanout")) + +(run main) diff --git a/qi-sdk/profile/loading/loadlib.rkt b/qi-sdk/profile/loading/loadlib.rkt index 4ebdaed6d..1541f04af 100755 --- a/qi-sdk/profile/loading/loadlib.rkt +++ b/qi-sdk/profile/loading/loadlib.rkt @@ -2,7 +2,8 @@ #lang cli (provide time-racket - time-module-ms) + time-module-ms + profile-load) (require racket/port racket/format) @@ -41,6 +42,15 @@ what remains is just the time contributed by requiring the specified module. (- (time-racket module-name) (time-racket)))) +(define (profile-load module-name) + (let ([name (~a "(require " module-name ")")] + [ms (time-module-ms module-name)]) + (displayln (~a name ": " ms " ms") + (current-error-port)) + (hash 'name name + 'unit "ms" + 'value ms))) + (program (time-require module-name) (displayln (~a (time-module-ms module-name) " ms"))) diff --git a/qi-sdk/profile/loading/report.rkt b/qi-sdk/profile/loading/report.rkt new file mode 100755 index 000000000..f6542cd10 --- /dev/null +++ b/qi-sdk/profile/loading/report.rkt @@ -0,0 +1,39 @@ +#!/usr/bin/env racket +#lang cli + +(require "../regression.rkt" + "loadlib.rkt") + +(require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call + write-csv + format-output)) + +(help + (usage + (~a "Measure module load time, i.e. the time taken by (require qi)."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-o" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(program (main) + (let ([output (profile-load "qi")]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (compute-regression before after)) + (format-output output (output-format))))) + +(run main) diff --git a/qi-sdk/profile/forms/regression.rkt b/qi-sdk/profile/regression.rkt similarity index 100% rename from qi-sdk/profile/forms/regression.rkt rename to qi-sdk/profile/regression.rkt diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 72a3e3edd..6150bb36a 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -2,32 +2,20 @@ #lang cli (require "loading/loadlib.rkt" - "forms/regression.rkt") + "regression.rkt") (require racket/match racket/format relation qi - json - csv-writing (only-in "util.rkt" only-if - for/call)) + for/call + write-csv + format-output)) (require (submod "forms/benchmarks.rkt" main)) -(define (write-csv data) - (~> (data) - △ - (>< (~> (-< (hash-ref 'name) - (hash-ref 'unit) - (hash-ref 'value)) - ▽)) - (-< '(name unit value) - _) - ▽ - display-table)) - (flag (forms #:param [forms null] name) ("-f" "--form" "Forms to benchmark") (forms (cons name (forms)))) @@ -46,32 +34,33 @@ "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") (output-format fmt)) +(flag (type #:param [report-type "all"] typ) + ("-t" + "--type" + "Type of report, either `forms`, `loading` or `all` (default `all`)") + (report-type typ)) + (flag (regression-file #:param [regression-file #f] reg-file) ("-r" "--regression" "'Before' data to compute regression against") (regression-file reg-file)) -(define (format-output output) - ;; Note: this is a case where declaring "constraints" on the CLI args - ;; would be useful, instead of using the ad hoc fallback `else` check here - ;; https://github.com/countvajhula/cli/issues/6 - (cond - [(equal? (output-format) "json") (write-json output)] - [(equal? (output-format) "csv") (write-csv output)] - [(equal? (output-format) "") (values)] - [else (error (~a "Unrecognized format: " (output-format) "!"))])) - +;; Note: much of this file is duplicated across forms/report.rkt +;; and loading/report.rkt. It could be avoided if we had +;; "composition of commands", see: +;; https://github.com/countvajhula/cli/issues/3 (program (main) - (define forms-data (benchmark (forms))) - (define require-data (list (hash 'name "(require qi)" - 'unit "ms" - 'value (time-module-ms "qi")))) - (let ([output (append forms-data require-data)]) - + (let* ([forms-data (if (member? (report-type) (list "all" "forms")) + (benchmark (forms)) + null)] + [require-data (if (member? (report-type) (list "all" "loading")) + (list (profile-load "qi")) + null)] + [output (append forms-data require-data)]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) (compute-regression before after)) - (format-output output)))) + (format-output output (output-format))))) ;; To run benchmarks for a form interactively, use e.g.: ;; (run main #("-f" "fanout")) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index 17fd1c805..40c8aa61b 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -10,7 +10,9 @@ run-summary-benchmark run-competitive-benchmark (for-space qi only-if) - for/call) + for/call + write-csv + format-output) (require (only-in racket/list range @@ -21,7 +23,8 @@ cycle take in) - racket/function + csv-writing + json racket/format syntax/parse/define (for-syntax racket/base @@ -136,3 +139,25 @@ [label (list "λ" "☯")]) (let ([ms (measure runner f n-times)]) (displayln (~a label ": " ms " ms")))))) + +(define (write-csv data) + (~> (data) + △ + (>< (~> (-< (hash-ref 'name) + (hash-ref 'unit) + (hash-ref 'value)) + ▽)) + (-< '(name unit value) + _) + ▽ + display-table)) + +(define (format-output output fmt) + ;; Note: this is a case where declaring "constraints" on the CLI args + ;; would be useful, instead of using the ad hoc fallback `else` check here + ;; https://github.com/countvajhula/cli/issues/6 + (cond + [(equal? fmt "json") (write-json output)] + [(equal? fmt "csv") (write-csv output)] + [(equal? fmt "") (values)] + [else (error (~a "Unrecognized format: " fmt "!"))])) From 021993ff1536687a1aac857fb96ca8250df9b38d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 20:31:45 -0800 Subject: [PATCH 149/338] Use require-latency library instead of measuring load time locally --- qi-sdk/info.rkt | 1 + qi-sdk/profile/loading/loadlib.rkt | 50 +++--------------------------- 2 files changed, 5 insertions(+), 46 deletions(-) diff --git a/qi-sdk/info.rkt b/qi-sdk/info.rkt index b79b9ef6c..ea3ccec2d 100644 --- a/qi-sdk/info.rkt +++ b/qi-sdk/info.rkt @@ -10,6 +10,7 @@ "collections-lib" "relation-lib" "csv-writing" + "require-latency" "cover" "cover-coveralls")) (define build-deps '()) diff --git a/qi-sdk/profile/loading/loadlib.rkt b/qi-sdk/profile/loading/loadlib.rkt index 1541f04af..b0dae806e 100755 --- a/qi-sdk/profile/loading/loadlib.rkt +++ b/qi-sdk/profile/loading/loadlib.rkt @@ -1,58 +1,16 @@ #!/usr/bin/env racket -#lang cli +#lang racket/base -(provide time-racket - time-module-ms - profile-load) +(provide profile-load) -(require racket/port +(require pkg/require-latency racket/format) -#| -This works by: -1. Running `racket -l ` and `racket -l racket/base` independently -2. Subtracting the latter from the former. -3. Printing that result in milliseconds. - -where is the argument you specified at the command line, -e.g. ./loadlib.rkt racket/list - -The idea is to subtract out the contribution from racket/base, so that -what remains is just the time contributed by requiring the specified module. -|# - -(define (time-racket [module-name "racket/base"]) - (define-values (sp out in err) - (subprocess #f #f #f (find-executable-path "time") "-p" (find-executable-path "racket") "-l" module-name)) - (define result (port->string err)) - (define seconds (string->number - (car - (regexp-match #px"[\\d|\\.]+" - (car - (regexp-match #rx"(?m:^real.*)" - result)))))) - (close-input-port out) - (close-output-port in) - (close-input-port err) - (subprocess-wait sp) - seconds) - -(define (time-module-ms module-name) - (* 1000 - (- (time-racket module-name) - (time-racket)))) - (define (profile-load module-name) (let ([name (~a "(require " module-name ")")] - [ms (time-module-ms module-name)]) + [ms (cdr (time-module-ms module-name))]) (displayln (~a name ": " ms " ms") (current-error-port)) (hash 'name name 'unit "ms" 'value ms))) - -(program (time-require module-name) - (displayln (~a (time-module-ms module-name) " ms"))) - -(module+ main - (run time-require)) From 065f41cdbd1493de2939a91989c85d4956108fa4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 20:39:48 -0800 Subject: [PATCH 150/338] move competitive benchmarks into a separate folder --- Makefile | 2 +- qi-sdk/profile/{ => competitive}/builtin.rkt | 0 qi-sdk/profile/{ => competitive}/competitive.rkt | 2 +- qi-sdk/profile/{ => competitive}/qi.rkt | 0 4 files changed, 2 insertions(+), 2 deletions(-) rename qi-sdk/profile/{ => competitive}/builtin.rkt (100%) rename qi-sdk/profile/{ => competitive}/competitive.rkt (98%) rename qi-sdk/profile/{ => competitive}/qi.rkt (100%) diff --git a/Makefile b/Makefile index 102bb2aab..f40cbd0b9 100644 --- a/Makefile +++ b/Makefile @@ -182,7 +182,7 @@ profile-selected-forms: profile-competitive: echo "Running competitive benchmarks..." - racket $(PACKAGE-NAME)-sdk/profile/competitive.rkt + racket $(PACKAGE-NAME)-sdk/profile/competitive/competitive.rkt profile: profile-competitive profile-forms diff --git a/qi-sdk/profile/builtin.rkt b/qi-sdk/profile/competitive/builtin.rkt similarity index 100% rename from qi-sdk/profile/builtin.rkt rename to qi-sdk/profile/competitive/builtin.rkt diff --git a/qi-sdk/profile/competitive.rkt b/qi-sdk/profile/competitive/competitive.rkt similarity index 98% rename from qi-sdk/profile/competitive.rkt rename to qi-sdk/profile/competitive/competitive.rkt index 833e5bf80..8547d11c0 100755 --- a/qi-sdk/profile/competitive.rkt +++ b/qi-sdk/profile/competitive/competitive.rkt @@ -12,7 +12,7 @@ (prefix-in q: "qi.rkt") (prefix-in b: "builtin.rkt")) -(require "util.rkt") +(require "../util.rkt") (displayln "\nRunning flat benchmarks...") diff --git a/qi-sdk/profile/qi.rkt b/qi-sdk/profile/competitive/qi.rkt similarity index 100% rename from qi-sdk/profile/qi.rkt rename to qi-sdk/profile/competitive/qi.rkt From ac10e20b1c6fb5753ec3641f546e9ffab74a7879 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 20:40:18 -0800 Subject: [PATCH 151/338] update phonies in makefile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index f40cbd0b9..d96e20b05 100644 --- a/Makefile +++ b/Makefile @@ -192,4 +192,4 @@ performance-report: performance-regression-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile performance-report performance-regression-report +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-loading profile-selected-forms profile-competitive profile performance-report performance-regression-report From 40e406a5f6fcddf1a0c47fab1feb1abef99e9378 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 20:44:20 -0800 Subject: [PATCH 152/338] merge some require forms --- qi-sdk/profile/competitive/competitive.rkt | 5 ++--- qi-sdk/profile/forms/report.rkt | 8 +++----- qi-sdk/profile/loading/report.rkt | 7 +++---- qi-sdk/profile/report.rkt | 11 +++++------ 4 files changed, 13 insertions(+), 18 deletions(-) diff --git a/qi-sdk/profile/competitive/competitive.rkt b/qi-sdk/profile/competitive/competitive.rkt index 8547d11c0..9a74b39ec 100755 --- a/qi-sdk/profile/competitive/competitive.rkt +++ b/qi-sdk/profile/competitive/competitive.rkt @@ -10,9 +10,8 @@ (only-in racket/function curryr) (prefix-in q: "qi.rkt") - (prefix-in b: "builtin.rkt")) - -(require "../util.rkt") + (prefix-in b: "builtin.rkt") + "../util.rkt") (displayln "\nRunning flat benchmarks...") diff --git a/qi-sdk/profile/forms/report.rkt b/qi-sdk/profile/forms/report.rkt index 753a8166d..73e96eea9 100755 --- a/qi-sdk/profile/forms/report.rkt +++ b/qi-sdk/profile/forms/report.rkt @@ -1,8 +1,6 @@ #!/usr/bin/env racket #lang cli -(require "../regression.rkt") - (require racket/match racket/format relation @@ -11,9 +9,9 @@ only-if for/call write-csv - format-output)) -(require - (submod "benchmarks.rkt" main)) + format-output) + "../regression.rkt" + (submod "benchmarks.rkt" main)) (flag (forms #:param [forms null] name) ("-f" "--form" "Forms to benchmark") diff --git a/qi-sdk/profile/loading/report.rkt b/qi-sdk/profile/loading/report.rkt index f6542cd10..147b0d62b 100755 --- a/qi-sdk/profile/loading/report.rkt +++ b/qi-sdk/profile/loading/report.rkt @@ -1,9 +1,6 @@ #!/usr/bin/env racket #lang cli -(require "../regression.rkt" - "loadlib.rkt") - (require racket/match racket/format relation @@ -12,7 +9,9 @@ only-if for/call write-csv - format-output)) + format-output) + "../regression.rkt" + "loadlib.rkt") (help (usage diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 6150bb36a..576a73a15 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -1,9 +1,6 @@ #!/usr/bin/env racket #lang cli -(require "loading/loadlib.rkt" - "regression.rkt") - (require racket/match racket/format relation @@ -12,9 +9,11 @@ only-if for/call write-csv - format-output)) -(require - (submod "forms/benchmarks.rkt" main)) + format-output) + + "loading/loadlib.rkt" + "regression.rkt" + (submod "forms/benchmarks.rkt" main)) (flag (forms #:param [forms null] name) ("-f" "--form" "Forms to benchmark") From cac0d3516aeb21e0a6a5bc502ceef189e95590f8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 21:10:13 -0800 Subject: [PATCH 153/338] categorize performance modules into intrinsic vs competitive --- Makefile | 10 +++++----- qi-sdk/profile/{ => intrinsic}/forms/base.rkt | 4 ++-- qi-sdk/profile/{ => intrinsic}/forms/benchmarks.rkt | 2 +- qi-sdk/profile/{ => intrinsic}/forms/report.rkt | 2 +- qi-sdk/profile/{ => intrinsic}/loading/loadlib.rkt | 0 qi-sdk/profile/{ => intrinsic}/loading/report.rkt | 2 +- qi-sdk/profile/{ => intrinsic}/regression.rkt | 0 qi-sdk/profile/{ => intrinsic}/report.rkt | 2 +- 8 files changed, 11 insertions(+), 11 deletions(-) rename qi-sdk/profile/{ => intrinsic}/forms/base.rkt (67%) rename qi-sdk/profile/{ => intrinsic}/forms/benchmarks.rkt (99%) rename qi-sdk/profile/{ => intrinsic}/forms/report.rkt (97%) rename qi-sdk/profile/{ => intrinsic}/loading/loadlib.rkt (100%) rename qi-sdk/profile/{ => intrinsic}/loading/report.rkt (96%) rename qi-sdk/profile/{ => intrinsic}/regression.rkt (100%) rename qi-sdk/profile/{ => intrinsic}/report.rkt (98%) diff --git a/Makefile b/Makefile index d96e20b05..9014d2bc6 100644 --- a/Makefile +++ b/Makefile @@ -171,14 +171,14 @@ cover-coveralls: profile-forms: echo "Profiling forms..." - racket $(PACKAGE-NAME)-sdk/profile/forms/report.rkt + racket $(PACKAGE-NAME)-sdk/profile/intrinsic/forms/report.rkt profile-loading: echo "Profiling module loading..." - racket $(PACKAGE-NAME)-sdk/profile/loading/report.rkt + racket $(PACKAGE-NAME)-sdk/profile/intrinsic/loading/report.rkt profile-selected-forms: - @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/forms/report.rkt' directly, with -f form-name for each form." + @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/intrinsic/forms/report.rkt' directly, with -f form-name for each form." profile-competitive: echo "Running competitive benchmarks..." @@ -187,9 +187,9 @@ profile-competitive: profile: profile-competitive profile-forms performance-report: - @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -o json + @racket $(PACKAGE-NAME)-sdk/profile/intrinsic/report.rkt -o json performance-regression-report: - @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) + @racket $(PACKAGE-NAME)-sdk/profile/intrinsic/report.rkt -r $(REF) .PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-loading profile-selected-forms profile-competitive profile performance-report performance-regression-report diff --git a/qi-sdk/profile/forms/base.rkt b/qi-sdk/profile/intrinsic/forms/base.rkt similarity index 67% rename from qi-sdk/profile/forms/base.rkt rename to qi-sdk/profile/intrinsic/forms/base.rkt index 7431b112f..a3ccd9fc7 100644 --- a/qi-sdk/profile/forms/base.rkt +++ b/qi-sdk/profile/intrinsic/forms/base.rkt @@ -2,9 +2,9 @@ (provide (all-from-out racket/base) (all-from-out qi) - (all-from-out "../util.rkt") + (all-from-out "../../util.rkt") sqr) (require qi - "../util.rkt" + "../../util.rkt" (only-in math sqr)) diff --git a/qi-sdk/profile/forms/benchmarks.rkt b/qi-sdk/profile/intrinsic/forms/benchmarks.rkt similarity index 99% rename from qi-sdk/profile/forms/benchmarks.rkt rename to qi-sdk/profile/intrinsic/forms/benchmarks.rkt index 84e8d0713..0decd7036 100755 --- a/qi-sdk/profile/forms/benchmarks.rkt +++ b/qi-sdk/profile/intrinsic/forms/benchmarks.rkt @@ -900,7 +900,7 @@ for the forms are run. qi json csv-writing - (only-in "../util.rkt" + (only-in "../../util.rkt" only-if for/call)) (require diff --git a/qi-sdk/profile/forms/report.rkt b/qi-sdk/profile/intrinsic/forms/report.rkt similarity index 97% rename from qi-sdk/profile/forms/report.rkt rename to qi-sdk/profile/intrinsic/forms/report.rkt index 73e96eea9..d55fc1a04 100755 --- a/qi-sdk/profile/forms/report.rkt +++ b/qi-sdk/profile/intrinsic/forms/report.rkt @@ -5,7 +5,7 @@ racket/format relation qi - (only-in "../util.rkt" + (only-in "../../util.rkt" only-if for/call write-csv diff --git a/qi-sdk/profile/loading/loadlib.rkt b/qi-sdk/profile/intrinsic/loading/loadlib.rkt similarity index 100% rename from qi-sdk/profile/loading/loadlib.rkt rename to qi-sdk/profile/intrinsic/loading/loadlib.rkt diff --git a/qi-sdk/profile/loading/report.rkt b/qi-sdk/profile/intrinsic/loading/report.rkt similarity index 96% rename from qi-sdk/profile/loading/report.rkt rename to qi-sdk/profile/intrinsic/loading/report.rkt index 147b0d62b..47cdf2411 100755 --- a/qi-sdk/profile/loading/report.rkt +++ b/qi-sdk/profile/intrinsic/loading/report.rkt @@ -5,7 +5,7 @@ racket/format relation qi - (only-in "../util.rkt" + (only-in "../../util.rkt" only-if for/call write-csv diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/intrinsic/regression.rkt similarity index 100% rename from qi-sdk/profile/regression.rkt rename to qi-sdk/profile/intrinsic/regression.rkt diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/intrinsic/report.rkt similarity index 98% rename from qi-sdk/profile/report.rkt rename to qi-sdk/profile/intrinsic/report.rkt index 576a73a15..a8deeab89 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/intrinsic/report.rkt @@ -5,7 +5,7 @@ racket/format relation qi - (only-in "util.rkt" + (only-in "../util.rkt" only-if for/call write-csv From 612f4a330ef1f9b4d4dea49b880a313258394dcb Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 7 Mar 2023 21:46:41 -0800 Subject: [PATCH 154/338] rename a file for uniformity --- Makefile | 2 +- qi-sdk/profile/competitive/{competitive.rkt => report.rkt} | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) rename qi-sdk/profile/competitive/{competitive.rkt => report.rkt} (93%) diff --git a/Makefile b/Makefile index 9014d2bc6..f9ff618e2 100644 --- a/Makefile +++ b/Makefile @@ -182,7 +182,7 @@ profile-selected-forms: profile-competitive: echo "Running competitive benchmarks..." - racket $(PACKAGE-NAME)-sdk/profile/competitive/competitive.rkt + racket $(PACKAGE-NAME)-sdk/profile/competitive/report.rkt profile: profile-competitive profile-forms diff --git a/qi-sdk/profile/competitive/competitive.rkt b/qi-sdk/profile/competitive/report.rkt similarity index 93% rename from qi-sdk/profile/competitive/competitive.rkt rename to qi-sdk/profile/competitive/report.rkt index 9a74b39ec..711b21a7e 100755 --- a/qi-sdk/profile/competitive/competitive.rkt +++ b/qi-sdk/profile/competitive/report.rkt @@ -15,6 +15,10 @@ (displayln "\nRunning flat benchmarks...") +;; TODO: make these display the results as "side effects" +;; in STDERR like the intrinsic benchmarking scripts. +;; and configurable via CLI flags + (run-competitive-benchmark "Conditionals" check-value cond-fn From febb2b25ab9919a7bd8c58da93e5a61c7e25db81 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 14 Mar 2023 22:38:12 -0700 Subject: [PATCH 155/338] begin refactor of competitive benchmarks for uniformity/tractability --- Makefile | 2 +- qi-sdk/profile/competitive/intrinsic.rkt | 19 +++ .../competitive/{qi.rkt => qi/main.rkt} | 0 .../{builtin.rkt => racket/main.rkt} | 0 qi-sdk/profile/competitive/report.rkt | 122 ++++++------------ qi-sdk/profile/competitive/spec.rkt | 56 ++++++++ qi-sdk/profile/intrinsic/forms/report.rkt | 2 + qi-sdk/profile/util.rkt | 29 ++--- 8 files changed, 132 insertions(+), 98 deletions(-) create mode 100755 qi-sdk/profile/competitive/intrinsic.rkt rename qi-sdk/profile/competitive/{qi.rkt => qi/main.rkt} (100%) rename qi-sdk/profile/competitive/{builtin.rkt => racket/main.rkt} (100%) create mode 100644 qi-sdk/profile/competitive/spec.rkt diff --git a/Makefile b/Makefile index f9ff618e2..0f0de57e6 100644 --- a/Makefile +++ b/Makefile @@ -182,7 +182,7 @@ profile-selected-forms: profile-competitive: echo "Running competitive benchmarks..." - racket $(PACKAGE-NAME)-sdk/profile/competitive/report.rkt + cd $(PACKAGE-NAME)-sdk/profile/competitive; racket report.rkt profile: profile-competitive profile-forms diff --git a/qi-sdk/profile/competitive/intrinsic.rkt b/qi-sdk/profile/competitive/intrinsic.rkt new file mode 100755 index 000000000..5dd6b791e --- /dev/null +++ b/qi-sdk/profile/competitive/intrinsic.rkt @@ -0,0 +1,19 @@ +#!/usr/bin/env racket +#lang cli + +(provide benchmark) + +(require "../util.rkt" + "spec.rkt") + +(define (benchmark language) + (define namespace (make-base-namespace)) + (cond [(eq? 'qi language) (eval '(require "qi/main.rkt") namespace)] + [(eq? 'racket language) (eval '(require "racket/main.rkt") namespace)]) + + (for/list ([spec specs]) + (let ([name (bm-name spec)] + [exerciser (bm-exerciser spec)] + [f (eval (read (open-input-string (bm-target spec))) namespace)] + [n-times (bm-times spec)]) + (run-nonlocal-benchmark name exerciser f n-times)))) diff --git a/qi-sdk/profile/competitive/qi.rkt b/qi-sdk/profile/competitive/qi/main.rkt similarity index 100% rename from qi-sdk/profile/competitive/qi.rkt rename to qi-sdk/profile/competitive/qi/main.rkt diff --git a/qi-sdk/profile/competitive/builtin.rkt b/qi-sdk/profile/competitive/racket/main.rkt similarity index 100% rename from qi-sdk/profile/competitive/builtin.rkt rename to qi-sdk/profile/competitive/racket/main.rkt diff --git a/qi-sdk/profile/competitive/report.rkt b/qi-sdk/profile/competitive/report.rkt index 711b21a7e..575691144 100755 --- a/qi-sdk/profile/competitive/report.rkt +++ b/qi-sdk/profile/competitive/report.rkt @@ -1,80 +1,44 @@ #!/usr/bin/env racket -#lang racket/base - -(require (only-in data/collection - cycle - take - in) - (only-in racket/list - range) - (only-in racket/function - curryr) - (prefix-in q: "qi.rkt") - (prefix-in b: "builtin.rkt") - "../util.rkt") - -(displayln "\nRunning flat benchmarks...") - -;; TODO: make these display the results as "side effects" -;; in STDERR like the intrinsic benchmarking scripts. -;; and configurable via CLI flags - -(run-competitive-benchmark "Conditionals" - check-value - cond-fn - 300000) - -(run-competitive-benchmark "Composition" - check-value - compose-fn - 300000) - -(run-competitive-benchmark "Root Mean Square" - check-list - root-mean-square - 500000) - -(run-competitive-benchmark "Filter-map" - check-list - filter-map-fn - 500000) - -(run-competitive-benchmark "Filter-map values" - check-values - filter-map-values - 500000) - -(run-competitive-benchmark "Double list" - check-list - double-list - 500000) - -(run-competitive-benchmark "Double values" - check-values - double-values - 500000) - -(displayln "\nRunning Recursive benchmarks...") - -(run-competitive-benchmark "Factorial" - check-value - fact - 100000) - -(run-competitive-benchmark "Pingala" - check-value - ping - 10000) - -(define check-value-primes (curryr check-value #(100 200 300))) - -(run-competitive-benchmark "Eratosthenes" - check-value-primes - eratos - 100) - -;; See https://en.wikipedia.org/wiki/Collatz_conjecture -(run-competitive-benchmark "Collatz" - check-value - collatz - 10000) +#lang cli + +(require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call + write-csv + format-output) + "../intrinsic/regression.rkt" + "intrinsic.rkt") + +(help + (usage + (~a "Run competitive benchmarks between Qi and Racket, " + "reporting the results in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-o" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(program (main) + (displayln "\nRunning competitive benchmarks..." (current-error-port)) + + (let ([output (benchmark 'qi)]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (compute-regression before after)) + (format-output output (output-format))))) + +;; ;; To run benchmarks for a form interactively, use e.g.: +;; ;; (run main #("-f" "fanout")) + +(run main) diff --git a/qi-sdk/profile/competitive/spec.rkt b/qi-sdk/profile/competitive/spec.rkt new file mode 100644 index 000000000..4e589fd37 --- /dev/null +++ b/qi-sdk/profile/competitive/spec.rkt @@ -0,0 +1,56 @@ +#lang racket/base + +(provide specs + (struct-out bm)) + +(require "../util.rkt") + +(struct bm (name exerciser target times) + #:transparent) + +(define specs + (list (bm "Conditionals" + check-value + "cond-fn" + 300000) + (bm "Composition" + check-value + "compose-fn" + 300000) + (bm "Root Mean Square" + check-list + "root-mean-square" + 500000) + (bm "Filter-map" + check-list + "filter-map-fn" + 500000) + (bm "Filter-map values" + check-values + "filter-map-values" + 500000) + (bm "Double list" + check-list + "double-list" + 500000) + (bm "Double values" + check-values + "double-values" + 500000) + (bm "Factorial" + check-value + "fact" + 100000) + (bm "Pingala" + check-value + "ping" + 10000) + (bm "Eratosthenes" + check-value-primes + "eratos" + 100) + ;; See https://en.wikipedia.org/wiki/Collatz_conjecture + (bm "Collatz" + check-value + "collatz" + 10000))) diff --git a/qi-sdk/profile/intrinsic/forms/report.rkt b/qi-sdk/profile/intrinsic/forms/report.rkt index d55fc1a04..a21b33af7 100755 --- a/qi-sdk/profile/intrinsic/forms/report.rkt +++ b/qi-sdk/profile/intrinsic/forms/report.rkt @@ -38,6 +38,8 @@ (program (main) (let ([output (benchmark (forms))]) (if (regression-file) + ;; TODO: regression ignores any flags and is a parallel path + ;; it should be properly incorporated into the CLI (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) (compute-regression before after)) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index 40c8aa61b..0ba2951b5 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -3,12 +3,13 @@ (provide average measure check-value + check-value-primes check-list check-values check-two-values run-benchmark run-summary-benchmark - run-competitive-benchmark + run-nonlocal-benchmark (for-space qi only-if) for/call write-csv @@ -17,6 +18,8 @@ (require (only-in racket/list range second) + (only-in racket/function + curryr) (only-in adjutor values->list) (only-in data/collection @@ -58,6 +61,8 @@ (set! i (remainder (add1 i) len)) (fn (vector-ref inputs i))))) +(define check-value-primes (curryr check-value #(100 200 300))) + ;; This uses the same list input each time. Not sure if that ;; may end up being cached at some level and thus obfuscate ;; the results? On the other hand, @@ -122,23 +127,11 @@ ;; Run different implementations of the same benchmark (e.g. a Racket vs a Qi ;; implementation) a specified number of times, and report the time taken ;; by each implementation. -(define-syntax-parse-rule (run-competitive-benchmark name runner f-name n-times) - #:with f-builtin (datum->syntax #'name - (string->symbol - (string-append "b:" - (symbol->string - (syntax->datum #'f-name))))) - #:with f-qi (datum->syntax #'name - (string->symbol - (string-append "q:" - (symbol->string - (syntax->datum #'f-name))))) - (begin - (displayln (~a name ":")) - (for ([f (list f-builtin f-qi)] - [label (list "λ" "☯")]) - (let ([ms (measure runner f n-times)]) - (displayln (~a label ": " ms " ms")))))) +(define (run-nonlocal-benchmark bm-name runner f n-times) + (displayln (~a bm-name ":") (current-error-port)) + (let ([ms (measure runner f n-times)]) + (displayln (~a ms " ms") (current-error-port)) + (hash 'name bm-name 'unit "ms" 'value ms))) (define (write-csv data) (~> (data) From a33d567bcda6f9f3a3cff9120c2eb32ec2b99d1e Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 14 Mar 2023 23:50:38 -0700 Subject: [PATCH 156/338] label a todo so it doesn't get lost --- qi-doc/scribblings/field-guide.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-doc/scribblings/field-guide.scrbl b/qi-doc/scribblings/field-guide.scrbl index a73ba2511..5843ba519 100644 --- a/qi-doc/scribblings/field-guide.scrbl +++ b/qi-doc/scribblings/field-guide.scrbl @@ -342,7 +342,7 @@ Another way to do it is to simply promote the expression out of the nest: (~> (3) (get-f 1)) ] -@;{Update this to reflect new partial application behavior} +@;{TODO: Update this to reflect new partial application behavior} Now, you might, once again, expect this to be treated as a partial application template, so that this would be equivalent to @racket[(get-f 3 1)] and would raise an error. But in fact, since the expression @racket[(get-f 1)] happens to be fully qualified with all the arguments it needs, the currying employed under the hood to implement partial application in this case @seclink["Using_Racket_to_Define_Flows"]{evaluates to a function result right away}. This then receives the value @racket[3], and consequently, this expression produces the correct result. So in sum, it's perhaps best to rely on @racket[esc] in such cases to be as explicit as possible about what you mean, rather than rely on quirks of the implementation that are revealed at this boundary between two languages. From db301e1928a62d401f1b1a5e6e05a04c7bdca8de Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 14 Mar 2023 23:51:49 -0700 Subject: [PATCH 157/338] standardize nonlocal benchmark names for use via CLI --- qi-sdk/profile/competitive/qi/main.rkt | 28 ++++++++--------- qi-sdk/profile/competitive/racket/main.rkt | 30 +++++++++---------- qi-sdk/profile/competitive/spec.rkt | 35 ++++++++-------------- 3 files changed, 41 insertions(+), 52 deletions(-) diff --git a/qi-sdk/profile/competitive/qi/main.rkt b/qi-sdk/profile/competitive/qi/main.rkt index d15594bb6..c4dc012c5 100644 --- a/qi-sdk/profile/competitive/qi/main.rkt +++ b/qi-sdk/profile/competitive/qi/main.rkt @@ -1,13 +1,13 @@ #lang racket/base -(provide cond-fn - compose-fn +(provide conditionals + composition root-mean-square - fact - ping - eratos + factorial + pingala + eratosthenes collatz - filter-map-fn + filter-map filter-map-values double-list double-values) @@ -16,28 +16,28 @@ (only-in racket/list range) qi) -(define-switch cond-fn +(define-switch conditionals [(< 5) sqr] [(> 5) add1] [else _]) -(define-flow compose-fn +(define-flow composition (~> add1 sqr sub1)) (define-flow root-mean-square (~> (-< (~>> △ (>< sqr) +) length) / sqrt)) -(define-switch fact +(define-switch factorial [(< 2) 1] - [else (~> (-< _ (~> sub1 fact)) *)]) + [else (~> (-< _ (~> sub1 factorial)) *)]) -(define-switch ping +(define-switch pingala [(< 2) _] [else (~> (-< sub1 - (- 2)) (>< ping) +)]) + (- 2)) (>< pingala) +)]) -(define-flow (eratos n) +(define-flow (eratosthenes n) (~> (-< (gen null) (~>> add1 (range 2) △)) (feedback (while (~> (block 1) live?)) (then (~> 1> reverse)) @@ -54,7 +54,7 @@ cons)])) -(define-flow filter-map-fn +(define-flow filter-map (~> △ (>< (if odd? sqr ⏚)) ▽)) (define-flow filter-map-values diff --git a/qi-sdk/profile/competitive/racket/main.rkt b/qi-sdk/profile/competitive/racket/main.rkt index 30351831d..4e80ae24f 100644 --- a/qi-sdk/profile/competitive/racket/main.rkt +++ b/qi-sdk/profile/competitive/racket/main.rkt @@ -1,13 +1,13 @@ #lang racket/base -(provide cond-fn - compose-fn +(provide conditionals + composition root-mean-square - fact - ping - eratos + factorial + pingala + eratosthenes collatz - filter-map-fn + filter-map filter-map-values double-list double-values) @@ -16,30 +16,30 @@ racket/list racket/match) -(define (cond-fn x) +(define (conditionals x) (cond [(< x 5) (sqr x)] [(> x 5) (add1 x)] [else x])) -(define (compose-fn v) +(define (composition v) (sub1 (sqr (add1 v)))) (define (root-mean-square vs) (sqrt (/ (apply + (map sqr vs)) (length vs)))) -(define (fact n) +(define (factorial n) (if (< n 2) 1 - (* (fact (sub1 n)) n))) + (* (factorial (sub1 n)) n))) -(define (ping n) +(define (pingala n) (if (< n 2) n - (+ (ping (sub1 n)) - (ping (- n 2))))) + (+ (pingala (sub1 n)) + (pingala (- n 2))))) -(define (eratos n) +(define (eratosthenes n) (let ([lst (range 2 (add1 n))]) (let loop ([rem lst] [result null]) @@ -55,7 +55,7 @@ [(odd? n) (cons n (collatz (+ (* 3 n) 1)))] [(even? n) (cons n (collatz (quotient n 2)))])) -(define (filter-map-fn lst) +(define (filter-map lst) (map sqr (filter odd? lst))) (define (filter-map-values . vs) diff --git a/qi-sdk/profile/competitive/spec.rkt b/qi-sdk/profile/competitive/spec.rkt index 4e589fd37..addaa412d 100644 --- a/qi-sdk/profile/competitive/spec.rkt +++ b/qi-sdk/profile/competitive/spec.rkt @@ -5,52 +5,41 @@ (require "../util.rkt") -(struct bm (name exerciser target times) +(struct bm (name exerciser times) #:transparent) (define specs - (list (bm "Conditionals" + (list (bm "conditionals" check-value - "cond-fn" 300000) - (bm "Composition" + (bm "composition" check-value - "compose-fn" 300000) - (bm "Root Mean Square" + (bm "root-mean-square" check-list - "root-mean-square" 500000) - (bm "Filter-map" + (bm "filter-map" check-list - "filter-map-fn" 500000) - (bm "Filter-map values" + (bm "filter-map-values" check-values - "filter-map-values" 500000) - (bm "Double list" + (bm "double-list" check-list - "double-list" 500000) - (bm "Double values" + (bm "double-values" check-values - "double-values" 500000) - (bm "Factorial" + (bm "factorial" check-value - "fact" 100000) - (bm "Pingala" + (bm "pingala" check-value - "ping" 10000) - (bm "Eratosthenes" + (bm "eratosthenes" check-value-primes - "eratos" 100) ;; See https://en.wikipedia.org/wiki/Collatz_conjecture - (bm "Collatz" + (bm "collatz" check-value - "collatz" 10000))) From 4f5660337010d98ef5526c100066ed05098c9687 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 14 Mar 2023 23:54:47 -0700 Subject: [PATCH 158/338] support selecting specific nonlocal benchmarks to run via CLI --- qi-sdk/profile/competitive/intrinsic.rkt | 24 ++++++++++++++---------- qi-sdk/profile/competitive/report.rkt | 8 +++++++- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/qi-sdk/profile/competitive/intrinsic.rkt b/qi-sdk/profile/competitive/intrinsic.rkt index 5dd6b791e..1b75772ed 100755 --- a/qi-sdk/profile/competitive/intrinsic.rkt +++ b/qi-sdk/profile/competitive/intrinsic.rkt @@ -6,14 +6,18 @@ (require "../util.rkt" "spec.rkt") -(define (benchmark language) - (define namespace (make-base-namespace)) - (cond [(eq? 'qi language) (eval '(require "qi/main.rkt") namespace)] - [(eq? 'racket language) (eval '(require "racket/main.rkt") namespace)]) +(define (benchmark language benchmarks-to-run) + (let ([namespace (make-base-namespace)] + [benchmarks-to-run (if (null? benchmarks-to-run) + (map bm-name specs) + benchmarks-to-run)]) + (cond [(eq? 'qi language) (eval '(require "qi/main.rkt") namespace)] + [(eq? 'racket language) (eval '(require "racket/main.rkt") namespace)]) - (for/list ([spec specs]) - (let ([name (bm-name spec)] - [exerciser (bm-exerciser spec)] - [f (eval (read (open-input-string (bm-target spec))) namespace)] - [n-times (bm-times spec)]) - (run-nonlocal-benchmark name exerciser f n-times)))) + (for/list ([spec specs] + #:when (member (bm-name spec) benchmarks-to-run)) + (let ([name (bm-name spec)] + [exerciser (bm-exerciser spec)] + [f (eval (read (open-input-string (bm-name spec))) namespace)] + [n-times (bm-times spec)]) + (run-nonlocal-benchmark name exerciser f n-times))))) diff --git a/qi-sdk/profile/competitive/report.rkt b/qi-sdk/profile/competitive/report.rkt index 575691144..f59413a0a 100755 --- a/qi-sdk/profile/competitive/report.rkt +++ b/qi-sdk/profile/competitive/report.rkt @@ -13,6 +13,12 @@ "../intrinsic/regression.rkt" "intrinsic.rkt") +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select benchmark by name") + (selected (cons name (selected)))) + +(constraint (multi selected)) + (help (usage (~a "Run competitive benchmarks between Qi and Racket, " @@ -31,7 +37,7 @@ (program (main) (displayln "\nRunning competitive benchmarks..." (current-error-port)) - (let ([output (benchmark 'qi)]) + (let ([output (benchmark 'qi (selected))]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) From 295f3973a47812bee72a96b0a8d334a12d90df62 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 14 Mar 2023 23:55:28 -0700 Subject: [PATCH 159/338] standardize flag conventions --- qi-sdk/profile/competitive/report.rkt | 8 ++++---- qi-sdk/profile/intrinsic/forms/report.rkt | 14 +++++++------- qi-sdk/profile/intrinsic/loading/report.rkt | 2 +- qi-sdk/profile/intrinsic/report.rkt | 14 +++++++------- 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/qi-sdk/profile/competitive/report.rkt b/qi-sdk/profile/competitive/report.rkt index f59413a0a..029e17a68 100755 --- a/qi-sdk/profile/competitive/report.rkt +++ b/qi-sdk/profile/competitive/report.rkt @@ -25,7 +25,7 @@ "reporting the results in a configurable output format."))) (flag (output-format #:param [output-format ""] fmt) - ("-o" + ("-f" "--format" "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") (output-format fmt)) @@ -44,7 +44,7 @@ (compute-regression before after)) (format-output output (output-format))))) -;; ;; To run benchmarks for a form interactively, use e.g.: -;; ;; (run main #("-f" "fanout")) +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "composition")) -(run main) +(run main #("-s" "composition")) diff --git a/qi-sdk/profile/intrinsic/forms/report.rkt b/qi-sdk/profile/intrinsic/forms/report.rkt index a21b33af7..4e0fef1ba 100755 --- a/qi-sdk/profile/intrinsic/forms/report.rkt +++ b/qi-sdk/profile/intrinsic/forms/report.rkt @@ -13,11 +13,11 @@ "../regression.rkt" (submod "benchmarks.rkt" main)) -(flag (forms #:param [forms null] name) - ("-f" "--form" "Forms to benchmark") - (forms (cons name (forms)))) +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select form to benchmark") + (selected (cons name (selected)))) -(constraint (multi forms)) +(constraint (multi selected)) (help (usage @@ -26,7 +26,7 @@ "in a configurable output format."))) (flag (output-format #:param [output-format ""] fmt) - ("-o" + ("-f" "--format" "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") (output-format fmt)) @@ -36,7 +36,7 @@ (regression-file reg-file)) (program (main) - (let ([output (benchmark (forms))]) + (let ([output (benchmark (selected))]) (if (regression-file) ;; TODO: regression ignores any flags and is a parallel path ;; it should be properly incorporated into the CLI @@ -46,6 +46,6 @@ (format-output output (output-format))))) ;; To run benchmarks for a form interactively, use e.g.: -;; (run main #("-f" "fanout")) +;; (run main #("-s" "fanout")) (run main) diff --git a/qi-sdk/profile/intrinsic/loading/report.rkt b/qi-sdk/profile/intrinsic/loading/report.rkt index 47cdf2411..90f415a35 100755 --- a/qi-sdk/profile/intrinsic/loading/report.rkt +++ b/qi-sdk/profile/intrinsic/loading/report.rkt @@ -18,7 +18,7 @@ (~a "Measure module load time, i.e. the time taken by (require qi)."))) (flag (output-format #:param [output-format ""] fmt) - ("-o" + ("-f" "--format" "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") (output-format fmt)) diff --git a/qi-sdk/profile/intrinsic/report.rkt b/qi-sdk/profile/intrinsic/report.rkt index a8deeab89..02996fab8 100755 --- a/qi-sdk/profile/intrinsic/report.rkt +++ b/qi-sdk/profile/intrinsic/report.rkt @@ -15,11 +15,11 @@ "regression.rkt" (submod "forms/benchmarks.rkt" main)) -(flag (forms #:param [forms null] name) - ("-f" "--form" "Forms to benchmark") - (forms (cons name (forms)))) +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select form to benchmark") + (selected (cons name (selected)))) -(constraint (multi forms)) +(constraint (multi selected)) (help (usage @@ -28,7 +28,7 @@ "in a configurable output format."))) (flag (output-format #:param [output-format ""] fmt) - ("-o" + ("-f" "--format" "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") (output-format fmt)) @@ -49,7 +49,7 @@ ;; https://github.com/countvajhula/cli/issues/3 (program (main) (let* ([forms-data (if (member? (report-type) (list "all" "forms")) - (benchmark (forms)) + (benchmark (selected)) null)] [require-data (if (member? (report-type) (list "all" "loading")) (list (profile-load "qi")) @@ -62,6 +62,6 @@ (format-output output (output-format))))) ;; To run benchmarks for a form interactively, use e.g.: -;; (run main #("-f" "fanout")) +;; (run main #("-s" "fanout")) (run main) From deb651ed883fceff34c7c46bde5ae60b5f0669ad Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 00:05:38 -0700 Subject: [PATCH 160/338] reorganize benchmarks as local and nonlocal --- Makefile | 6 +++--- qi-sdk/profile/{intrinsic => local}/forms/base.rkt | 0 qi-sdk/profile/{intrinsic => local}/forms/benchmarks.rkt | 0 qi-sdk/profile/{intrinsic => local}/forms/report.rkt | 2 +- qi-sdk/profile/{intrinsic => local}/loading/loadlib.rkt | 0 qi-sdk/profile/{intrinsic => local}/loading/report.rkt | 2 +- qi-sdk/profile/{intrinsic => local}/report.rkt | 2 +- qi-sdk/profile/{competitive => nonlocal}/intrinsic.rkt | 0 qi-sdk/profile/{competitive => nonlocal}/qi/main.rkt | 0 qi-sdk/profile/{competitive => nonlocal}/racket/main.rkt | 0 qi-sdk/profile/{competitive => nonlocal}/report.rkt | 4 ++-- qi-sdk/profile/{competitive => nonlocal}/spec.rkt | 0 qi-sdk/profile/{intrinsic => }/regression.rkt | 0 13 files changed, 8 insertions(+), 8 deletions(-) rename qi-sdk/profile/{intrinsic => local}/forms/base.rkt (100%) rename qi-sdk/profile/{intrinsic => local}/forms/benchmarks.rkt (100%) rename qi-sdk/profile/{intrinsic => local}/forms/report.rkt (97%) rename qi-sdk/profile/{intrinsic => local}/loading/loadlib.rkt (100%) rename qi-sdk/profile/{intrinsic => local}/loading/report.rkt (97%) rename qi-sdk/profile/{intrinsic => local}/report.rkt (98%) rename qi-sdk/profile/{competitive => nonlocal}/intrinsic.rkt (100%) rename qi-sdk/profile/{competitive => nonlocal}/qi/main.rkt (100%) rename qi-sdk/profile/{competitive => nonlocal}/racket/main.rkt (100%) rename qi-sdk/profile/{competitive => nonlocal}/report.rkt (95%) rename qi-sdk/profile/{competitive => nonlocal}/spec.rkt (100%) rename qi-sdk/profile/{intrinsic => }/regression.rkt (100%) diff --git a/Makefile b/Makefile index 0f0de57e6..f7efcae88 100644 --- a/Makefile +++ b/Makefile @@ -182,14 +182,14 @@ profile-selected-forms: profile-competitive: echo "Running competitive benchmarks..." - cd $(PACKAGE-NAME)-sdk/profile/competitive; racket report.rkt + cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report.rkt profile: profile-competitive profile-forms performance-report: - @racket $(PACKAGE-NAME)-sdk/profile/intrinsic/report.rkt -o json + @racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt -f json performance-regression-report: - @racket $(PACKAGE-NAME)-sdk/profile/intrinsic/report.rkt -r $(REF) + @racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt -r $(REF) .PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-loading profile-selected-forms profile-competitive profile performance-report performance-regression-report diff --git a/qi-sdk/profile/intrinsic/forms/base.rkt b/qi-sdk/profile/local/forms/base.rkt similarity index 100% rename from qi-sdk/profile/intrinsic/forms/base.rkt rename to qi-sdk/profile/local/forms/base.rkt diff --git a/qi-sdk/profile/intrinsic/forms/benchmarks.rkt b/qi-sdk/profile/local/forms/benchmarks.rkt similarity index 100% rename from qi-sdk/profile/intrinsic/forms/benchmarks.rkt rename to qi-sdk/profile/local/forms/benchmarks.rkt diff --git a/qi-sdk/profile/intrinsic/forms/report.rkt b/qi-sdk/profile/local/forms/report.rkt similarity index 97% rename from qi-sdk/profile/intrinsic/forms/report.rkt rename to qi-sdk/profile/local/forms/report.rkt index 4e0fef1ba..9c1198bf9 100755 --- a/qi-sdk/profile/intrinsic/forms/report.rkt +++ b/qi-sdk/profile/local/forms/report.rkt @@ -10,7 +10,7 @@ for/call write-csv format-output) - "../regression.rkt" + "../../regression.rkt" (submod "benchmarks.rkt" main)) (flag (selected #:param [selected null] name) diff --git a/qi-sdk/profile/intrinsic/loading/loadlib.rkt b/qi-sdk/profile/local/loading/loadlib.rkt similarity index 100% rename from qi-sdk/profile/intrinsic/loading/loadlib.rkt rename to qi-sdk/profile/local/loading/loadlib.rkt diff --git a/qi-sdk/profile/intrinsic/loading/report.rkt b/qi-sdk/profile/local/loading/report.rkt similarity index 97% rename from qi-sdk/profile/intrinsic/loading/report.rkt rename to qi-sdk/profile/local/loading/report.rkt index 90f415a35..1e15eb84a 100755 --- a/qi-sdk/profile/intrinsic/loading/report.rkt +++ b/qi-sdk/profile/local/loading/report.rkt @@ -10,7 +10,7 @@ for/call write-csv format-output) - "../regression.rkt" + "../../regression.rkt" "loadlib.rkt") (help diff --git a/qi-sdk/profile/intrinsic/report.rkt b/qi-sdk/profile/local/report.rkt similarity index 98% rename from qi-sdk/profile/intrinsic/report.rkt rename to qi-sdk/profile/local/report.rkt index 02996fab8..f7e229d8a 100755 --- a/qi-sdk/profile/intrinsic/report.rkt +++ b/qi-sdk/profile/local/report.rkt @@ -12,7 +12,7 @@ format-output) "loading/loadlib.rkt" - "regression.rkt" + "../regression.rkt" (submod "forms/benchmarks.rkt" main)) (flag (selected #:param [selected null] name) diff --git a/qi-sdk/profile/competitive/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt similarity index 100% rename from qi-sdk/profile/competitive/intrinsic.rkt rename to qi-sdk/profile/nonlocal/intrinsic.rkt diff --git a/qi-sdk/profile/competitive/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt similarity index 100% rename from qi-sdk/profile/competitive/qi/main.rkt rename to qi-sdk/profile/nonlocal/qi/main.rkt diff --git a/qi-sdk/profile/competitive/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt similarity index 100% rename from qi-sdk/profile/competitive/racket/main.rkt rename to qi-sdk/profile/nonlocal/racket/main.rkt diff --git a/qi-sdk/profile/competitive/report.rkt b/qi-sdk/profile/nonlocal/report.rkt similarity index 95% rename from qi-sdk/profile/competitive/report.rkt rename to qi-sdk/profile/nonlocal/report.rkt index 029e17a68..61e549054 100755 --- a/qi-sdk/profile/competitive/report.rkt +++ b/qi-sdk/profile/nonlocal/report.rkt @@ -10,7 +10,7 @@ for/call write-csv format-output) - "../intrinsic/regression.rkt" + "../regression.rkt" "intrinsic.rkt") (flag (selected #:param [selected null] name) @@ -47,4 +47,4 @@ ;; To run benchmarks for a form interactively, use e.g.: ;; (run main #("-s" "composition")) -(run main #("-s" "composition")) +(run main) diff --git a/qi-sdk/profile/competitive/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt similarity index 100% rename from qi-sdk/profile/competitive/spec.rkt rename to qi-sdk/profile/nonlocal/spec.rkt diff --git a/qi-sdk/profile/intrinsic/regression.rkt b/qi-sdk/profile/regression.rkt similarity index 100% rename from qi-sdk/profile/intrinsic/regression.rkt rename to qi-sdk/profile/regression.rkt From 8d0fdaf417e03c9e89536fbd3d6917dcace51ddd Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 00:30:53 -0700 Subject: [PATCH 161/338] continue reorganizing benchmarks.. --- Makefile | 10 +++---- .../profile/{local => }/loading/loadlib.rkt | 0 qi-sdk/profile/{local => }/loading/report.rkt | 4 +-- qi-sdk/profile/local/{forms => }/base.rkt | 4 +-- .../profile/local/{forms => }/benchmarks.rkt | 2 +- qi-sdk/profile/local/report.rkt | 24 +++-------------- qi-sdk/profile/{local/forms => }/report.rkt | 27 ++++++++++++++----- 7 files changed, 35 insertions(+), 36 deletions(-) rename qi-sdk/profile/{local => }/loading/loadlib.rkt (100%) rename qi-sdk/profile/{local => }/loading/report.rkt (93%) rename qi-sdk/profile/local/{forms => }/base.rkt (67%) rename qi-sdk/profile/local/{forms => }/benchmarks.rkt (99%) rename qi-sdk/profile/{local/forms => }/report.rkt (59%) diff --git a/Makefile b/Makefile index f7efcae88..69777a9f3 100644 --- a/Makefile +++ b/Makefile @@ -171,14 +171,14 @@ cover-coveralls: profile-forms: echo "Profiling forms..." - racket $(PACKAGE-NAME)-sdk/profile/intrinsic/forms/report.rkt + racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt profile-loading: echo "Profiling module loading..." - racket $(PACKAGE-NAME)-sdk/profile/intrinsic/loading/report.rkt + racket $(PACKAGE-NAME)-sdk/profile/loading/report.rkt profile-selected-forms: - @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/intrinsic/forms/report.rkt' directly, with -f form-name for each form." + @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt' directly, with -f form-name for each form." profile-competitive: echo "Running competitive benchmarks..." @@ -187,9 +187,9 @@ profile-competitive: profile: profile-competitive profile-forms performance-report: - @racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt -f json + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -f json performance-regression-report: - @racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt -r $(REF) + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) .PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-loading profile-selected-forms profile-competitive profile performance-report performance-regression-report diff --git a/qi-sdk/profile/local/loading/loadlib.rkt b/qi-sdk/profile/loading/loadlib.rkt similarity index 100% rename from qi-sdk/profile/local/loading/loadlib.rkt rename to qi-sdk/profile/loading/loadlib.rkt diff --git a/qi-sdk/profile/local/loading/report.rkt b/qi-sdk/profile/loading/report.rkt similarity index 93% rename from qi-sdk/profile/local/loading/report.rkt rename to qi-sdk/profile/loading/report.rkt index 1e15eb84a..8c56eddad 100755 --- a/qi-sdk/profile/local/loading/report.rkt +++ b/qi-sdk/profile/loading/report.rkt @@ -5,12 +5,12 @@ racket/format relation qi - (only-in "../../util.rkt" + (only-in "../util.rkt" only-if for/call write-csv format-output) - "../../regression.rkt" + "../regression.rkt" "loadlib.rkt") (help diff --git a/qi-sdk/profile/local/forms/base.rkt b/qi-sdk/profile/local/base.rkt similarity index 67% rename from qi-sdk/profile/local/forms/base.rkt rename to qi-sdk/profile/local/base.rkt index a3ccd9fc7..7431b112f 100644 --- a/qi-sdk/profile/local/forms/base.rkt +++ b/qi-sdk/profile/local/base.rkt @@ -2,9 +2,9 @@ (provide (all-from-out racket/base) (all-from-out qi) - (all-from-out "../../util.rkt") + (all-from-out "../util.rkt") sqr) (require qi - "../../util.rkt" + "../util.rkt" (only-in math sqr)) diff --git a/qi-sdk/profile/local/forms/benchmarks.rkt b/qi-sdk/profile/local/benchmarks.rkt similarity index 99% rename from qi-sdk/profile/local/forms/benchmarks.rkt rename to qi-sdk/profile/local/benchmarks.rkt index 0decd7036..84e8d0713 100755 --- a/qi-sdk/profile/local/forms/benchmarks.rkt +++ b/qi-sdk/profile/local/benchmarks.rkt @@ -900,7 +900,7 @@ for the forms are run. qi json csv-writing - (only-in "../../util.rkt" + (only-in "../util.rkt" only-if for/call)) (require diff --git a/qi-sdk/profile/local/report.rkt b/qi-sdk/profile/local/report.rkt index f7e229d8a..d2d47e8e0 100755 --- a/qi-sdk/profile/local/report.rkt +++ b/qi-sdk/profile/local/report.rkt @@ -10,10 +10,8 @@ for/call write-csv format-output) - - "loading/loadlib.rkt" "../regression.rkt" - (submod "forms/benchmarks.rkt" main)) + (submod "benchmarks.rkt" main)) (flag (selected #:param [selected null] name) ("-s" "--select" "Select form to benchmark") @@ -33,29 +31,15 @@ "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") (output-format fmt)) -(flag (type #:param [report-type "all"] typ) - ("-t" - "--type" - "Type of report, either `forms`, `loading` or `all` (default `all`)") - (report-type typ)) - (flag (regression-file #:param [regression-file #f] reg-file) ("-r" "--regression" "'Before' data to compute regression against") (regression-file reg-file)) -;; Note: much of this file is duplicated across forms/report.rkt -;; and loading/report.rkt. It could be avoided if we had -;; "composition of commands", see: -;; https://github.com/countvajhula/cli/issues/3 (program (main) - (let* ([forms-data (if (member? (report-type) (list "all" "forms")) - (benchmark (selected)) - null)] - [require-data (if (member? (report-type) (list "all" "loading")) - (list (profile-load "qi")) - null)] - [output (append forms-data require-data)]) + (let ([output (benchmark (selected))]) (if (regression-file) + ;; TODO: regression ignores any flags and is a parallel path + ;; it should be properly incorporated into the CLI (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) (compute-regression before after)) diff --git a/qi-sdk/profile/local/forms/report.rkt b/qi-sdk/profile/report.rkt similarity index 59% rename from qi-sdk/profile/local/forms/report.rkt rename to qi-sdk/profile/report.rkt index 9c1198bf9..3b9e2c264 100755 --- a/qi-sdk/profile/local/forms/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -5,13 +5,14 @@ racket/format relation qi - (only-in "../../util.rkt" + (only-in "util.rkt" only-if for/call write-csv format-output) - "../../regression.rkt" - (submod "benchmarks.rkt" main)) + "loading/loadlib.rkt" + "regression.rkt" + (submod "local/benchmarks.rkt" main)) (flag (selected #:param [selected null] name) ("-s" "--select" "Select form to benchmark") @@ -31,15 +32,29 @@ "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") (output-format fmt)) +(flag (type #:param [report-type "all"] typ) + ("-t" + "--type" + "Type of report, either `forms`, `loading` or `all` (default `all`)") + (report-type typ)) + (flag (regression-file #:param [regression-file #f] reg-file) ("-r" "--regression" "'Before' data to compute regression against") (regression-file reg-file)) +;; Note: much of this file is duplicated across forms/report.rkt +;; and loading/report.rkt. It could be avoided if we had +;; "composition of commands", see: +;; https://github.com/countvajhula/cli/issues/3 (program (main) - (let ([output (benchmark (selected))]) + (let* ([forms-data (if (member? (report-type) (list "all" "forms")) + (benchmark (selected)) + null)] + [require-data (if (member? (report-type) (list "all" "loading")) + (list (profile-load "qi")) + null)] + [output (append forms-data require-data)]) (if (regression-file) - ;; TODO: regression ignores any flags and is a parallel path - ;; it should be properly incorporated into the CLI (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) (compute-regression before after)) From 91d35bf9a3ea9c559f74735ec2eb2b9f9ce39687 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 00:53:23 -0700 Subject: [PATCH 162/338] run nonlocal benchmarks for racket or qi via CLI --- qi-sdk/profile/nonlocal/intrinsic.rkt | 4 ++-- qi-sdk/profile/nonlocal/report.rkt | 8 +++++++- qi-sdk/profile/util.rkt | 6 +++--- 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/qi-sdk/profile/nonlocal/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt index 1b75772ed..731e379a4 100755 --- a/qi-sdk/profile/nonlocal/intrinsic.rkt +++ b/qi-sdk/profile/nonlocal/intrinsic.rkt @@ -11,8 +11,8 @@ [benchmarks-to-run (if (null? benchmarks-to-run) (map bm-name specs) benchmarks-to-run)]) - (cond [(eq? 'qi language) (eval '(require "qi/main.rkt") namespace)] - [(eq? 'racket language) (eval '(require "racket/main.rkt") namespace)]) + (cond [(equal? "qi" language) (eval '(require "qi/main.rkt") namespace)] + [(equal? "racket" language) (eval '(require "racket/main.rkt") namespace)]) (for/list ([spec specs] #:when (member (bm-name spec) benchmarks-to-run)) diff --git a/qi-sdk/profile/nonlocal/report.rkt b/qi-sdk/profile/nonlocal/report.rkt index 61e549054..2b0b99b5d 100755 --- a/qi-sdk/profile/nonlocal/report.rkt +++ b/qi-sdk/profile/nonlocal/report.rkt @@ -34,10 +34,16 @@ ("-r" "--regression" "'Before' data to compute regression against") (regression-file reg-file)) +(flag (language #:param [language "qi"] lang) + ("-l" + "--language" + "Language to benchmark, either 'qi' or 'racket'. If none is specified, assumes 'qi'.") + (language lang)) + (program (main) (displayln "\nRunning competitive benchmarks..." (current-error-port)) - (let ([output (benchmark 'qi (selected))]) + (let ([output (benchmark (language) (selected))]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index 0ba2951b5..38a560cfe 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -127,11 +127,11 @@ ;; Run different implementations of the same benchmark (e.g. a Racket vs a Qi ;; implementation) a specified number of times, and report the time taken ;; by each implementation. -(define (run-nonlocal-benchmark bm-name runner f n-times) - (displayln (~a bm-name ":") (current-error-port)) +(define (run-nonlocal-benchmark name runner f n-times) + (displayln (~a name ":") (current-error-port)) (let ([ms (measure runner f n-times)]) (displayln (~a ms " ms") (current-error-port)) - (hash 'name bm-name 'unit "ms" 'value ms))) + (hash 'name name 'unit "ms" 'value ms))) (define (write-csv data) (~> (data) From 65eccaf8e083d4befb5d5aab1883ed1b2241d9af Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 01:26:34 -0700 Subject: [PATCH 163/338] use regression logic to implement competitive benchmarks --- Makefile | 6 ++- .../profile/nonlocal/report-competitive.rkt | 46 +++++++++++++++++++ .../{report.rkt => report-intrinsic.rkt} | 2 +- qi-sdk/profile/regression.rkt | 9 +++- 4 files changed, 60 insertions(+), 3 deletions(-) create mode 100755 qi-sdk/profile/nonlocal/report-competitive.rkt rename qi-sdk/profile/nonlocal/{report.rkt => report-intrinsic.rkt} (96%) diff --git a/Makefile b/Makefile index 69777a9f3..683723e73 100644 --- a/Makefile +++ b/Makefile @@ -182,7 +182,11 @@ profile-selected-forms: profile-competitive: echo "Running competitive benchmarks..." - cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report.rkt + cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-competitive.rkt + +profile-nonlocal: + echo "Running nonlocal benchmarks..." + cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-intrinsic.rkt -l qi profile: profile-competitive profile-forms diff --git a/qi-sdk/profile/nonlocal/report-competitive.rkt b/qi-sdk/profile/nonlocal/report-competitive.rkt new file mode 100755 index 000000000..ed3a42dfd --- /dev/null +++ b/qi-sdk/profile/nonlocal/report-competitive.rkt @@ -0,0 +1,46 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call + write-csv + format-output) + "../regression.rkt" + "intrinsic.rkt") + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select benchmark by name") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run competitive benchmarks between Qi and Racket, " + "reporting the results in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(program (main) + (displayln "\nRunning competitive benchmarks..." (current-error-port)) + + (let* ([racket-output (benchmark "racket" (selected))] + [qi-output (benchmark "qi" (selected))] + [before (parse-benchmarks racket-output)] + [after (parse-benchmarks qi-output)]) + (format-output (compute-regression before after) + (output-format)))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "composition")) + +(run main) diff --git a/qi-sdk/profile/nonlocal/report.rkt b/qi-sdk/profile/nonlocal/report-intrinsic.rkt similarity index 96% rename from qi-sdk/profile/nonlocal/report.rkt rename to qi-sdk/profile/nonlocal/report-intrinsic.rkt index 2b0b99b5d..9849f9aa4 100755 --- a/qi-sdk/profile/nonlocal/report.rkt +++ b/qi-sdk/profile/nonlocal/report-intrinsic.rkt @@ -21,7 +21,7 @@ (help (usage - (~a "Run competitive benchmarks between Qi and Racket, " + (~a "Run nonlocal benchmarks on either Qi or Racket, " "reporting the results in a configurable output format."))) (flag (output-format #:param [output-format ""] fmt) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index d27ddedd9..c3eba8146 100644 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -42,6 +42,12 @@ 1 (~r #:precision 2)))) + (define-flow reformat + (~> △ + (>< (~> (-< car cadr) + (hash 'name _ 'value _ 'unit "x"))) + ▽)) + (define results (~>> (before) hash-keys @@ -52,6 +58,7 @@ calculate-ratio) ▽)) ▽ - (sort > #:key (☯ (~> cadr ->inexact))))) + (sort > #:key (☯ (~> cadr ->inexact))) + reformat)) results) From cc3fa884d336890143990f039f28db675a50b668 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 09:47:38 -0700 Subject: [PATCH 164/338] respect CLI flags in performance regression reporting --- qi-sdk/profile/loading/report.rkt | 3 ++- qi-sdk/profile/local/report.rkt | 5 ++--- qi-sdk/profile/nonlocal/report-intrinsic.rkt | 5 +++-- qi-sdk/profile/regression.rkt | 2 ++ qi-sdk/profile/report.rkt | 3 ++- 5 files changed, 11 insertions(+), 7 deletions(-) diff --git a/qi-sdk/profile/loading/report.rkt b/qi-sdk/profile/loading/report.rkt index 8c56eddad..1b1436447 100755 --- a/qi-sdk/profile/loading/report.rkt +++ b/qi-sdk/profile/loading/report.rkt @@ -32,7 +32,8 @@ (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) - (compute-regression before after)) + (format-output (compute-regression before after) + (output-format))) (format-output output (output-format))))) (run main) diff --git a/qi-sdk/profile/local/report.rkt b/qi-sdk/profile/local/report.rkt index d2d47e8e0..0a80a6cc0 100755 --- a/qi-sdk/profile/local/report.rkt +++ b/qi-sdk/profile/local/report.rkt @@ -38,11 +38,10 @@ (program (main) (let ([output (benchmark (selected))]) (if (regression-file) - ;; TODO: regression ignores any flags and is a parallel path - ;; it should be properly incorporated into the CLI (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) - (compute-regression before after)) + (format-output (compute-regression before after) + (output-format))) (format-output output (output-format))))) ;; To run benchmarks for a form interactively, use e.g.: diff --git a/qi-sdk/profile/nonlocal/report-intrinsic.rkt b/qi-sdk/profile/nonlocal/report-intrinsic.rkt index 9849f9aa4..5ee75633d 100755 --- a/qi-sdk/profile/nonlocal/report-intrinsic.rkt +++ b/qi-sdk/profile/nonlocal/report-intrinsic.rkt @@ -41,13 +41,14 @@ (language lang)) (program (main) - (displayln "\nRunning competitive benchmarks..." (current-error-port)) + (displayln "\nRunning nonlocal benchmarks..." (current-error-port)) (let ([output (benchmark (language) (selected))]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) - (compute-regression before after)) + (format-output (compute-regression before after) + (output-format))) (format-output output (output-format))))) ;; To run benchmarks for a form interactively, use e.g.: diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index c3eba8146..ad139e73c 100644 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -19,6 +19,8 @@ (read-json port)))) (define (parse-benchmarks benchmarks) + ;; renames some forms so they're consistently named + ;; but otherwise leaves the original data unmodified (make-hash (map (☯ (~> (-< (~> (hash-ref 'name) (switch diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 3b9e2c264..1a51770cc 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -57,7 +57,8 @@ (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) - (compute-regression before after)) + (format-output (compute-regression before after) + (output-format))) (format-output output (output-format))))) ;; To run benchmarks for a form interactively, use e.g.: From 9403cf5d013c0ace3ca2c7c392a7c7aee09accb2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 09:49:22 -0700 Subject: [PATCH 165/338] check regression wrt the "after" data to respect narrowed selection --- qi-sdk/profile/regression.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index ad139e73c..93c14ed45 100644 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -51,7 +51,7 @@ ▽)) (define results - (~>> (before) + (~>> (after) hash-keys △ (>< From 191d76fed01c576e80e384c89143fedc57ca40b2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 10:13:56 -0700 Subject: [PATCH 166/338] update makefile targets and name things consistently --- Makefile | 15 ++++++--------- qi-sdk/profile/loading/report.rkt | 2 ++ qi-sdk/profile/local/report.rkt | 2 ++ qi-sdk/profile/report.rkt | 5 ++++- 4 files changed, 14 insertions(+), 10 deletions(-) diff --git a/Makefile b/Makefile index 683723e73..0d0b17a61 100644 --- a/Makefile +++ b/Makefile @@ -40,7 +40,8 @@ help: @echo "docs - view docs in a browser" @echo "profile - Run comprehensive performance benchmarks" @echo "profile-competitive - Run competitive benchmarks" - @echo "profile-forms - Run benchmarks for individual Qi forms" + @echo "profile-local - Run benchmarks for individual Qi forms" + @echo "profile-nonlocal - Run nonlocal benchmarks exercising many components at once" @echo "profile-selected-forms - Run benchmarks for Qi forms by name (command only)" @echo "performance-report - Run benchmarks for Qi forms and produce results for use in CI and for measuring regression" @echo " For use in regression: make performance-report > /path/to/before.json" @@ -169,26 +170,22 @@ cover: coverage-check coverage-report cover-coveralls: raco cover -b -f coveralls -p $(PACKAGE-NAME)-{lib,test} -profile-forms: - echo "Profiling forms..." +profile-local: racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt profile-loading: - echo "Profiling module loading..." racket $(PACKAGE-NAME)-sdk/profile/loading/report.rkt profile-selected-forms: - @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt' directly, with -f form-name for each form." + @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt' directly, with -s form-name for each form." profile-competitive: - echo "Running competitive benchmarks..." cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-competitive.rkt profile-nonlocal: - echo "Running nonlocal benchmarks..." cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-intrinsic.rkt -l qi -profile: profile-competitive profile-forms +profile: profile-local profile-nonlocal profile-loading performance-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -f json @@ -196,4 +193,4 @@ performance-report: performance-regression-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-loading profile-selected-forms profile-competitive profile performance-report performance-regression-report +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report diff --git a/qi-sdk/profile/loading/report.rkt b/qi-sdk/profile/loading/report.rkt index 1b1436447..e91d64de6 100755 --- a/qi-sdk/profile/loading/report.rkt +++ b/qi-sdk/profile/loading/report.rkt @@ -28,6 +28,8 @@ (regression-file reg-file)) (program (main) + (displayln "\nMeasuring module load time..." (current-error-port)) + (let ([output (profile-load "qi")]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] diff --git a/qi-sdk/profile/local/report.rkt b/qi-sdk/profile/local/report.rkt index 0a80a6cc0..85201dbd1 100755 --- a/qi-sdk/profile/local/report.rkt +++ b/qi-sdk/profile/local/report.rkt @@ -36,6 +36,8 @@ (regression-file reg-file)) (program (main) + (displayln "\nRunning local (forms) benchmarks..." (current-error-port)) + (let ([output (benchmark (selected))]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 1a51770cc..fb3fa1cd7 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -42,11 +42,14 @@ ("-r" "--regression" "'Before' data to compute regression against") (regression-file reg-file)) -;; Note: much of this file is duplicated across forms/report.rkt +;; Note: much of this file is duplicated across local/report.rkt ;; and loading/report.rkt. It could be avoided if we had ;; "composition of commands", see: ;; https://github.com/countvajhula/cli/issues/3 (program (main) + (displayln "\nRunning local (forms) benchmarks and measuring module load time..." + (current-error-port)) + (let* ([forms-data (if (member? (report-type) (list "all" "forms")) (benchmark (selected)) null)] From 62fbab89564ce0c4362a315c95a7b58eb6ebd0b4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 10:30:50 -0700 Subject: [PATCH 167/338] improve live output in competitive report --- qi-sdk/profile/nonlocal/report-competitive.rkt | 8 ++++++-- qi-sdk/profile/regression.rkt | 8 +++++++- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/qi-sdk/profile/nonlocal/report-competitive.rkt b/qi-sdk/profile/nonlocal/report-competitive.rkt index ed3a42dfd..458f99f35 100755 --- a/qi-sdk/profile/nonlocal/report-competitive.rkt +++ b/qi-sdk/profile/nonlocal/report-competitive.rkt @@ -33,8 +33,12 @@ (program (main) (displayln "\nRunning competitive benchmarks..." (current-error-port)) - (let* ([racket-output (benchmark "racket" (selected))] - [qi-output (benchmark "qi" (selected))] + (let* ([racket-output + (begin (displayln "\nRunning Racket benchmarks..." (current-error-port)) + (benchmark "racket" (selected)))] + [qi-output + (begin (displayln "\nRunning Qi benchmarks..." (current-error-port)) + (benchmark "qi" (selected)))] [before (parse-benchmarks racket-output)] [after (parse-benchmarks qi-output)]) (format-output (compute-regression before after) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index 93c14ed45..0e1e072b3 100644 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -8,7 +8,8 @@ (require qi relation json - racket/format) + racket/format + racket/pretty) (define LOWER-THRESHOLD 0.75) (define HIGHER-THRESHOLD 1.5) @@ -50,6 +51,10 @@ (hash 'name _ 'value _ 'unit "x"))) ▽)) + (define (show-results results) + (displayln "\nPerformance relative to baseline:" (current-error-port)) + (pretty-display results (current-error-port))) + (define results (~>> (after) hash-keys @@ -61,6 +66,7 @@ ▽)) ▽ (sort > #:key (☯ (~> cadr ->inexact))) + (ε show-results) reformat)) results) From 9279d83737136348da808a6e2b517ea95210dce0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 10:43:16 -0700 Subject: [PATCH 168/338] cleanup, remove unused imports --- qi-sdk/profile/local/benchmarks.rkt | 2 -- qi-sdk/profile/local/report.rkt | 8 +------- qi-sdk/profile/nonlocal/intrinsic.rkt | 2 +- qi-sdk/profile/nonlocal/report-competitive.rkt | 8 +------- qi-sdk/profile/nonlocal/report-intrinsic.rkt | 8 +------- qi-sdk/profile/report.rkt | 8 +------- qi-sdk/profile/util.rkt | 6 ++---- 7 files changed, 7 insertions(+), 35 deletions(-) diff --git a/qi-sdk/profile/local/benchmarks.rkt b/qi-sdk/profile/local/benchmarks.rkt index 84e8d0713..75c3d73be 100755 --- a/qi-sdk/profile/local/benchmarks.rkt +++ b/qi-sdk/profile/local/benchmarks.rkt @@ -898,8 +898,6 @@ for the forms are run. racket/format relation qi - json - csv-writing (only-in "../util.rkt" only-if for/call)) diff --git a/qi-sdk/profile/local/report.rkt b/qi-sdk/profile/local/report.rkt index 85201dbd1..2ff1e96ea 100755 --- a/qi-sdk/profile/local/report.rkt +++ b/qi-sdk/profile/local/report.rkt @@ -1,14 +1,8 @@ #!/usr/bin/env racket #lang cli -(require racket/match - racket/format - relation - qi +(require racket/format (only-in "../util.rkt" - only-if - for/call - write-csv format-output) "../regression.rkt" (submod "benchmarks.rkt" main)) diff --git a/qi-sdk/profile/nonlocal/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt index 731e379a4..e632d7361 100755 --- a/qi-sdk/profile/nonlocal/intrinsic.rkt +++ b/qi-sdk/profile/nonlocal/intrinsic.rkt @@ -1,5 +1,5 @@ #!/usr/bin/env racket -#lang cli +#lang racket/base (provide benchmark) diff --git a/qi-sdk/profile/nonlocal/report-competitive.rkt b/qi-sdk/profile/nonlocal/report-competitive.rkt index 458f99f35..7e03033ff 100755 --- a/qi-sdk/profile/nonlocal/report-competitive.rkt +++ b/qi-sdk/profile/nonlocal/report-competitive.rkt @@ -1,14 +1,8 @@ #!/usr/bin/env racket #lang cli -(require racket/match - racket/format - relation - qi +(require racket/format (only-in "../util.rkt" - only-if - for/call - write-csv format-output) "../regression.rkt" "intrinsic.rkt") diff --git a/qi-sdk/profile/nonlocal/report-intrinsic.rkt b/qi-sdk/profile/nonlocal/report-intrinsic.rkt index 5ee75633d..c451cd71d 100755 --- a/qi-sdk/profile/nonlocal/report-intrinsic.rkt +++ b/qi-sdk/profile/nonlocal/report-intrinsic.rkt @@ -1,14 +1,8 @@ #!/usr/bin/env racket #lang cli -(require racket/match - racket/format - relation - qi +(require racket/format (only-in "../util.rkt" - only-if - for/call - write-csv format-output) "../regression.rkt" "intrinsic.rkt") diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index fb3fa1cd7..d9de9b1d0 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -1,14 +1,8 @@ #!/usr/bin/env racket #lang cli -(require racket/match - racket/format - relation - qi +(require racket/format (only-in "util.rkt" - only-if - for/call - write-csv format-output) "loading/loadlib.rkt" "regression.rkt" diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index 38a560cfe..a751e2123 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -22,10 +22,6 @@ curryr) (only-in adjutor values->list) - (only-in data/collection - cycle - take - in) csv-writing json racket/format @@ -94,6 +90,8 @@ ;; Run a single benchmarking function a specified number of times ;; and report the time taken. +;; TODO: this is very similar to run-nonlocal-benchmark and these +;; should be unified. (define-syntax-parse-rule (run-benchmark f-name runner n-times) #:with name (datum->syntax #'f-name ;; this is because of the name collision between From 102481b360dc23c97fd678bdd2b62077b614bdc2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 12:28:11 -0700 Subject: [PATCH 169/338] use "local" instead of "forms" --- qi-sdk/profile/report.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index d9de9b1d0..d1482e5f0 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -29,7 +29,7 @@ (flag (type #:param [report-type "all"] typ) ("-t" "--type" - "Type of report, either `forms`, `loading` or `all` (default `all`)") + "Type of report, either `local`, `loading` or `all` (default `all`)") (report-type typ)) (flag (regression-file #:param [regression-file #f] reg-file) @@ -44,13 +44,13 @@ (displayln "\nRunning local (forms) benchmarks and measuring module load time..." (current-error-port)) - (let* ([forms-data (if (member? (report-type) (list "all" "forms")) + (let* ([local-data (if (member? (report-type) (list "all" "local")) (benchmark (selected)) null)] [require-data (if (member? (report-type) (list "all" "loading")) (list (profile-load "qi")) null)] - [output (append forms-data require-data)]) + [output (append local-data require-data)]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) From 5bfc8e7a14f5de0c6b21bea18d1fda37b5620cdc Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 15 Mar 2023 12:48:57 -0700 Subject: [PATCH 170/338] add back needed import --- qi-sdk/profile/report.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index d1482e5f0..554b9cd27 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -2,6 +2,7 @@ #lang cli (require racket/format + relation (only-in "util.rkt" format-output) "loading/loadlib.rkt" From e689c96f80f84983872fafdcfc91548d12847e44 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 21 Mar 2023 20:15:44 -0700 Subject: [PATCH 171/338] add nonlocal benchmarks to the performance report --- qi-sdk/profile/nonlocal/intrinsic.rkt | 35 ++++++++++++++++++++++++--- qi-sdk/profile/report.rkt | 10 +++++--- 2 files changed, 39 insertions(+), 6 deletions(-) diff --git a/qi-sdk/profile/nonlocal/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt index e632d7361..f0afbd1ae 100755 --- a/qi-sdk/profile/nonlocal/intrinsic.rkt +++ b/qi-sdk/profile/nonlocal/intrinsic.rkt @@ -3,16 +3,45 @@ (provide benchmark) -(require "../util.rkt" +(require racket/runtime-path + "../util.rkt" "spec.rkt") +;; We use `eval` in this module to `require` the appropriate objective +;; functions (either Racket or Qi) for benchmarking in a dynamically +;; constructed namespace (following +;; https://docs.racket-lang.org/guide/eval.html). This allows us to +;; define those functions symmetrically in the Racket and Qi modules, and +;; invoke them in a common way here. But as this eval namespace is +;; dynamically constructed, the require paths are interpreted as being +;; relative to the path from which this module is executed (e.g. either +;; locally from this folder or from the qi root via the Makefile) and may +;; therefore fail to find the modules if executed from "the wrong" +;; location. To avoid this, we set the "load relative" directory to the +;; module's path, so that requiring modules is always relative to the +;; present module path, allowing it to behave the same no matter where it +;; is executed from. Another possibility is to simply assume that the +;; qi-sdk package is installed so that the modules are available via +;; collection paths, but currently, having the SDK "officially" installed +;; slows down building of other packages for reasons as yet unknown. See: +;; https://github.com/drym-org/qi/wiki/Installing-the-SDK#install-the-sdk +;; So for now, we use this fix so that we can have the SDK remain +;; uninstalled. + +(define-runtime-path lexical-module-path ".") +(current-load-relative-directory lexical-module-path) + (define (benchmark language benchmarks-to-run) (let ([namespace (make-base-namespace)] [benchmarks-to-run (if (null? benchmarks-to-run) (map bm-name specs) benchmarks-to-run)]) - (cond [(equal? "qi" language) (eval '(require "qi/main.rkt") namespace)] - [(equal? "racket" language) (eval '(require "racket/main.rkt") namespace)]) + (cond [(equal? "qi" language) + (eval '(require "qi/main.rkt") + namespace)] + [(equal? "racket" language) + (eval '(require "racket/main.rkt") + namespace)]) (for/list ([spec specs] #:when (member (bm-name spec) benchmarks-to-run)) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt index 554b9cd27..1208491ac 100755 --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -7,7 +7,8 @@ format-output) "loading/loadlib.rkt" "regression.rkt" - (submod "local/benchmarks.rkt" main)) + (submod "local/benchmarks.rkt" main) + (prefix-in n: "nonlocal/intrinsic.rkt")) (flag (selected #:param [selected null] name) ("-s" "--select" "Select form to benchmark") @@ -30,7 +31,7 @@ (flag (type #:param [report-type "all"] typ) ("-t" "--type" - "Type of report, either `local`, `loading` or `all` (default `all`)") + "Type of report, either `local`, `nonlocal`, `loading` or `all` (default `all`)") (report-type typ)) (flag (regression-file #:param [regression-file #f] reg-file) @@ -48,10 +49,13 @@ (let* ([local-data (if (member? (report-type) (list "all" "local")) (benchmark (selected)) null)] + [nonlocal-data (if (member? (report-type) (list "all" "nonlocal")) + (n:benchmark "qi" (selected)) + null)] [require-data (if (member? (report-type) (list "all" "loading")) (list (profile-load "qi")) null)] - [output (append local-data require-data)]) + [output (~ local-data nonlocal-data require-data)]) (if (regression-file) (let ([before (parse-benchmarks (parse-json-file (regression-file)))] [after (parse-benchmarks output)]) From 1f982051ea41616c7687be489895810e9d2e78b6 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 22 Mar 2023 17:29:34 -0700 Subject: [PATCH 172/338] contain load path parameter to eval where it's needed --- qi-sdk/profile/nonlocal/intrinsic.rkt | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/qi-sdk/profile/nonlocal/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt index f0afbd1ae..6607f1844 100755 --- a/qi-sdk/profile/nonlocal/intrinsic.rkt +++ b/qi-sdk/profile/nonlocal/intrinsic.rkt @@ -29,7 +29,6 @@ ;; uninstalled. (define-runtime-path lexical-module-path ".") -(current-load-relative-directory lexical-module-path) (define (benchmark language benchmarks-to-run) (let ([namespace (make-base-namespace)] @@ -37,11 +36,13 @@ (map bm-name specs) benchmarks-to-run)]) (cond [(equal? "qi" language) - (eval '(require "qi/main.rkt") - namespace)] + (parameterize ([current-load-relative-directory lexical-module-path]) + (eval '(require "qi/main.rkt") + namespace))] [(equal? "racket" language) - (eval '(require "racket/main.rkt") - namespace)]) + (parameterize ([current-load-relative-directory lexical-module-path]) + (eval '(require "racket/main.rkt") + namespace))]) (for/list ([spec specs] #:when (member (bm-name spec) benchmarks-to-run)) From 56e7906028c690c6f62bb9994ec6f42f289f476c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 3 May 2023 17:25:38 -0700 Subject: [PATCH 173/338] Simplify syntax-spec grammar We did this in last week's Qi meetup. --- qi-lib/flow.rkt | 2 +- qi-lib/flow/extended/expander.rkt | 116 +++++++++++++----------------- 2 files changed, 52 insertions(+), 66 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index a6b20690b..ad49312f3 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -34,7 +34,7 @@ in the flow macro. (syntax-spec (host-interface/expression - (flow f:floe ...) + (flow f:closed-floe ...) (syntax-parse #'(f ...) [(f) (compile-flow #'f)] ;; a non-flow diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 538a456d7..76ea3f1ad 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -1,7 +1,7 @@ #lang racket/base (provide (for-syntax qi-macro - floe) + closed-floe) (for-space qi (all-defined-out) (rename-out [ground ⏚] @@ -26,13 +26,13 @@ (extension-class qi-macro #:binding-space qi) - (nonterminal floe + (nonterminal closed-floe #:description "a flow expression" - f:threading-floe + f:floe #:binding (nest-one f [])) - (nonterminal/nesting binding-floe (nested) + (nonterminal/nesting floe (nested) #:description "a flow expression" #:allow-extension qi-macro #:binding-space qi @@ -40,37 +40,23 @@ (as v:racket-var ...+) #:binding {(bind v) nested} - f:threading-floe - #:binding (nest-one f nested)) - - (nonterminal/nesting threading-floe (nested) - #:description "a flow expression" - #:allow-extension qi-macro - #:binding-space qi - - (thread f:binding-floe ...) + (thread f:floe ...) #:binding (nest f nested) - (tee f:binding-floe ...) + (tee f:floe ...) #:binding (nest f nested) tee ;; Note: `#:binding nested` is the implicit binding rule here - (relay f:binding-floe ...) + (relay f:floe ...) #:binding (nest f nested) relay ;; [f nested] is the implicit binding rule ;; anything not mentioned (e.g. nested) is treated as a ;; subexpression that's not in any scope - ;; Note: this could be at the top level floe after - ;; binding-floe, but that isnt supported atm because - ;; it doesn't backtrack - _:simple-floe) - - (nonterminal simple-floe - #:description "a flow expression" - #:binding-space qi + ;; Note: once a nonterminal is chosen, it doesn't backtrack + ;; to consider alternatives (gen e:racket-expr ...) ;; Ad hoc expansion rule to allow _ to be used in application @@ -83,7 +69,7 @@ _ ground amp - (amp f:floe) + (amp f:closed-floe) (~>/form (amp f0:clause f:clause ...) ;; potentially pull out as a phase 1 function ;; just a stopgap until better error messages @@ -91,17 +77,17 @@ "(>< flo)" "amp expects a single flow specification, but it received many.")) pass - (pass f:floe) + (pass f:closed-floe) sep - (sep f:floe) + (sep f:closed-floe) collect NOT XOR - (and f:floe ...) - (or f:floe ...) - (not f:floe) - (all f:floe) - (any f:floe) + (and f:closed-floe ...) + (or f:closed-floe ...) + (not f:closed-floe) + (all f:closed-floe) + (any f:closed-floe) (select n:number ...) (~>/form (select arg ...) (report-syntax-error this-syntax @@ -112,62 +98,62 @@ "(block ...)")) (fanout n:racket-expr) fanout - (group n:racket-expr e1:floe e2:floe) + (group n:racket-expr e1:closed-floe e2:closed-floe) group (~>/form (group arg ...) (report-syntax-error this-syntax "(group )")) - (if consequent:floe - alternative:floe) - (if condition:floe - consequent:floe - alternative:floe) - (sieve condition:floe - sonex:floe - ronex:floe) + (if consequent:closed-floe + alternative:closed-floe) + (if condition:closed-floe + consequent:closed-floe + alternative:closed-floe) + (sieve condition:closed-floe + sonex:closed-floe + ronex:closed-floe) sieve (~>/form (sieve arg ...) (report-syntax-error this-syntax "(sieve )")) (partition) - (partition [cond:floe body:floe] ...+) - (try flo:floe - [error-condition-flo:floe error-handler-flo:floe] + (partition [cond:closed-floe body:closed-floe] ...+) + (try flo:closed-floe + [error-condition-flo:closed-floe error-handler-flo:closed-floe] ...+) (~>/form (try arg ...) (report-syntax-error this-syntax "(try [error-predicate-flo error-handler-flo] ...)")) >> - (>> fn:floe init:floe) - (>> fn:floe) + (>> fn:closed-floe init:closed-floe) + (>> fn:closed-floe) << - (<< fn:floe init:floe) - (<< fn:floe) - (feedback ((~datum while) tilex:floe) - ((~datum then) thenex:floe) - onex:floe) - (feedback ((~datum while) tilex:floe) - ((~datum then) thenex:floe)) - (feedback ((~datum while) tilex:floe) onex:floe) - (feedback ((~datum while) tilex:floe)) + (<< fn:closed-floe init:closed-floe) + (<< fn:closed-floe) + (feedback ((~datum while) tilex:closed-floe) + ((~datum then) thenex:closed-floe) + onex:closed-floe) + (feedback ((~datum while) tilex:closed-floe) + ((~datum then) thenex:closed-floe)) + (feedback ((~datum while) tilex:closed-floe) onex:closed-floe) + (feedback ((~datum while) tilex:closed-floe)) (feedback n:racket-expr - ((~datum then) thenex:floe) - onex:floe) + ((~datum then) thenex:closed-floe) + onex:closed-floe) (feedback n:racket-expr - ((~datum then) thenex:floe)) - (feedback n:racket-expr onex:floe) - (feedback onex:floe) + ((~datum then) thenex:closed-floe)) + (feedback n:racket-expr onex:closed-floe) + (feedback onex:closed-floe) feedback - (loop pred:floe mapex:floe combex:floe retex:floe) - (loop pred:floe mapex:floe combex:floe) - (loop pred:floe mapex:floe) - (loop mapex:floe) + (loop pred:closed-floe mapex:closed-floe combex:closed-floe retex:closed-floe) + (loop pred:closed-floe mapex:closed-floe combex:closed-floe) + (loop pred:closed-floe mapex:closed-floe) + (loop mapex:closed-floe) loop - (loop2 pred:floe mapex:floe combex:floe) + (loop2 pred:closed-floe mapex:closed-floe combex:closed-floe) appleye (~> (~literal apply) #'appleye) clos - (clos onex:floe) + (clos onex:closed-floe) (esc ex:racket-expr) ;; backwards compat macro extensibility via Racket macros From 32cdecffe150adf1451e11ac4c164ff4879a570f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 21:49:41 -0700 Subject: [PATCH 174/338] add a restorative optimization for "all" --- qi-lib/flow/core/compiler.rkt | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index fbd0d08b0..edd3c42d4 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -21,7 +21,11 @@ (process-bindings (optimize-flow stx))) (define (optimize-flow stx) - stx)) + (syntax-parse stx + ;; restorative optimization for "all" + [((~datum ~>) ((~datum ><) onex) (~datum AND)) + #`(esc (give (curry andmap #,(compile-flow #'onex))))] + [_ stx]))) ;; Transformation rules for the `as` binding form: ;; From 377f231a3956c1d7d05298a56aa31b14905e87cb Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 21:59:53 -0700 Subject: [PATCH 175/338] simple cases of "deforestation" for values --- qi-lib/flow/core/compiler.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index edd3c42d4..f0b53da82 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -25,6 +25,11 @@ ;; restorative optimization for "all" [((~datum ~>) ((~datum ><) onex) (~datum AND)) #`(esc (give (curry andmap #,(compile-flow #'onex))))] + ;; "deforestation" for values + [((~datum ~>) _0 ... ((~datum pass) f) ((~datum ><) g) _1 ...) + #'(~> _0 ... (>< (if f g ⏚)) _1 ...)] + [((~datum ~>) _0 ... ((~datum ><) g) ((~datum pass) f) _1 ...) + #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] [_ stx]))) ;; Transformation rules for the `as` binding form: From a13b492d7260f8ec6ab0293d4bae1c08b56b89b0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 22:26:20 -0700 Subject: [PATCH 176/338] basic optimization loop --- qi-lib/flow/core/compiler.rkt | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index f0b53da82..6bb4fb762 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -20,7 +20,7 @@ (define (compile-flow stx) (process-bindings (optimize-flow stx))) - (define (optimize-flow stx) + (define (optimization-pass stx) (syntax-parse stx ;; restorative optimization for "all" [((~datum ~>) ((~datum ><) onex) (~datum AND)) @@ -30,7 +30,13 @@ #'(~> _0 ... (>< (if f g ⏚)) _1 ...)] [((~datum ~>) _0 ... ((~datum ><) g) ((~datum pass) f) _1 ...) #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] - [_ stx]))) + [_ stx])) + + (define (optimize-flow stx) + (let ([optimized (optimization-pass stx)]) + (if (eq? optimized stx) + stx + (optimize-flow optimized))))) ;; Transformation rules for the `as` binding form: ;; From e945a4c01a80d173bd2fd907d50963422cea831a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 22:32:06 -0700 Subject: [PATCH 177/338] merge amps in sequence --- qi-lib/flow/core/compiler.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 6bb4fb762..397a6a419 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -30,6 +30,8 @@ #'(~> _0 ... (>< (if f g ⏚)) _1 ...)] [((~datum ~>) _0 ... ((~datum ><) g) ((~datum pass) f) _1 ...) #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] + [((~datum ~>) _0 ... ((~datum ><) f) ((~datum ><) g) _1 ...) + #'(~> _0 ... (>< (~> f g)) _1 ...)] [_ stx])) (define (optimize-flow stx) From e88a846ccd1d7b17f95a88161ed309249de16ef0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 22:36:19 -0700 Subject: [PATCH 178/338] flatten nested compositions (associative law) --- qi-lib/flow/core/compiler.rkt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 397a6a419..5c90cbbfb 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -32,6 +32,10 @@ #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] [((~datum ~>) _0 ... ((~datum ><) f) ((~datum ><) g) _1 ...) #'(~> _0 ... (>< (~> f g)) _1 ...)] + [((~datum ~>) _0 ... ((~datum ~>) f ...) _1 ...) + #'(~> _0 ... f ... _1 ...)] + [((~datum ~>>) _0 ... ((~datum ~>>) f ...) _1 ...) + #'(~>> _0 ... f ... _1 ...)] [_ stx])) (define (optimize-flow stx) From edb6ca4dd72823d5b3c456a1cd65c17f907b87cf Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 22:41:40 -0700 Subject: [PATCH 179/338] eliminate superfluous identity flows --- qi-lib/flow/core/compiler.rkt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 5c90cbbfb..8da6cdd93 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -36,6 +36,10 @@ #'(~> _0 ... f ... _1 ...)] [((~datum ~>>) _0 ... ((~datum ~>>) f ...) _1 ...) #'(~>> _0 ... f ... _1 ...)] + [((~datum ~>) _0 ... (~datum _) _1 ...) + #'(~> _0 ... _1 ...)] + [((~datum ~>>) _0 ... (~datum _) _1 ...) + #'(~>> _0 ... _1 ...)] [_ stx])) (define (optimize-flow stx) From 886c257e99f4c8c2b0dd717a01cbf1f4530d8968 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 22:50:40 -0700 Subject: [PATCH 180/338] incorporate various identities as optimizations --- qi-lib/flow/core/compiler.rkt | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 8da6cdd93..49f287033 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -40,6 +40,20 @@ #'(~> _0 ... _1 ...)] [((~datum ~>>) _0 ... (~datum _) _1 ...) #'(~>> _0 ... _1 ...)] + [((~datum ~>) (~datum _) ...) + #'_] + [((~datum ==) (~datum _) ...) + #'_] + [((~datum ><) (~datum _)) + #'_] + [((~datum -<) f) + #'f] + [((~datum -<) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + #'(-< _0 ... (gen a ... b ...) _1 ...)] + [((~datum ~>) _0 ... (~datum △) (~datum ▽) _1 ...) + #'(~> _0 ... _1 ...)] + [((~datum ~>) _0 ... (~datum ▽) (~datum △) _1 ...) + #'(~> _0 ... _1 ...)] [_ stx])) (define (optimize-flow stx) From e880bce6480915b92a5f2ca599d39e499dae50cc Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 22:56:58 -0700 Subject: [PATCH 181/338] add some comments --- qi-lib/flow/core/compiler.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 49f287033..145eb2b60 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -30,8 +30,10 @@ #'(~> _0 ... (>< (if f g ⏚)) _1 ...)] [((~datum ~>) _0 ... ((~datum ><) g) ((~datum pass) f) _1 ...) #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] + ;; merge amps in sequence [((~datum ~>) _0 ... ((~datum ><) f) ((~datum ><) g) _1 ...) #'(~> _0 ... (>< (~> f g)) _1 ...)] + ;; identities [((~datum ~>) _0 ... ((~datum ~>) f ...) _1 ...) #'(~> _0 ... f ... _1 ...)] [((~datum ~>>) _0 ... ((~datum ~>>) f ...) _1 ...) @@ -54,6 +56,7 @@ #'(~> _0 ... _1 ...)] [((~datum ~>) _0 ... (~datum ▽) (~datum △) _1 ...) #'(~> _0 ... _1 ...)] + ;; return syntax unchanged if there are no known optimizations [_ stx])) (define (optimize-flow stx) From df7ce49086123674381425a43c1e5d78a0a26e7d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 22:58:28 -0700 Subject: [PATCH 182/338] merge `pass` filters in sequence by conjoining the predicates --- qi-lib/flow/core/compiler.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 145eb2b60..7559598a2 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -33,6 +33,9 @@ ;; merge amps in sequence [((~datum ~>) _0 ... ((~datum ><) f) ((~datum ><) g) _1 ...) #'(~> _0 ... (>< (~> f g)) _1 ...)] + ;; merge pass filters in sequence + [((~datum ~>) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) + #'(~> _0 ... (pass (and f g)) _1 ...)] ;; identities [((~datum ~>) _0 ... ((~datum ~>) f ...) _1 ...) #'(~> _0 ... f ... _1 ...)] From e54dc4e8f49e539cb9add21a1edb2365da21f2c8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 15 Sep 2022 23:04:30 -0700 Subject: [PATCH 183/338] note a todo --- qi-lib/flow/core/compiler.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 7559598a2..2fede4000 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -32,7 +32,7 @@ #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] ;; merge amps in sequence [((~datum ~>) _0 ... ((~datum ><) f) ((~datum ><) g) _1 ...) - #'(~> _0 ... (>< (~> f g)) _1 ...)] + #'(~> _0 ... (>< (~> f g)) _1 ...)] ; TODO: optimizing the inner flow? ;; merge pass filters in sequence [((~datum ~>) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) #'(~> _0 ... (pass (and f g)) _1 ...)] From 2618d71c4fc6b081a745fbae13d0dd3693056348 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 16 Sep 2022 09:08:33 -0700 Subject: [PATCH 184/338] more comments --- qi-lib/flow/core/compiler.rkt | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 2fede4000..92c6ee7c3 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -36,25 +36,32 @@ ;; merge pass filters in sequence [((~datum ~>) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) #'(~> _0 ... (pass (and f g)) _1 ...)] - ;; identities + ;; associative laws for ~> [((~datum ~>) _0 ... ((~datum ~>) f ...) _1 ...) #'(~> _0 ... f ... _1 ...)] [((~datum ~>>) _0 ... ((~datum ~>>) f ...) _1 ...) #'(~>> _0 ... f ... _1 ...)] + ;; left and right identity for ~> [((~datum ~>) _0 ... (~datum _) _1 ...) #'(~> _0 ... _1 ...)] [((~datum ~>>) _0 ... (~datum _) _1 ...) #'(~>> _0 ... _1 ...)] + ;; composition of identity flows is the identity flow [((~datum ~>) (~datum _) ...) #'_] + ;; identity flows composed using a relay [((~datum ==) (~datum _) ...) #'_] + ;; amp and identity [((~datum ><) (~datum _)) #'_] + ;; trivial tee junction [((~datum -<) f) #'f] + ;; merge adjacent gens [((~datum -<) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) #'(-< _0 ... (gen a ... b ...) _1 ...)] + ;; prism identities [((~datum ~>) _0 ... (~datum △) (~datum ▽) _1 ...) #'(~> _0 ... _1 ...)] [((~datum ~>) _0 ... (~datum ▽) (~datum △) _1 ...) From b06e88dc62178ba6dafd1b01498e5a62ced8a120 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 16 Sep 2022 09:11:44 -0700 Subject: [PATCH 185/338] collapse deterministic conditionals --- qi-lib/flow/core/compiler.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 92c6ee7c3..a3e7be996 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -36,6 +36,9 @@ ;; merge pass filters in sequence [((~datum ~>) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) #'(~> _0 ... (pass (and f g)) _1 ...)] + ;; collapse deterministic conditionals + [((~datum if) (~datum #t) f g) #'f] + [((~datum if) (~datum #f) f g) #'g] ;; associative laws for ~> [((~datum ~>) _0 ... ((~datum ~>) f ...) _1 ...) #'(~> _0 ... f ... _1 ...)] From 47f38665d0d59ffbfbcaf6bd9c59c31a7adadad2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 16 Sep 2022 09:21:00 -0700 Subject: [PATCH 186/338] note about optimizing "active" components of optimized expansions --- qi-lib/flow/core/compiler.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index a3e7be996..23afbc130 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -21,6 +21,9 @@ (process-bindings (optimize-flow stx))) (define (optimization-pass stx) + ;; TODO: the "active" components of the expansions should be + ;; optimized, i.e. they should be wrapped with a recursive + ;; call to the optimizer (syntax-parse stx ;; restorative optimization for "all" [((~datum ~>) ((~datum ><) onex) (~datum AND)) @@ -32,7 +35,7 @@ #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] ;; merge amps in sequence [((~datum ~>) _0 ... ((~datum ><) f) ((~datum ><) g) _1 ...) - #'(~> _0 ... (>< (~> f g)) _1 ...)] ; TODO: optimizing the inner flow? + #`(~> _0 ... #,(optimization-pass #'(>< (~> f g))) _1 ...)] ;; merge pass filters in sequence [((~datum ~>) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) #'(~> _0 ... (pass (and f g)) _1 ...)] From dacdc68c0ef2f5fdc5d78645955dfb1b74161028 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 28 Sep 2022 00:47:50 -0700 Subject: [PATCH 187/338] use core language words instead of symbols in optimizations --- qi-lib/flow/core/compiler.rkt | 50 ++++++++++++++++------------------- 1 file changed, 23 insertions(+), 27 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 23afbc130..2ddcfd8a9 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -26,52 +26,48 @@ ;; call to the optimizer (syntax-parse stx ;; restorative optimization for "all" - [((~datum ~>) ((~datum ><) onex) (~datum AND)) + [((~datum thread) ((~datum amp) onex) (~datum AND)) #`(esc (give (curry andmap #,(compile-flow #'onex))))] ;; "deforestation" for values - [((~datum ~>) _0 ... ((~datum pass) f) ((~datum ><) g) _1 ...) - #'(~> _0 ... (>< (if f g ⏚)) _1 ...)] - [((~datum ~>) _0 ... ((~datum ><) g) ((~datum pass) f) _1 ...) - #'(~> _0 ... (>< (~> g (if f _ ⏚))) _1 ...)] + [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) + #'(thread _0 ... (amp (if f g ground)) _1 ...)] + [((~datum thread) _0 ... ((~datum amp) g) ((~datum pass) f) _1 ...) + #'(thread _0 ... (amp (thread g (if f _ ground))) _1 ...)] ;; merge amps in sequence - [((~datum ~>) _0 ... ((~datum ><) f) ((~datum ><) g) _1 ...) - #`(~> _0 ... #,(optimization-pass #'(>< (~> f g))) _1 ...)] + [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) + #`(thread _0 ... #,(optimization-pass #'(amp (thread f g))) _1 ...)] ;; merge pass filters in sequence - [((~datum ~>) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) - #'(~> _0 ... (pass (and f g)) _1 ...)] + [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) + #'(thread _0 ... (pass (and f g)) _1 ...)] ;; collapse deterministic conditionals [((~datum if) (~datum #t) f g) #'f] [((~datum if) (~datum #f) f g) #'g] ;; associative laws for ~> - [((~datum ~>) _0 ... ((~datum ~>) f ...) _1 ...) - #'(~> _0 ... f ... _1 ...)] - [((~datum ~>>) _0 ... ((~datum ~>>) f ...) _1 ...) - #'(~>> _0 ... f ... _1 ...)] + [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) + #'(thread _0 ... f ... _1 ...)] ;; left and right identity for ~> - [((~datum ~>) _0 ... (~datum _) _1 ...) - #'(~> _0 ... _1 ...)] - [((~datum ~>>) _0 ... (~datum _) _1 ...) - #'(~>> _0 ... _1 ...)] + [((~datum thread) _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] ;; composition of identity flows is the identity flow - [((~datum ~>) (~datum _) ...) + [((~datum thread) (~datum _) ...) #'_] ;; identity flows composed using a relay - [((~datum ==) (~datum _) ...) + [((~datum relay) (~datum _) ...) #'_] ;; amp and identity - [((~datum ><) (~datum _)) + [((~datum amp) (~datum _)) #'_] ;; trivial tee junction - [((~datum -<) f) + [((~datum tee) f) #'f] ;; merge adjacent gens - [((~datum -<) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) - #'(-< _0 ... (gen a ... b ...) _1 ...)] + [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + #'(tee _0 ... (gen a ... b ...) _1 ...)] ;; prism identities - [((~datum ~>) _0 ... (~datum △) (~datum ▽) _1 ...) - #'(~> _0 ... _1 ...)] - [((~datum ~>) _0 ... (~datum ▽) (~datum △) _1 ...) - #'(~> _0 ... _1 ...)] + [((~datum thread) _0 ... (~datum sep) (~datum collect) _1 ...) + #'(thread _0 ... _1 ...)] + [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) + #'(thread _0 ... _1 ...)] ;; return syntax unchanged if there are no known optimizations [_ stx])) From 59502ea15dfda01b202df236b206ece299963077 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 28 Sep 2022 20:56:53 -0700 Subject: [PATCH 188/338] don't optimize prisms where it expects a list input specifically --- qi-lib/flow/core/compiler.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 2ddcfd8a9..586fa95c5 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -64,8 +64,9 @@ [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) #'(tee _0 ... (gen a ... b ...) _1 ...)] ;; prism identities - [((~datum thread) _0 ... (~datum sep) (~datum collect) _1 ...) - #'(thread _0 ... _1 ...)] + ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's + ;; only valid if the input is in fact a list, and is an error otherwise, + ;; and we can only know this at runtime. [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) #'(thread _0 ... _1 ...)] ;; return syntax unchanged if there are no known optimizations From 257eebe2240a331a148e94b8e038a36957d031a5 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 29 Sep 2022 17:57:13 -0700 Subject: [PATCH 189/338] rudimentary deforestation --- qi-lib/flow/core/compiler.rkt | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 586fa95c5..b791b5854 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -69,6 +69,39 @@ ;; and we can only know this at runtime. [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) #'(thread _0 ... _1 ...)] + ;; Deforestation + ;; (~> (>< f) (pass g)) → (~> (>< (if g f ⏚))) + [((~datum thread) ((~datum amp) f) ((~datum pass) g)) #'(thread (amp (if g f ground)))] + ;; TODO: propagate the syntax property instead + ;; (~> (filter f) (map g)) → (~> (foldr [f+g] ...))) + [((~datum thread) _0 ... + ((~datum #%partial-application) ((~literal filter) g)) + ((~datum #%partial-application) ((~literal map) f)) + _1 ...) + #'(thread _0 ... + (#%fine-template + (foldr (λ (v vs) + (if (g v) + (cons (f v) vs) + vs)) + null + _)) + _1 ...)] + ;; (~> (map f) (filter g)) → (~> (foldr [f+g] ...))) + [((~datum thread) _0 ... + ((~datum #%partial-application) ((~literal map) f)) + ((~datum #%partial-application) ((~literal filter) g)) + _1 ...) + #'(thread _0 ... + (#%fine-template + (foldr (λ (v vs) + (let ([result (f v)]) + (if (g result) + (cons result vs) + vs))) + null + _)) + _1 ...)] ;; return syntax unchanged if there are no known optimizations [_ stx])) From 48930780e5aa45749c8f265ac94b029b5906d86a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 4 Oct 2022 18:37:47 -0700 Subject: [PATCH 190/338] remove invalid deforestation optimization (noted in CR) --- qi-lib/flow/core/compiler.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index b791b5854..c2dd198d3 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -29,8 +29,10 @@ [((~datum thread) ((~datum amp) onex) (~datum AND)) #`(esc (give (curry andmap #,(compile-flow #'onex))))] ;; "deforestation" for values + ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) #'(thread _0 ... (amp (if f g ground)) _1 ...)] + ;; (~> (>< g) (pass f)) → (>< (~> g (if f _ ⏚))) [((~datum thread) _0 ... ((~datum amp) g) ((~datum pass) f) _1 ...) #'(thread _0 ... (amp (thread g (if f _ ground))) _1 ...)] ;; merge amps in sequence @@ -69,9 +71,7 @@ ;; and we can only know this at runtime. [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) #'(thread _0 ... _1 ...)] - ;; Deforestation - ;; (~> (>< f) (pass g)) → (~> (>< (if g f ⏚))) - [((~datum thread) ((~datum amp) f) ((~datum pass) g)) #'(thread (amp (if g f ground)))] + ;; Deforestation for lists ;; TODO: propagate the syntax property instead ;; (~> (filter f) (map g)) → (~> (foldr [f+g] ...))) [((~datum thread) _0 ... From e3dc00f38a903f02a4dc7e943e56777fcca1555a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 11 Oct 2022 19:17:12 -0700 Subject: [PATCH 191/338] remove invalid optimization (CR) --- qi-lib/flow/core/compiler.rkt | 3 --- 1 file changed, 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index c2dd198d3..4326164aa 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -32,9 +32,6 @@ ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) #'(thread _0 ... (amp (if f g ground)) _1 ...)] - ;; (~> (>< g) (pass f)) → (>< (~> g (if f _ ⏚))) - [((~datum thread) _0 ... ((~datum amp) g) ((~datum pass) f) _1 ...) - #'(thread _0 ... (amp (thread g (if f _ ground))) _1 ...)] ;; merge amps in sequence [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) #`(thread _0 ... #,(optimization-pass #'(amp (thread f g))) _1 ...)] From 0e60aa9bbce582a145eea6cb7705556852a48868 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 11 Oct 2022 20:55:27 -0700 Subject: [PATCH 192/338] add tests to check known counterexamples to seeming equivalences --- qi-test/tests/flow.rkt | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 61385b52f..6dae428f0 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1487,7 +1487,32 @@ (check-equal? ((☯ (~> (pass positive?) +)) 1 -3 5) 6 - "runtime arity changes in threading form")))) + "runtime arity changes in threading form")) + + (test-suite + "nonlocal semantics" + ;; these are collected from counterexamples to candidate equivalences + ;; that turned up during code review. They ensure that some tempting + ;; "equivalences" that are not really equivalences are formally checked + (let () + (define-flow g (-< add1 sub1)) + (define-flow f positive?) + (define (f* x y) (= (sub1 x) (add1 y))) + (define (amp-pass g f) (☯ (~> (>< g) (pass f) ▽))) + (define (amp-if g f) (☯ (~> (>< (~> g (if f _ ground))) ▽))) + (check-equal? (apply (amp-pass g f) (range -3 4)) + (list 1 2 3 1 4 2)) + (check-exn exn:fail? + (thunk (apply (amp-if g f) (range -3 4)))) + (check-exn exn:fail? + (thunk (apply (amp-pass g f*) (range -3 4)))) + (check-equal? (apply (amp-if g f*) (range -3 4)) + (list -2 -4 -1 -3 0 -2 1 -1 2 0 3 1 4 2))) + (let () + (check-equal? ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") + 2) + (check-equal? ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") + (list #f 2 #f)))))) (module+ main (void (run-tests tests))) From 0822aa1519849098bb1bd4028bcd7757847ff450 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Feb 2023 17:09:26 -0800 Subject: [PATCH 193/338] collapse singleton threading form --- qi-lib/flow/core/compiler.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 4326164aa..d21eead80 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -41,6 +41,9 @@ ;; collapse deterministic conditionals [((~datum if) (~datum #t) f g) #'f] [((~datum if) (~datum #f) f g) #'g] + ;; trivial threading form + [((~datum thread) f) + #'f] ;; associative laws for ~> [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) #'(thread _0 ... f ... _1 ...)] From 3c8d6c7db997737c56717f97971a72559efed15f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 4 Aug 2023 16:21:05 -0700 Subject: [PATCH 194/338] Commit wip from today's meeting - define a new "large list" benchmark exerciser - simple list-based functional pipeline for filter-map - fold universality baseline implementation - stream fusion - various hand optimized stages on top of stream fusion See https://github.com/drym-org/qi/wiki/Qi-Compiler-Sync-Aug-4-2023 --- qi-sdk/profile/nonlocal/qi/main.rkt | 189 +++++++++++++++++++++++++++- qi-sdk/profile/nonlocal/spec.rkt | 3 + qi-sdk/profile/util.rkt | 7 ++ 3 files changed, 197 insertions(+), 2 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index c4dc012c5..02536705b 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -1,5 +1,7 @@ #lang racket/base +(require racket/match) + (provide conditionals composition root-mean-square @@ -54,8 +56,191 @@ cons)])) -(define-flow filter-map - (~> △ (>< (if odd? sqr ⏚)) ▽)) +;; (define-flow filter-map +;; (~> △ (>< (if odd? sqr ⏚)) ▽)) + +;; (define-flow filter-map +;; (~>> (filter odd?) (map sqr))) + +;; (define (filter-map lst) +;; (foldr (λ (v vs) +;; (if (odd? v) +;; (cons (sqr v) vs) +;; vs)) +;; null +;; lst)) + +(struct stream (next state) + #:transparent) + +(define (map-stream f s) + (define (next state) + (match ((stream-next s) state) + ['done 'done] + [(cons 'skip new-state) (cons 'skip new-state)] + [(list 'yield value new-state) + (list 'yield (f value) new-state)])) + (stream next (stream-state s))) + +(define (filter-stream f s) + (define (next state) + (match ((stream-next s) state) + ['done 'done] + [(cons 'skip new-state) (cons 'skip new-state)] + [(list 'yield value new-state) + (if (f value) + (list 'yield value new-state) + (cons 'skip new-state))])) + (stream next (stream-state s))) + +(define (list->stream lst) + (define (next state) + (cond [(null? state) 'done] + [else (list 'yield (car state) (cdr state))])) + (stream next lst)) + +(define (stream->list s) + (match ((stream-next s) (stream-state s)) + ['done null] + [(cons 'skip state) + (stream->list (stream (stream-next s) state))] + [(list 'yield value state) + (cons value + (stream->list (stream (stream-next s) state)))])) + +;; (define (filter-map lst) +;; (let ([s (list->stream lst)]) +;; (stream->list (map-stream sqr (filter-stream odd? s))))) + +;; This is the result of inline all of the stream operations +;; (define (filter-map lst) +;; (define (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (let ([s (stream next-list->stream lst)]) +;; (define (next-filter-stream state) +;; (match ((stream-next s) state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])) +;; (let ([s (stream next-filter-stream (stream-state s))]) +;; (define (next-map-stream state) +;; (match ((stream-next s) state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([s (stream next-map-stream (stream-state s))]) +;; (stream->list s))))) + +;; partially evaluate accessors to stream constructor +;; (define (filter-map lst) +;; (define (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (let ([s (stream next-list->stream lst)]) +;; (define (next-filter-stream state) +;; (match (next-list->stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])) +;; (let ([s (stream next-filter-stream lst)]) +;; (define (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([s (stream next-map-stream lst)]) +;; (stream->list s))))) + +;; dead code elimination (eliminate unused binding forms) +;; (define (filter-map lst) +;; (define (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (define (next-filter-stream state) +;; (match (next-list->stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])) +;; (define (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([s (stream next-map-stream lst)]) +;; (stream->list s))) + +;; case of case +;; when there is a conditional based on the return value of a conditional +;; invert which conditional is checked first +;; (define (filter-map lst) +;; (define (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (define (next-filter-stream state) +;; (cond [(null? state) (match 'done +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])] +;; [else (match (list 'yield (car state) (cdr state)) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])])) +;; (define (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([s (stream next-map-stream lst)]) +;; (stream->list s))) + +;; partially evaluate match on known argument +(define (filter-map lst) + (define (next-list->stream state) + (cond [(null? state) 'done] + [else (list 'yield (car state) (cdr state))])) + (define (next-filter-stream state) + (cond [(null? state) (match 'done + ['done 'done] + [(cons 'skip new-state) (cons 'skip new-state)] + [(list 'yield value new-state) + (if (odd? value) + (list 'yield value new-state) + (cons 'skip new-state))])] + [else (match (list 'yield (car state) (cdr state)) + ['done 'done] + [(cons 'skip new-state) (cons 'skip new-state)] + [(list 'yield value new-state) + (if (odd? value) + (list 'yield value new-state) + (cons 'skip new-state))])])) + (define (next-map-stream state) + (match (next-filter-stream state) + ['done 'done] + [(cons 'skip new-state) (cons 'skip new-state)] + [(list 'yield value new-state) + (list 'yield (sqr value) new-state)])) + (let ([s (stream next-map-stream lst)]) + (stream->list s))) (define-flow filter-map-values (>< (if odd? sqr ⏚))) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index addaa412d..5ca9d2672 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -21,6 +21,9 @@ (bm "filter-map" check-list 500000) + (bm "filter-map (large list)" + check-large-list + 50000) (bm "filter-map-values" check-values 500000) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index a751e2123..c8a3c8972 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -5,6 +5,7 @@ check-value check-value-primes check-list + check-large-list check-values check-two-values run-benchmark @@ -70,6 +71,12 @@ (for ([i how-many]) (fn vs)))) +(define (check-large-list fn how-many) + ;; call a function with a single list argument + (let ([vs (range 1000)]) + (for ([i how-many]) + (fn vs)))) + ;; This uses the same input values each time. See the note ;; above for check-list in this connection. (define (check-values fn how-many) From f7052e2511374b8961ed64526796d9227684fabb Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 11 Aug 2023 13:34:45 -0700 Subject: [PATCH 195/338] wip from today's meeting (ignition!) - additional inlining - used some Racket compiler hooks to trigger inlining - notes on trying multiple values instead of variable-sized lists - continuation passing style --- qi-sdk/profile/nonlocal/qi/main.rkt | 250 ++++++++++++++++++++++++---- 1 file changed, 216 insertions(+), 34 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 02536705b..d59902195 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -2,6 +2,8 @@ (require racket/match) +(require racket/performance-hint) + (provide conditionals composition root-mean-square @@ -99,14 +101,67 @@ [else (list 'yield (car state) (cdr state))])) (stream next lst)) +;; continuation version +;; a lambda that does not escape is equivalent to a goto +;; lambda the ultimate goto by guy steele +(begin-encourage-inline + (define-inline (cstream->list next) + (λ (state) + (let loop ([state state]) + ((next (λ () null) + (λ (state) (loop state)) + (λ (value state) + (cons value (loop state)))) + state)))) + + (define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) + + (define-inline ((map-cstream-next f next) done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state)))) + + (define-inline ((filter-cstream-next f next) done skip yield) + (next done + skip + (λ (value state) + (if (f value) + (yield value state) + (skip state)))))) + +;; except for cstream->list, it's all CPS with tail recursion +(define (filter-map lst) + ((cstream->list + (map-cstream-next sqr + (filter-cstream-next odd? + list->cstream-next))) + lst)) + + +;; (define (stream->list s) +;; (match ((stream-next s) (stream-state s)) +;; ['done null] +;; [(cons 'skip state) +;; (stream->list (stream (stream-next s) state))] +;; [(list 'yield value state) +;; (cons value +;; (stream->list (stream (stream-next s) state)))])) + (define (stream->list s) - (match ((stream-next s) (stream-state s)) - ['done null] - [(cons 'skip state) - (stream->list (stream (stream-next s) state))] - [(list 'yield value state) - (cons value - (stream->list (stream (stream-next s) state)))])) + (let ([next (stream-next s)] + [state (stream-state s)]) + (let loop ([state state]) + (match (next state) + ['done null] + [(cons 'skip state) + (loop state)] + [(list 'yield value state) + (cons value + (loop state))])))) ;; (define (filter-map lst) ;; (let ([s (list->stream lst)]) @@ -182,6 +237,131 @@ ;; (let ([s (stream next-map-stream lst)]) ;; (stream->list s))) +;; inline stream->list as well +;; (define (filter-map lst) +;; (define (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (define (next-filter-stream state) +;; (match (next-list->stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])) +;; (define (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([next next-map-stream] +;; [state lst]) +;; (let loop ([state state]) +;; (match (next state) +;; ['done null] +;; [(cons 'skip state) +;; (loop state)] +;; [(list 'yield value state) +;; (cons value +;; (loop state))])))) + +;; try with inlining macro +;; (require racket/performance-hint) + +;; (define (filter-map lst) +;; (define-inline (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (define-inline (next-filter-stream state) +;; (match (next-list->stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])) +;; (define-inline (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([next next-map-stream] +;; [state lst]) +;; (let loop ([state state]) +;; (match (next state) +;; ['done null] +;; [(cons 'skip state) +;; (loop state)] +;; [(list 'yield value state) +;; (cons value +;; (loop state))])))) + +;; return multiple values -- instead of cons skip or list yield, return values instead +;; always return exactly three values +;; (values skip new-state #f) +;; (values done #f #f) +;; every match is going to be a case on the first value of the return +;; chez scheme would kick in and result could be pretty good (CP0) +;; (define (filter-map lst) +;; (define-inline (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (define-inline (next-filter-stream state) +;; (match (next-list->stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])) +;; (define-inline (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([next next-map-stream] +;; [state lst]) +;; (let loop ([state state]) +;; (match (next state) +;; ['done null] +;; [(cons 'skip state) +;; (loop state)] +;; [(list 'yield value state) +;; (cons value +;; (loop state))])))) + +;; inline next-list->stream into next-filter-stream +;; (define (filter-map lst) +;; (define (next-filter-stream state) +;; (match (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))]) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])) +;; (define (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([next next-map-stream] +;; [state lst]) +;; (let loop ([state state]) +;; (match (next state) +;; ['done null] +;; [(cons 'skip state) +;; (loop state)] +;; [(list 'yield value state) +;; (cons value +;; (loop state))])))) + ;; case of case ;; when there is a conditional based on the return value of a conditional ;; invert which conditional is checked first @@ -214,33 +394,35 @@ ;; (stream->list s))) ;; partially evaluate match on known argument -(define (filter-map lst) - (define (next-list->stream state) - (cond [(null? state) 'done] - [else (list 'yield (car state) (cdr state))])) - (define (next-filter-stream state) - (cond [(null? state) (match 'done - ['done 'done] - [(cons 'skip new-state) (cons 'skip new-state)] - [(list 'yield value new-state) - (if (odd? value) - (list 'yield value new-state) - (cons 'skip new-state))])] - [else (match (list 'yield (car state) (cdr state)) - ['done 'done] - [(cons 'skip new-state) (cons 'skip new-state)] - [(list 'yield value new-state) - (if (odd? value) - (list 'yield value new-state) - (cons 'skip new-state))])])) - (define (next-map-stream state) - (match (next-filter-stream state) - ['done 'done] - [(cons 'skip new-state) (cons 'skip new-state)] - [(list 'yield value new-state) - (list 'yield (sqr value) new-state)])) - (let ([s (stream next-map-stream lst)]) - (stream->list s))) +;; (define (filter-map lst) +;; (define (next-list->stream state) +;; (cond [(null? state) 'done] +;; [else (list 'yield (car state) (cdr state))])) +;; (define (next-filter-stream state) +;; (cond [(null? state) (match 'done +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])] +;; [else (match (list 'yield (car state) (cdr state)) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state))])])) +;; (define (next-map-stream state) +;; (match (next-filter-stream state) +;; ['done 'done] +;; [(cons 'skip new-state) (cons 'skip new-state)] +;; [(list 'yield value new-state) +;; (list 'yield (sqr value) new-state)])) +;; (let ([s (stream next-map-stream lst)]) +;; (stream->list s))) + +;; (define-flow filter-map-values (>< (if odd? sqr ⏚))) From 7725222d13e0be8c92e11afeaea1259d7de5fde8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 11 Aug 2023 15:05:31 -0700 Subject: [PATCH 196/338] implement filter-map using multiple values instead of allocated data (continuing from today's meeting) --- qi-sdk/profile/nonlocal/qi/main.rkt | 54 ++++++++++++++++++----------- 1 file changed, 33 insertions(+), 21 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index d59902195..b5d497cb6 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -307,32 +307,44 @@ ;; chez scheme would kick in and result could be pretty good (CP0) ;; (define (filter-map lst) ;; (define-inline (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) +;; (cond [(null? state) (values 'done #f #f)] +;; [else (values 'yield (car state) (cdr state))])) ;; (define-inline (next-filter-stream state) -;; (match (next-list->stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])) +;; (call-with-values +;; (λ () +;; (next-list->stream state)) +;; (λ (type value new-state) +;; (case type +;; [(done) (values 'done #f #f)] +;; [(skip) (values 'skip #f new-state)] +;; [(yield) +;; (if (odd? value) +;; (values 'yield value new-state) +;; (values 'skip #f new-state))])))) ;; (define-inline (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) +;; (call-with-values +;; (λ () +;; (next-filter-stream state)) +;; (λ (type value new-state) +;; (case type +;; [(done) (values 'done #f #f)] +;; [(skip) (values 'skip #f new-state)] +;; [(yield) +;; (values 'yield (sqr value) new-state)])))) ;; (let ([next next-map-stream] ;; [state lst]) ;; (let loop ([state state]) -;; (match (next state) -;; ['done null] -;; [(cons 'skip state) -;; (loop state)] -;; [(list 'yield value state) -;; (cons value -;; (loop state))])))) +;; (call-with-values +;; (λ () +;; (next state)) +;; (λ (type value new-state) +;; (case type +;; [(done) null] +;; [(skip) +;; (loop new-state)] +;; [(yield) +;; (cons value +;; (loop new-state))])))))) ;; inline next-list->stream into next-filter-stream ;; (define (filter-map lst) From 6af0d31be59e4f708e4f6cb2f456f9648d6a1d11 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 12 Aug 2023 00:58:22 -0700 Subject: [PATCH 197/338] add version from ben with partially evaluated match, for completeness --- qi-sdk/profile/nonlocal/qi/main.rkt | 21 +++++++-------------- 1 file changed, 7 insertions(+), 14 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index b5d497cb6..6767a9dc6 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -411,20 +411,13 @@ ;; (cond [(null? state) 'done] ;; [else (list 'yield (car state) (cdr state))])) ;; (define (next-filter-stream state) -;; (cond [(null? state) (match 'done -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])] -;; [else (match (list 'yield (car state) (cdr state)) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])])) +;; (cond [(null? state) 'done] +;; [else +;; (let ([value (car state)] +;; [new-state (cdr state)]) +;; (if (odd? value) +;; (list 'yield value new-state) +;; (cons 'skip new-state)))])) ;; (define (next-map-stream state) ;; (match (next-filter-stream state) ;; ['done 'done] From 7d7b8f0ab55c953d32fe3b47b5763eef8c9e152b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 15 Aug 2023 01:07:13 -0700 Subject: [PATCH 198/338] add the hand-coded iteration (upper bound on performance) --- qi-sdk/profile/nonlocal/qi/main.rkt | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 6767a9dc6..14ef18ebb 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -141,6 +141,15 @@ list->cstream-next))) lst)) +;; hand-coded iteration (representing the upper bound on performance) +;; (define (filter-map lst) +;; (if (null? lst) +;; '() +;; (let ([v (car lst)]) +;; (if (odd? v) +;; (cons (sqr v) (filter-map (cdr lst))) +;; (filter-map (cdr lst)))))) + ;; (define (stream->list s) ;; (match ((stream-next s) (stream-state s)) From 2b8483d9491c340ac97489fa1b754852d1a0852e Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 18 Aug 2023 08:52:30 -0700 Subject: [PATCH 199/338] add `range-map-sum` benchmark (used in St-Amour's writeup) --- qi-sdk/profile/nonlocal/intrinsic.rkt | 4 +++- qi-sdk/profile/nonlocal/qi/main.rkt | 7 +++++++ qi-sdk/profile/nonlocal/racket/main.rkt | 7 +++++++ qi-sdk/profile/nonlocal/spec.rkt | 7 ++++++- qi-sdk/profile/util.rkt | 7 +++++-- 5 files changed, 28 insertions(+), 4 deletions(-) diff --git a/qi-sdk/profile/nonlocal/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt index 6607f1844..b5c04ad1b 100755 --- a/qi-sdk/profile/nonlocal/intrinsic.rkt +++ b/qi-sdk/profile/nonlocal/intrinsic.rkt @@ -48,6 +48,8 @@ #:when (member (bm-name spec) benchmarks-to-run)) (let ([name (bm-name spec)] [exerciser (bm-exerciser spec)] - [f (eval (read (open-input-string (bm-name spec))) namespace)] + [f (eval + ;; the first datum in the benchmark name needs to be a function name + (read (open-input-string (bm-name spec))) namespace)] [n-times (bm-times spec)]) (run-nonlocal-benchmark name exerciser f n-times))))) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 14ef18ebb..ce97cda82 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -13,6 +13,7 @@ collatz filter-map filter-map-values + range-map-sum double-list double-values) @@ -141,6 +142,12 @@ list->cstream-next))) lst)) +(define (~sum vs) + (apply + vs)) + +(define-flow range-map-sum + (~>> (range 1) (map sqr) ~sum)) + ;; hand-coded iteration (representing the upper bound on performance) ;; (define (filter-map lst) ;; (if (null? lst) diff --git a/qi-sdk/profile/nonlocal/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt index 4e80ae24f..035bfb8fc 100644 --- a/qi-sdk/profile/nonlocal/racket/main.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -9,6 +9,7 @@ collatz filter-map filter-map-values + range-map-sum double-list double-values) @@ -62,6 +63,12 @@ (apply values (map sqr (filter odd? vs)))) +(define (~sum vs) + (apply + vs)) + +(define (range-map-sum n) + (~sum (map sqr (range 1 n)))) + (define (double-list lst) (apply append (map (λ (v) (list v v)) lst))) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index 5ca9d2672..17ffe3af7 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -9,6 +9,8 @@ #:transparent) (define specs + ;; the first datum in the benchmark name needs to be the name + ;; of the function that will be exercised (list (bm "conditionals" check-value 300000) @@ -24,6 +26,9 @@ (bm "filter-map (large list)" check-large-list 50000) + (bm "range-map-sum" + check-value-large + 5000) (bm "filter-map-values" check-values 500000) @@ -40,7 +45,7 @@ check-value 10000) (bm "eratosthenes" - check-value-primes + check-value-medium-large 100) ;; See https://en.wikipedia.org/wiki/Collatz_conjecture (bm "collatz" diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index c8a3c8972..b831bd1e6 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -3,7 +3,8 @@ (provide average measure check-value - check-value-primes + check-value-medium-large + check-value-large check-list check-large-list check-values @@ -58,7 +59,9 @@ (set! i (remainder (add1 i) len)) (fn (vector-ref inputs i))))) -(define check-value-primes (curryr check-value #(100 200 300))) +(define check-value-medium-large (curryr check-value #(100 200 300))) + +(define check-value-large (curryr check-value #(1000))) ;; This uses the same list input each time. Not sure if that ;; may end up being cached at some level and thus obfuscate From 7014300e4db678dcf726c0649b2b1d8a9cb34ead Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 18 Aug 2023 13:52:31 -0700 Subject: [PATCH 200/338] minimally incorporate stream fusion into the compiler --- qi-lib/flow/core/compiler.rkt | 26 ++++++++++++++++++-- qi-lib/flow/core/impl.rkt | 38 +++++++++++++++++++++++++++-- qi-sdk/profile/nonlocal/qi/main.rkt | 15 +++++++----- 3 files changed, 69 insertions(+), 10 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index d21eead80..f5bf3421c 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -14,20 +14,42 @@ racket/undefined (prefix-in fancy: fancy-app)) +(define-syntax inline-compose1 + (syntax-rules () + [(_ f) f] + [(_ f1 f ...) (f1 (inline-compose1 f ...))])) + (begin-for-syntax ;; note: this does not return compiled code but instead, ;; syntax whose expansion compiles the code (define (compile-flow stx) (process-bindings (optimize-flow stx))) + (define-syntax-class fusable-list-operation + #:attributes (next) + (pattern ((~literal map) f) + #:attr next #'map-cstream-next) + (pattern ((~literal filter) f) + #:attr next #'filter-cstream-next)) + + (define (generate-fused-operation ops) + (displayln ops (current-error-port)) + (syntax-parse (reverse ops) + [(op:fusable-list-operation ...) + #'(esc (λ (lst) + ((cstream->list + (inline-compose1 op.next ... + list->cstream-next)) + lst)))])) + (define (optimization-pass stx) ;; TODO: the "active" components of the expansions should be ;; optimized, i.e. they should be wrapped with a recursive ;; call to the optimizer (syntax-parse stx ;; restorative optimization for "all" - [((~datum thread) ((~datum amp) onex) (~datum AND)) - #`(esc (give (curry andmap #,(compile-flow #'onex))))] + [((~datum thread) f:fusable-list-operation ...+) + (generate-fused-operation (attribute f))] ;; "deforestation" for values ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 658778d96..df7fb031c 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -19,7 +19,11 @@ values->list feedback-times feedback-while - kw-helper) + kw-helper + cstream->list + list->cstream-next + map-cstream-next + filter-cstream-next) (require racket/match (only-in racket/function @@ -29,7 +33,8 @@ racket/list racket/format syntax/parse/define - (for-syntax racket/base)) + (for-syntax racket/base) + racket/performance-hint) (define-syntax-parse-rule (values->list body:expr ...+) (call-with-values (λ () body ...) list)) @@ -235,3 +240,32 @@ (loop (values->list (apply f args))) (apply then-f args))))) + +(begin-encourage-inline + (define-inline (cstream->list next) + (λ (state) + (let loop ([state state]) + ((next (λ () null) + (λ (state) (loop state)) + (λ (value state) + (cons value (loop state)))) + state)))) + + (define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) + + (define-inline ((map-cstream-next f next) done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state)))) + + (define-inline ((filter-cstream-next f next) done skip yield) + (next done + skip + (λ (value state) + (if (f value) + (yield value state) + (skip state)))))) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index ce97cda82..eda2bafe3 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -135,12 +135,15 @@ (skip state)))))) ;; except for cstream->list, it's all CPS with tail recursion -(define (filter-map lst) - ((cstream->list - (map-cstream-next sqr - (filter-cstream-next odd? - list->cstream-next))) - lst)) +;; (define (filter-map lst) +;; ((cstream->list +;; (map-cstream-next sqr +;; (filter-cstream-next odd? +;; list->cstream-next))) +;; lst)) + +(define-flow filter-map + (~>> (filter odd?) (map sqr))) (define (~sum vs) (apply + vs)) From f693e08bdf4593fbdc447c3ab19449b2a7378249 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 24 Aug 2023 15:46:40 -0700 Subject: [PATCH 201/338] restore restorative optimization that was accidentally dropped --- qi-lib/flow/core/compiler.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index f5bf3421c..6e964b026 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -47,9 +47,12 @@ ;; optimized, i.e. they should be wrapped with a recursive ;; call to the optimizer (syntax-parse stx - ;; restorative optimization for "all" + ;; stream fusion for list operations [((~datum thread) f:fusable-list-operation ...+) (generate-fused-operation (attribute f))] + ;; restorative optimization for "all" + [((~datum thread) ((~datum amp) onex) (~datum AND)) + #`(esc (give (curry andmap #,(compile-flow #'onex))))] ;; "deforestation" for values ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) From 6c7f2e7b5285791b5da9226f322c598aa81a6f9c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 25 Aug 2023 20:28:14 -0700 Subject: [PATCH 202/338] test for the `filter-map` functional pipeline --- qi-test/tests/flow.rkt | 45 ++++++++++++++++++++++++------------------ 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 6dae428f0..4cef3a52e 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1494,25 +1494,32 @@ ;; these are collected from counterexamples to candidate equivalences ;; that turned up during code review. They ensure that some tempting ;; "equivalences" that are not really equivalences are formally checked - (let () - (define-flow g (-< add1 sub1)) - (define-flow f positive?) - (define (f* x y) (= (sub1 x) (add1 y))) - (define (amp-pass g f) (☯ (~> (>< g) (pass f) ▽))) - (define (amp-if g f) (☯ (~> (>< (~> g (if f _ ground))) ▽))) - (check-equal? (apply (amp-pass g f) (range -3 4)) - (list 1 2 3 1 4 2)) - (check-exn exn:fail? - (thunk (apply (amp-if g f) (range -3 4)))) - (check-exn exn:fail? - (thunk (apply (amp-pass g f*) (range -3 4)))) - (check-equal? (apply (amp-if g f*) (range -3 4)) - (list -2 -4 -1 -3 0 -2 1 -1 2 0 3 1 4 2))) - (let () - (check-equal? ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") - 2) - (check-equal? ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") - (list #f 2 #f)))))) + (test-suite + "counterexamples" + (let () + (define-flow g (-< add1 sub1)) + (define-flow f positive?) + (define (f* x y) (= (sub1 x) (add1 y))) + (define (amp-pass g f) (☯ (~> (>< g) (pass f) ▽))) + (define (amp-if g f) (☯ (~> (>< (~> g (if f _ ground))) ▽))) + (check-equal? (apply (amp-pass g f) (range -3 4)) + (list 1 2 3 1 4 2)) + (check-exn exn:fail? + (thunk (apply (amp-if g f) (range -3 4)))) + (check-exn exn:fail? + (thunk (apply (amp-pass g f*) (range -3 4)))) + (check-equal? (apply (amp-if g f*) (range -3 4)) + (list -2 -4 -1 -3 0 -2 1 -1 2 0 3 1 4 2))) + (let () + (check-equal? ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") + 2) + (check-equal? ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") + (list #f 2 #f)))) + (test-suite + "general" + (check-equal? ((☯ (~>> (filter odd?) (map sqr))) + (list 1 2 3 4 5)) + (list 1 9 25)))))) (module+ main (void (run-tests tests))) From e3037de8206f45643048dae6ae8a3c0119f8dbf8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 25 Aug 2023 20:30:22 -0700 Subject: [PATCH 203/338] use `racket -y` in running all tests to recompile if needed --- Makefile | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Makefile b/Makefile index 0d0b17a61..785687ae5 100644 --- a/Makefile +++ b/Makefile @@ -104,25 +104,25 @@ test: raco test -exp $(PACKAGE-NAME)-{lib,test,doc,probe} test-flow: - racket $(PACKAGE-NAME)-test/tests/flow.rkt + racket -y $(PACKAGE-NAME)-test/tests/flow.rkt test-on: - racket $(PACKAGE-NAME)-test/tests/on.rkt + racket -y $(PACKAGE-NAME)-test/tests/on.rkt test-threading: - racket $(PACKAGE-NAME)-test/tests/threading.rkt + racket -y $(PACKAGE-NAME)-test/tests/threading.rkt test-switch: - racket $(PACKAGE-NAME)-test/tests/switch.rkt + racket -y $(PACKAGE-NAME)-test/tests/switch.rkt test-definitions: - racket $(PACKAGE-NAME)-test/tests/definitions.rkt + racket -y $(PACKAGE-NAME)-test/tests/definitions.rkt test-macro: - racket $(PACKAGE-NAME)-test/tests/macro.rkt + racket -y $(PACKAGE-NAME)-test/tests/macro.rkt test-util: - racket $(PACKAGE-NAME)-test/tests/util.rkt + racket -y $(PACKAGE-NAME)-test/tests/util.rkt test-probe: raco test -exp $(PACKAGE-NAME)-probe From efb8f6569e6d7450899a9af0d6106fbe133356fd Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 25 Aug 2023 20:31:28 -0700 Subject: [PATCH 204/338] fix stream fusion (from today's qi meeting) See: https://github.com/drym-org/qi/wiki/Qi-Compiler-Sync-Aug-25-2023 --- qi-lib/flow/core/compiler.rkt | 21 +++++++---- qi-lib/flow/core/impl.rkt | 31 +++++++++------- qi-sdk/profile/nonlocal/qi/main.rkt | 56 ++++++++++++++--------------- 3 files changed, 61 insertions(+), 47 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 6e964b026..e7298ea0b 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -14,10 +14,15 @@ racket/undefined (prefix-in fancy: fancy-app)) +;; "Composes" higher-order functions inline by directly applying them +;; to the result of each subsequent application, with the last argument +;; being passed to the penultimate application as a (single) argument. +;; This is specialized to our implementation of stream fusion in the +;; arguments it expects and how it uses them. (define-syntax inline-compose1 (syntax-rules () [(_ f) f] - [(_ f1 f ...) (f1 (inline-compose1 f ...))])) + [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) (begin-for-syntax ;; note: this does not return compiled code but instead, @@ -26,19 +31,23 @@ (process-bindings (optimize-flow stx))) (define-syntax-class fusable-list-operation - #:attributes (next) - (pattern ((~literal map) f) + #:attributes (f next) + #:datum-literals (#%host-expression #%partial-application) + (pattern (#%partial-application + ((#%host-expression (~literal map)) + (#%host-expression f))) #:attr next #'map-cstream-next) - (pattern ((~literal filter) f) + (pattern (#%partial-application + ((#%host-expression (~literal filter)) + (#%host-expression f))) #:attr next #'filter-cstream-next)) (define (generate-fused-operation ops) - (displayln ops (current-error-port)) (syntax-parse (reverse ops) [(op:fusable-list-operation ...) #'(esc (λ (lst) ((cstream->list - (inline-compose1 op.next ... + (inline-compose1 [op.next op.f] ... list->cstream-next)) lst)))])) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index df7fb031c..781eb9b71 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -126,6 +126,8 @@ [(cons v vs) (append (values->list (f v)) (~map f vs))])) +;; Note: can probably get rid of implicit packing to args, and the +;; final apply values (define (map-values f . args) (apply values (~map f args))) @@ -241,6 +243,7 @@ (apply f args))) (apply then-f args))))) +;; Stream fusion (begin-encourage-inline (define-inline (cstream->list next) (λ (state) @@ -256,16 +259,18 @@ (cond [(null? state) (done)] [else (yield (car state) (cdr state))]))) - (define-inline ((map-cstream-next f next) done skip yield) - (next done - skip - (λ (value state) - (yield (f value) state)))) - - (define-inline ((filter-cstream-next f next) done skip yield) - (next done - skip - (λ (value state) - (if (f value) - (yield value state) - (skip state)))))) + (define-inline (map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state))))) + + (define-inline (filter-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (if (f value) + (yield value state) + (skip state))))))) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index eda2bafe3..496d4e71e 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -105,34 +105,34 @@ ;; continuation version ;; a lambda that does not escape is equivalent to a goto ;; lambda the ultimate goto by guy steele -(begin-encourage-inline - (define-inline (cstream->list next) - (λ (state) - (let loop ([state state]) - ((next (λ () null) - (λ (state) (loop state)) - (λ (value state) - (cons value (loop state)))) - state)))) - - (define-inline (list->cstream-next done skip yield) - (λ (state) - (cond [(null? state) (done)] - [else (yield (car state) (cdr state))]))) - - (define-inline ((map-cstream-next f next) done skip yield) - (next done - skip - (λ (value state) - (yield (f value) state)))) - - (define-inline ((filter-cstream-next f next) done skip yield) - (next done - skip - (λ (value state) - (if (f value) - (yield value state) - (skip state)))))) +;; (begin-encourage-inline +;; (define-inline (cstream->list next) +;; (λ (state) +;; (let loop ([state state]) +;; ((next (λ () null) +;; (λ (state) (loop state)) +;; (λ (value state) +;; (cons value (loop state)))) +;; state)))) + +;; (define-inline (list->cstream-next done skip yield) +;; (λ (state) +;; (cond [(null? state) (done)] +;; [else (yield (car state) (cdr state))]))) + +;; (define-inline ((map-cstream-next f next) done skip yield) +;; (next done +;; skip +;; (λ (value state) +;; (yield (f value) state)))) + +;; (define-inline ((filter-cstream-next f next) done skip yield) +;; (next done +;; skip +;; (λ (value state) +;; (if (f value) +;; (yield value state) +;; (skip state)))))) ;; except for cstream->list, it's all CPS with tail recursion ;; (define (filter-map lst) From 8ce3a883eb1d838e6671e2204fecf575b7f45163 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 1 Sep 2023 11:20:16 -0700 Subject: [PATCH 205/338] tidy - remove deforestation wip from benchmarking module --- qi-sdk/profile/nonlocal/qi/main.rkt | 377 ---------------------------- 1 file changed, 377 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 496d4e71e..3bec84e4b 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -62,86 +62,6 @@ ;; (define-flow filter-map ;; (~> △ (>< (if odd? sqr ⏚)) ▽)) -;; (define-flow filter-map -;; (~>> (filter odd?) (map sqr))) - -;; (define (filter-map lst) -;; (foldr (λ (v vs) -;; (if (odd? v) -;; (cons (sqr v) vs) -;; vs)) -;; null -;; lst)) - -(struct stream (next state) - #:transparent) - -(define (map-stream f s) - (define (next state) - (match ((stream-next s) state) - ['done 'done] - [(cons 'skip new-state) (cons 'skip new-state)] - [(list 'yield value new-state) - (list 'yield (f value) new-state)])) - (stream next (stream-state s))) - -(define (filter-stream f s) - (define (next state) - (match ((stream-next s) state) - ['done 'done] - [(cons 'skip new-state) (cons 'skip new-state)] - [(list 'yield value new-state) - (if (f value) - (list 'yield value new-state) - (cons 'skip new-state))])) - (stream next (stream-state s))) - -(define (list->stream lst) - (define (next state) - (cond [(null? state) 'done] - [else (list 'yield (car state) (cdr state))])) - (stream next lst)) - -;; continuation version -;; a lambda that does not escape is equivalent to a goto -;; lambda the ultimate goto by guy steele -;; (begin-encourage-inline -;; (define-inline (cstream->list next) -;; (λ (state) -;; (let loop ([state state]) -;; ((next (λ () null) -;; (λ (state) (loop state)) -;; (λ (value state) -;; (cons value (loop state)))) -;; state)))) - -;; (define-inline (list->cstream-next done skip yield) -;; (λ (state) -;; (cond [(null? state) (done)] -;; [else (yield (car state) (cdr state))]))) - -;; (define-inline ((map-cstream-next f next) done skip yield) -;; (next done -;; skip -;; (λ (value state) -;; (yield (f value) state)))) - -;; (define-inline ((filter-cstream-next f next) done skip yield) -;; (next done -;; skip -;; (λ (value state) -;; (if (f value) -;; (yield value state) -;; (skip state)))))) - -;; except for cstream->list, it's all CPS with tail recursion -;; (define (filter-map lst) -;; ((cstream->list -;; (map-cstream-next sqr -;; (filter-cstream-next odd? -;; list->cstream-next))) -;; lst)) - (define-flow filter-map (~>> (filter odd?) (map sqr))) @@ -151,303 +71,6 @@ (define-flow range-map-sum (~>> (range 1) (map sqr) ~sum)) -;; hand-coded iteration (representing the upper bound on performance) -;; (define (filter-map lst) -;; (if (null? lst) -;; '() -;; (let ([v (car lst)]) -;; (if (odd? v) -;; (cons (sqr v) (filter-map (cdr lst))) -;; (filter-map (cdr lst)))))) - - -;; (define (stream->list s) -;; (match ((stream-next s) (stream-state s)) -;; ['done null] -;; [(cons 'skip state) -;; (stream->list (stream (stream-next s) state))] -;; [(list 'yield value state) -;; (cons value -;; (stream->list (stream (stream-next s) state)))])) - -(define (stream->list s) - (let ([next (stream-next s)] - [state (stream-state s)]) - (let loop ([state state]) - (match (next state) - ['done null] - [(cons 'skip state) - (loop state)] - [(list 'yield value state) - (cons value - (loop state))])))) - -;; (define (filter-map lst) -;; (let ([s (list->stream lst)]) -;; (stream->list (map-stream sqr (filter-stream odd? s))))) - -;; This is the result of inline all of the stream operations -;; (define (filter-map lst) -;; (define (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) -;; (let ([s (stream next-list->stream lst)]) -;; (define (next-filter-stream state) -;; (match ((stream-next s) state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])) -;; (let ([s (stream next-filter-stream (stream-state s))]) -;; (define (next-map-stream state) -;; (match ((stream-next s) state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([s (stream next-map-stream (stream-state s))]) -;; (stream->list s))))) - -;; partially evaluate accessors to stream constructor -;; (define (filter-map lst) -;; (define (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) -;; (let ([s (stream next-list->stream lst)]) -;; (define (next-filter-stream state) -;; (match (next-list->stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])) -;; (let ([s (stream next-filter-stream lst)]) -;; (define (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([s (stream next-map-stream lst)]) -;; (stream->list s))))) - -;; dead code elimination (eliminate unused binding forms) -;; (define (filter-map lst) -;; (define (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) -;; (define (next-filter-stream state) -;; (match (next-list->stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])) -;; (define (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([s (stream next-map-stream lst)]) -;; (stream->list s))) - -;; inline stream->list as well -;; (define (filter-map lst) -;; (define (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) -;; (define (next-filter-stream state) -;; (match (next-list->stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])) -;; (define (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([next next-map-stream] -;; [state lst]) -;; (let loop ([state state]) -;; (match (next state) -;; ['done null] -;; [(cons 'skip state) -;; (loop state)] -;; [(list 'yield value state) -;; (cons value -;; (loop state))])))) - -;; try with inlining macro -;; (require racket/performance-hint) - -;; (define (filter-map lst) -;; (define-inline (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) -;; (define-inline (next-filter-stream state) -;; (match (next-list->stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])) -;; (define-inline (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([next next-map-stream] -;; [state lst]) -;; (let loop ([state state]) -;; (match (next state) -;; ['done null] -;; [(cons 'skip state) -;; (loop state)] -;; [(list 'yield value state) -;; (cons value -;; (loop state))])))) - -;; return multiple values -- instead of cons skip or list yield, return values instead -;; always return exactly three values -;; (values skip new-state #f) -;; (values done #f #f) -;; every match is going to be a case on the first value of the return -;; chez scheme would kick in and result could be pretty good (CP0) -;; (define (filter-map lst) -;; (define-inline (next-list->stream state) -;; (cond [(null? state) (values 'done #f #f)] -;; [else (values 'yield (car state) (cdr state))])) -;; (define-inline (next-filter-stream state) -;; (call-with-values -;; (λ () -;; (next-list->stream state)) -;; (λ (type value new-state) -;; (case type -;; [(done) (values 'done #f #f)] -;; [(skip) (values 'skip #f new-state)] -;; [(yield) -;; (if (odd? value) -;; (values 'yield value new-state) -;; (values 'skip #f new-state))])))) -;; (define-inline (next-map-stream state) -;; (call-with-values -;; (λ () -;; (next-filter-stream state)) -;; (λ (type value new-state) -;; (case type -;; [(done) (values 'done #f #f)] -;; [(skip) (values 'skip #f new-state)] -;; [(yield) -;; (values 'yield (sqr value) new-state)])))) -;; (let ([next next-map-stream] -;; [state lst]) -;; (let loop ([state state]) -;; (call-with-values -;; (λ () -;; (next state)) -;; (λ (type value new-state) -;; (case type -;; [(done) null] -;; [(skip) -;; (loop new-state)] -;; [(yield) -;; (cons value -;; (loop new-state))])))))) - -;; inline next-list->stream into next-filter-stream -;; (define (filter-map lst) -;; (define (next-filter-stream state) -;; (match (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))]) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])) -;; (define (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([next next-map-stream] -;; [state lst]) -;; (let loop ([state state]) -;; (match (next state) -;; ['done null] -;; [(cons 'skip state) -;; (loop state)] -;; [(list 'yield value state) -;; (cons value -;; (loop state))])))) - -;; case of case -;; when there is a conditional based on the return value of a conditional -;; invert which conditional is checked first -;; (define (filter-map lst) -;; (define (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) -;; (define (next-filter-stream state) -;; (cond [(null? state) (match 'done -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])] -;; [else (match (list 'yield (car state) (cdr state)) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state))])])) -;; (define (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([s (stream next-map-stream lst)]) -;; (stream->list s))) - -;; partially evaluate match on known argument -;; (define (filter-map lst) -;; (define (next-list->stream state) -;; (cond [(null? state) 'done] -;; [else (list 'yield (car state) (cdr state))])) -;; (define (next-filter-stream state) -;; (cond [(null? state) 'done] -;; [else -;; (let ([value (car state)] -;; [new-state (cdr state)]) -;; (if (odd? value) -;; (list 'yield value new-state) -;; (cons 'skip new-state)))])) -;; (define (next-map-stream state) -;; (match (next-filter-stream state) -;; ['done 'done] -;; [(cons 'skip new-state) (cons 'skip new-state)] -;; [(list 'yield value new-state) -;; (list 'yield (sqr value) new-state)])) -;; (let ([s (stream next-map-stream lst)]) -;; (stream->list s))) - -;; - (define-flow filter-map-values (>< (if odd? sqr ⏚))) From 0b2d62fcf326612bbe297b5ea0c0132f76351ac2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 1 Sep 2023 17:12:31 -0700 Subject: [PATCH 206/338] WIP from today's meeting - Improve match pattern for stream fusion to match fusable expressions anywhere in the source expression - Change layout of compiler passes so that each pass is done in a distinct stage, and these stages are sequential rather than recurring. This is a conservative starting point and won't always find the most optimal solutions, but is a worthy place to start and will give us clues over time on how to handle cases that elude this paradigm. --- qi-lib/flow/core/compiler.rkt | 46 ++++++++++++++++++++++------- qi-lib/info.rkt | 1 + qi-sdk/profile/nonlocal/qi/main.rkt | 22 ++++++++++++-- qi-test/tests/flow.rkt | 9 +++++- 4 files changed, 65 insertions(+), 13 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index e7298ea0b..1c4389687 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -42,6 +42,9 @@ (#%host-expression f))) #:attr next #'filter-cstream-next)) + (define-syntax-class non-fusable + (pattern (~not _:fusable-list-operation))) + (define (generate-fused-operation ops) (syntax-parse (reverse ops) [(op:fusable-list-operation ...) @@ -51,14 +54,11 @@ list->cstream-next)) lst)))])) - (define (optimization-pass stx) + (define (normalize-rewrites stx) ;; TODO: the "active" components of the expansions should be ;; optimized, i.e. they should be wrapped with a recursive ;; call to the optimizer (syntax-parse stx - ;; stream fusion for list operations - [((~datum thread) f:fusable-list-operation ...+) - (generate-fused-operation (attribute f))] ;; restorative optimization for "all" [((~datum thread) ((~datum amp) onex) (~datum AND)) #`(esc (give (curry andmap #,(compile-flow #'onex))))] @@ -68,7 +68,7 @@ #'(thread _0 ... (amp (if f g ground)) _1 ...)] ;; merge amps in sequence [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) - #`(thread _0 ... #,(optimization-pass #'(amp (thread f g))) _1 ...)] + #`(thread _0 ... #,(normalize-rewrites #'(amp (thread f g))) _1 ...)] ;; merge pass filters in sequence [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) #'(thread _0 ... (pass (and f g)) _1 ...)] @@ -79,7 +79,7 @@ [((~datum thread) f) #'f] ;; associative laws for ~> - [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) + [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) ; note: greedy matching #'(thread _0 ... f ... _1 ...)] ;; left and right identity for ~> [((~datum thread) _0 ... (~datum _) _1 ...) @@ -139,11 +139,37 @@ ;; return syntax unchanged if there are no known optimizations [_ stx])) + ;; 0. "Qi-normal form" + ;; 1. deforestation pass + ;; 2. other passes ... + ;; e.g.: + ;; changing internal representation to lists from values - may affect passes + ;; passes as distinct stages is safe and interesting, a conservative start + ;; one challenge: traversing the syntax tree + (define (deforest-rewrite stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... f:fusable-list-operation ...+ _1 ...) + #:with fused (generate-fused-operation (attribute f)) + #'(thread _0 ... fused _1 ...)] + [_ this-syntax])) + + (define ((fix f) init-val) + (let ([new-val (f init-val)]) + (if (eq? new-val init-val) + new-val + ((fix f) new-val)))) + + (define (deforest-pass stx) + (find-and-map/qi (fix deforest-rewrite) + stx)) + + (define (normalize-pass stx) + (find-and-map/qi (fix normalize-rewrites) + stx)) + (define (optimize-flow stx) - (let ([optimized (optimization-pass stx)]) - (if (eq? optimized stx) - stx - (optimize-flow optimized))))) + ;; (deforest-pass (normalize-pass stx)) + (deforest-pass (normalize-pass stx)))) ;; Transformation rules for the `as` binding form: ;; diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index 630025a20..6041bcfe3 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -6,6 +6,7 @@ ("fancy-app" #:version "1.1") ;; this git URL should be changed to a named package spec ;; once syntax-spec is on the package index + ;; "syntax-spec-v1" "git://github.com/michaelballantyne/syntax-spec.git#main")) (define build-deps '()) (define clean '("compiled" "private/compiled")) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 3bec84e4b..3f352f32e 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -1,6 +1,7 @@ #lang racket/base -(require racket/match) +(require racket/match + racket/function) (require racket/performance-hint) @@ -62,8 +63,20 @@ ;; (define-flow filter-map ;; (~> △ (>< (if odd? sqr ⏚)) ▽)) +;; (define-flow filter-map +;; (~>> (filter odd?) (map sqr))) + (define-flow filter-map - (~>> (filter odd?) (map sqr))) + (~>> values + (~> (filter odd?) + (map sqr)))) + +;; (define-flow filter-map +;; (~>> (filter odd?) +;; (map sqr) +;; identity +;; (filter (λ (v) (< v 10))) +;; (map sqr))) (define (~sum vs) (apply + vs)) @@ -71,6 +84,11 @@ (define-flow range-map-sum (~>> (range 1) (map sqr) ~sum)) +;; (define filter-double +;; (map (☯ (when odd? +;; (-< _ _))) +;; (list 1 2 3 4 5))) + (define-flow filter-map-values (>< (if odd? sqr ⏚))) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 4cef3a52e..d4d7580a3 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1519,7 +1519,14 @@ "general" (check-equal? ((☯ (~>> (filter odd?) (map sqr))) (list 1 2 3 4 5)) - (list 1 9 25)))))) + (list 1 9 25)) + ;; TODO: need a better way to validate that optimizations are + ;; happening, that they preserve semantics, and that they + ;; rewrite expressions as expected + (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) + (list 1 2 3 4 5)) + (list 1 9 25) + "optimizes subexpressions"))))) (module+ main (void (run-tests tests))) From e9298cb18dd579d0467326a1b24f30a0ddf0a787 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 1 Sep 2023 17:33:34 -0700 Subject: [PATCH 207/338] use the much-anticipated syntax-spec-v1 from the package index :) --- qi-lib/flow.rkt | 2 +- qi-lib/flow/extended/expander.rkt | 2 +- qi-lib/info.rkt | 5 +---- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index ad49312f3..8a5639c1b 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -5,7 +5,7 @@ (all-from-out "flow/extended/expander.rkt") (all-from-out "flow/extended/forms.rkt")) -(require syntax-spec +(require syntax-spec-v1 (for-syntax racket/base syntax/parse (only-in "private/util.rkt" diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 76ea3f1ad..a22608df1 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -12,7 +12,7 @@ [sep △] [collect ▽]))) -(require syntax-spec +(require syntax-spec-v1 (for-syntax "../aux-syntax.rkt" "syntax.rkt" racket/base diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index 6041bcfe3..c72a9c099 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -4,10 +4,7 @@ (define collection "qi") (define deps '("base" ("fancy-app" #:version "1.1") - ;; this git URL should be changed to a named package spec - ;; once syntax-spec is on the package index - ;; "syntax-spec-v1" - "git://github.com/michaelballantyne/syntax-spec.git#main")) + "syntax-spec-v1")) (define build-deps '()) (define clean '("compiled" "private/compiled")) (define pkg-authors '(countvajhula)) From a75c790cb4d0a2814d50190450a30e9bf87e6a96 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Sep 2023 09:48:34 -0700 Subject: [PATCH 208/338] a couple more nonlocal testcases, using folds --- qi-test/tests/flow.rkt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index d4d7580a3..16de53074 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1520,13 +1520,16 @@ (check-equal? ((☯ (~>> (filter odd?) (map sqr))) (list 1 2 3 4 5)) (list 1 9 25)) - ;; TODO: need a better way to validate that optimizations are - ;; happening, that they preserve semantics, and that they - ;; rewrite expressions as expected (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) (list 1 2 3 4 5)) (list 1 9 25) - "optimizes subexpressions"))))) + "optimizes subexpressions") + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldr + 0))) + (list 1 2 3 4 5)) + 35) + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldl + 0))) + (list 1 2 3 4 5)) + 35))))) (module+ main (void (run-tests tests))) From 69fc6f727ff2156645e2d6e230868c201673ce15 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Sep 2023 09:49:03 -0700 Subject: [PATCH 209/338] add starter tests to validate compiler rewrite rules --- qi-lib/flow/core/compiler.rkt | 5 +++- qi-test/tests/compiler.rkt | 43 +++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) create mode 100644 qi-test/tests/compiler.rkt diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 1c4389687..fb1663297 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -1,6 +1,9 @@ #lang racket/base -(provide (for-syntax compile-flow)) +(provide (for-syntax compile-flow + ;; TODO: only used in unit tests, maybe try + ;; using a submodule to avoid providing these usually + deforest-rewrite)) (require (for-syntax racket/base syntax/parse diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt new file mode 100644 index 000000000..7593fc351 --- /dev/null +++ b/qi-test/tests/compiler.rkt @@ -0,0 +1,43 @@ +#lang racket/base + +(provide tests) + +(require (for-template qi/flow/core/compiler) + rackunit + rackunit/text-ui + (only-in math sqr)) + +(define tests + (test-suite + "compiler tests" + + (test-suite + "deforestation" + ;; (~>> values (filter odd?) (map sqr) values) + (check-equal? (syntax->datum + (deforest-rewrite + #'(thread values + (#%partial-application + ((#%host-expression filter) + (#%host-expression odd?))) + (#%partial-application + ((#%host-expression map) + (#%host-expression sqr))) + values))) + '(thread + values + (esc + (λ (lst) + ((cstream->list + (inline-compose1 + (map-cstream-next + sqr) + (filter-cstream-next + odd?) + list->cstream-next)) + lst))) + values) + "deforestation in arbitrary positions")))) + +(module+ main + (void (run-tests tests))) From 047ca985000e5c93c4fd054369ca48fc104c3e08 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Sep 2023 09:49:41 -0700 Subject: [PATCH 210/338] benchmark for functional pipeline using foldr --- qi-sdk/profile/nonlocal/qi/main.rkt | 6 ++++++ qi-sdk/profile/nonlocal/racket/main.rkt | 4 ++++ qi-sdk/profile/nonlocal/spec.rkt | 3 +++ 3 files changed, 13 insertions(+) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 3f352f32e..175ff8c8c 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -13,6 +13,7 @@ eratosthenes collatz filter-map + filter-map-foldr filter-map-values range-map-sum double-list @@ -71,6 +72,11 @@ (~> (filter odd?) (map sqr)))) +(define-flow filter-map-foldr + (~>> (filter odd?) + (map sqr) + (foldr + 0))) + ;; (define-flow filter-map ;; (~>> (filter odd?) ;; (map sqr) diff --git a/qi-sdk/profile/nonlocal/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt index 035bfb8fc..61ad1c455 100644 --- a/qi-sdk/profile/nonlocal/racket/main.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -8,6 +8,7 @@ eratosthenes collatz filter-map + filter-map-foldr filter-map-values range-map-sum double-list @@ -59,6 +60,9 @@ (define (filter-map lst) (map sqr (filter odd? lst))) +(define (filter-map-foldr lst) + (foldr + 0 (map sqr (filter odd? lst)))) + (define (filter-map-values . vs) (apply values (map sqr (filter odd? vs)))) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index 17ffe3af7..e1f6f2837 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -26,6 +26,9 @@ (bm "filter-map (large list)" check-large-list 50000) + (bm "filter-map-foldr" + check-large-list + 50000) (bm "range-map-sum" check-value-large 5000) From 7d04b074bf2cbd615035e6e1c3dcbf0ceea96712 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 16 Sep 2023 13:46:26 -0700 Subject: [PATCH 211/338] foldr fusable stream terminator (committing code from yesterday's meetup) --- qi-lib/flow/core/compiler.rkt | 21 +++++++++++++++++++++ qi-lib/flow/core/impl.rkt | 12 +++++++++++- 2 files changed, 32 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index fb1663297..2265d92f6 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -45,11 +45,26 @@ (#%host-expression f))) #:attr next #'filter-cstream-next)) + (define-syntax-class fusable-fold-operation + #:attributes (op init end) + #:datum-literals (#%host-expression #%partial-application) + (pattern (#%partial-application + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init))) + #:attr end #'(foldr-cstream op init))) + (define-syntax-class non-fusable (pattern (~not _:fusable-list-operation))) (define (generate-fused-operation ops) (syntax-parse (reverse ops) + [(g:fusable-fold-operation op:fusable-list-operation ...) + #`(esc (λ (lst) + ((#,@#'g.end + (inline-compose1 [op.next op.f] ... + list->cstream-next)) + lst)))] [(op:fusable-list-operation ...) #'(esc (λ (lst) ((cstream->list @@ -151,6 +166,12 @@ ;; one challenge: traversing the syntax tree (define (deforest-rewrite stx) (syntax-parse stx + [((~datum thread) _0:non-fusable ... + f:fusable-list-operation ...+ + g:fusable-fold-operation + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(f ... g))) + #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... f:fusable-list-operation ...+ _1 ...) #:with fused (generate-fused-operation (attribute f)) #'(thread _0 ... fused _1 ...)] diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 781eb9b71..295c69a30 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -23,7 +23,8 @@ cstream->list list->cstream-next map-cstream-next - filter-cstream-next) + filter-cstream-next + foldr-cstream) (require racket/match (only-in racket/function @@ -254,6 +255,15 @@ (cons value (loop state)))) state)))) + (define-inline (foldr-cstream op init next) + (λ (state) + (let loop ([state state]) + ((next (λ () init) + (λ (state) (loop state)) + (λ (value state) + (op value (loop state)))) + state)))) + (define-inline (list->cstream-next done skip yield) (λ (state) (cond [(null? state) (done)] From ca8ff1251bcddd569e33f0bb4ebfed6f03e230d1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 22 Sep 2023 12:24:06 -0700 Subject: [PATCH 212/338] WIP from today's meeting - Check specifically for right chirality in deforestation - some unit tests for rewrite rules - more tests for deforestation - considering false return value for find-and-map mapping functions --- qi-lib/flow/core/compiler.rkt | 30 +++++++++++++++++++++--------- qi-test/tests/compiler.rkt | 25 ++++++++++++++++++++++++- qi-test/tests/flow.rkt | 17 ++++++++++++++++- 3 files changed, 61 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 2265d92f6..b9fe4ce41 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -36,13 +36,19 @@ (define-syntax-class fusable-list-operation #:attributes (f next) #:datum-literals (#%host-expression #%partial-application) - (pattern (#%partial-application - ((#%host-expression (~literal map)) - (#%host-expression f))) + (pattern (~and (#%partial-application + ((#%host-expression (~literal map)) + (#%host-expression f))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) #:attr next #'map-cstream-next) - (pattern (#%partial-application - ((#%host-expression (~literal filter)) - (#%host-expression f))) + (pattern (~and (#%partial-application + ((#%host-expression (~literal filter)) + (#%host-expression f))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) #:attr next #'filter-cstream-next)) (define-syntax-class fusable-fold-operation @@ -52,6 +58,8 @@ ((#%host-expression (~literal foldr)) (#%host-expression op) (#%host-expression init))) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) #:attr end #'(foldr-cstream op init))) (define-syntax-class non-fusable @@ -173,18 +181,22 @@ #:with fused (generate-fused-operation (syntax->list #'(f ... g))) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... f:fusable-list-operation ...+ _1 ...) - #:with fused (generate-fused-operation (attribute f)) + #:with fused (generate-fused-operation (syntax->list #'(f ...))) #'(thread _0 ... fused _1 ...)] - [_ this-syntax])) + [_ #f])) (define ((fix f) init-val) + ;; may need to be modified to handle #f as a special terminator (let ([new-val (f init-val)]) (if (eq? new-val init-val) new-val ((fix f) new-val)))) (define (deforest-pass stx) - (find-and-map/qi (fix deforest-rewrite) + ;; Note: deforestation happens only for threading, + ;; and the normalize pass strips the threading form + ;; if it contains only one expression, so this would not be hit. + (find-and-map/qi deforest-rewrite stx)) (define (normalize-pass stx) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 7593fc351..6ab632c35 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -14,6 +14,26 @@ (test-suite "deforestation" ;; (~>> values (filter odd?) (map sqr) values) + (check-equal? (syntax->datum + (deforest-rewrite + #'(thread (#%partial-application + ((#%host-expression filter) + (#%host-expression odd?)))))) + '(thread + (esc + (λ (lst) + ((cstream->list (inline-compose1 (filter-cstream-next odd?) list->cstream-next)) lst)))) + "deforestation of map -- note this tests the rule in isolation; with normalization this would never be necessary") + (check-equal? (syntax->datum + (deforest-rewrite + #'(thread (#%partial-application + ((#%host-expression map) + (#%host-expression sqr)))))) + '(thread + (esc + (λ (lst) + ((cstream->list (inline-compose1 (map-cstream-next sqr) list->cstream-next)) lst)))) + "deforestation of filter -- note this tests the rule in isolation; with normalization this would never be necessary") (check-equal? (syntax->datum (deforest-rewrite #'(thread values @@ -37,7 +57,10 @@ list->cstream-next)) lst))) values) - "deforestation in arbitrary positions")))) + "deforestation in arbitrary positions")) + (test-suite + "fixed point" + null))) (module+ main (void (run-tests tests))) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 16de53074..8dd7fc0fa 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1516,10 +1516,25 @@ (check-equal? ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") (list #f 2 #f)))) (test-suite - "general" + "deforestation" (check-equal? ((☯ (~>> (filter odd?) (map sqr))) (list 1 2 3 4 5)) (list 1 9 25)) + (check-exn exn:fail? + (thunk + ((☯ (~> (map sqr) (map sqr))) + (list 1 2 3 4 5))) + "(map) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~> (filter odd?) (filter odd?))) + (list 1 2 3 4 5))) + "(filter) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~>> (filter odd?) (~> (foldr + 0)))) + (list 1 2 3 4 5))) + "(foldlr) doforestation should only be done for right threading") (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) (list 1 2 3 4 5)) (list 1 9 25) From 02a5b5cc3551de41de5dda460e95f77cf13239f3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 29 Sep 2023 15:05:57 -0700 Subject: [PATCH 213/338] remove old unused deforestation code --- qi-lib/flow/core/compiler.rkt | 31 ------------------------------- qi-test/tests/flow.rkt | 2 +- 2 files changed, 1 insertion(+), 32 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index b9fe4ce41..fa71cc741 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -131,37 +131,6 @@ ;; and we can only know this at runtime. [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) #'(thread _0 ... _1 ...)] - ;; Deforestation for lists - ;; TODO: propagate the syntax property instead - ;; (~> (filter f) (map g)) → (~> (foldr [f+g] ...))) - [((~datum thread) _0 ... - ((~datum #%partial-application) ((~literal filter) g)) - ((~datum #%partial-application) ((~literal map) f)) - _1 ...) - #'(thread _0 ... - (#%fine-template - (foldr (λ (v vs) - (if (g v) - (cons (f v) vs) - vs)) - null - _)) - _1 ...)] - ;; (~> (map f) (filter g)) → (~> (foldr [f+g] ...))) - [((~datum thread) _0 ... - ((~datum #%partial-application) ((~literal map) f)) - ((~datum #%partial-application) ((~literal filter) g)) - _1 ...) - #'(thread _0 ... - (#%fine-template - (foldr (λ (v vs) - (let ([result (f v)]) - (if (g result) - (cons result vs) - vs))) - null - _)) - _1 ...)] ;; return syntax unchanged if there are no known optimizations [_ stx])) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 8dd7fc0fa..481c07090 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1534,7 +1534,7 @@ (thunk ((☯ (~>> (filter odd?) (~> (foldr + 0)))) (list 1 2 3 4 5))) - "(foldlr) doforestation should only be done for right threading") + "(foldr) doforestation should only be done for right threading") (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) (list 1 2 3 4 5)) (list 1 9 25) From 25b4b68176320970842aa68a41de0314c10b0b97 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 29 Sep 2023 19:57:44 -0700 Subject: [PATCH 214/338] Implement `foldl` as a stream Fix the syntax class to retain a reference to the input syntax in both foldl as well as foldr. Add a WIP tests for `foldl`. (WIP from today's meeting) --- qi-lib/flow/core/compiler.rkt | 19 ++++++++++++++----- qi-lib/flow/core/impl.rkt | 12 +++++++++++- qi-test/tests/compiler.rkt | 23 +++++++++++++++++++++++ qi-test/tests/flow.rkt | 8 +++++++- 4 files changed, 55 insertions(+), 7 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index fa71cc741..c7f4a9492 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -54,13 +54,22 @@ (define-syntax-class fusable-fold-operation #:attributes (op init end) #:datum-literals (#%host-expression #%partial-application) - (pattern (#%partial-application - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init))) + (pattern (~and (#%partial-application + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr end #'(foldr-cstream op init)) + (pattern (~and (#%partial-application + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init))) + stx) #:do [(define chirality (syntax-property #'stx 'chirality))] #:when (and chirality (eq? chirality 'right)) - #:attr end #'(foldr-cstream op init))) + #:attr end #'(foldl-cstream op init))) (define-syntax-class non-fusable (pattern (~not _:fusable-list-operation))) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 295c69a30..4a99312c0 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -24,7 +24,8 @@ list->cstream-next map-cstream-next filter-cstream-next - foldr-cstream) + foldr-cstream + foldl-cstream) (require racket/match (only-in racket/function @@ -264,6 +265,15 @@ (op value (loop state)))) state)))) + (define-inline (foldl-cstream op init next) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) + (define-inline (list->cstream-next done skip yield) (λ (state) (cond [(null? state) (done)] diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 6ab632c35..d11664f42 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -57,6 +57,29 @@ list->cstream-next)) lst))) values) + "deforestation in arbitrary positions") + (check-equal? (syntax->datum + (deforest-rewrite + #'(thread (#%partial-application + ((#%host-expression map) + (#%host-expression string-upcase))) + (#%partial-application + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I")))))) + '(thread + values + (esc + (λ (lst) + ((cstream->list + (inline-compose1 + (map-cstream-next + sqr) + (filter-cstream-next + odd?) + list->cstream-next)) + lst))) + values) "deforestation in arbitrary positions")) (test-suite "fixed point" diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 481c07090..4c800a5b9 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1544,7 +1544,13 @@ 35) (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldl + 0))) (list 1 2 3 4 5)) - 35))))) + 35) + (check-equal? ((☯ (~>> (map string-upcase) (foldr string-append "I"))) + (list "a" "b" "c")) + "ABCI") + (check-equal? ((☯ (~>> (map string-upcase) (foldl string-append "I"))) + (list "a" "b" "c")) + "CBAI"))))) (module+ main (void (run-tests tests))) From 28b9301cebcae841d43951bb09ef18e074e7e967 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 30 Sep 2023 20:00:35 -0700 Subject: [PATCH 215/338] fix compiler tests by adding chirality --- Makefile | 5 +- qi-lib/flow/core/compiler.rkt | 4 +- qi-lib/flow/extended/syntax.rkt | 3 +- qi-test/tests/compiler.rkt | 144 +++++++++++++++++--------------- qi-test/tests/qi.rkt | 6 +- 5 files changed, 89 insertions(+), 73 deletions(-) diff --git a/Makefile b/Makefile index 785687ae5..3ffd6e48e 100644 --- a/Makefile +++ b/Makefile @@ -124,6 +124,9 @@ test-macro: test-util: racket -y $(PACKAGE-NAME)-test/tests/util.rkt +test-compiler: + racket -y $(PACKAGE-NAME)-test/tests/compiler.rkt + test-probe: raco test -exp $(PACKAGE-NAME)-probe @@ -193,4 +196,4 @@ performance-report: performance-regression-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-compiler test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index c7f4a9492..3e3dee900 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -161,7 +161,7 @@ [((~datum thread) _0:non-fusable ... f:fusable-list-operation ...+ _1 ...) #:with fused (generate-fused-operation (syntax->list #'(f ...))) #'(thread _0 ... fused _1 ...)] - [_ #f])) + [_ this-syntax])) (define ((fix f) init-val) ;; may need to be modified to handle #f as a special terminator @@ -174,7 +174,7 @@ ;; Note: deforestation happens only for threading, ;; and the normalize pass strips the threading form ;; if it contains only one expression, so this would not be hit. - (find-and-map/qi deforest-rewrite + (find-and-map/qi (fix deforest-rewrite) stx)) (define (normalize-pass stx) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index 20067ab2a..288c9ca7e 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -6,7 +6,8 @@ blanket-template-form fine-template-form partial-application-form - any-stx) + any-stx + make-right-chiral) (require syntax/parse "../aux-syntax.rkt" diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index d11664f42..07ceb8aea 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -3,6 +3,8 @@ (provide tests) (require (for-template qi/flow/core/compiler) + (only-in qi/flow/extended/syntax + make-right-chiral) rackunit rackunit/text-ui (only-in math sqr)) @@ -14,73 +16,81 @@ (test-suite "deforestation" ;; (~>> values (filter odd?) (map sqr) values) - (check-equal? (syntax->datum - (deforest-rewrite - #'(thread (#%partial-application - ((#%host-expression filter) - (#%host-expression odd?)))))) - '(thread - (esc - (λ (lst) - ((cstream->list (inline-compose1 (filter-cstream-next odd?) list->cstream-next)) lst)))) - "deforestation of map -- note this tests the rule in isolation; with normalization this would never be necessary") - (check-equal? (syntax->datum - (deforest-rewrite - #'(thread (#%partial-application - ((#%host-expression map) - (#%host-expression sqr)))))) - '(thread - (esc - (λ (lst) - ((cstream->list (inline-compose1 (map-cstream-next sqr) list->cstream-next)) lst)))) - "deforestation of filter -- note this tests the rule in isolation; with normalization this would never be necessary") - (check-equal? (syntax->datum - (deforest-rewrite - #'(thread values - (#%partial-application - ((#%host-expression filter) - (#%host-expression odd?))) - (#%partial-application - ((#%host-expression map) - (#%host-expression sqr))) - values))) - '(thread - values - (esc - (λ (lst) - ((cstream->list - (inline-compose1 - (map-cstream-next - sqr) - (filter-cstream-next - odd?) - list->cstream-next)) - lst))) - values) - "deforestation in arbitrary positions") - (check-equal? (syntax->datum - (deforest-rewrite - #'(thread (#%partial-application - ((#%host-expression map) - (#%host-expression string-upcase))) - (#%partial-application - ((#%host-expression foldl) - (#%host-expression string-append) - (#%host-expression "I")))))) - '(thread - values - (esc - (λ (lst) - ((cstream->list - (inline-compose1 - (map-cstream-next - sqr) - (filter-cstream-next - odd?) - list->cstream-next)) - lst))) - values) - "deforestation in arbitrary positions")) + (let ([stx (make-right-chiral + #'(#%partial-application + ((#%host-expression filter) + (#%host-expression odd?))))]) + (check-equal? (syntax->datum + (deforest-rewrite + #`(thread #,stx))) + '(thread + (esc + (λ (lst) + ((cstream->list (inline-compose1 (filter-cstream-next odd?) list->cstream-next)) lst)))) + "deforestation of map -- note this tests the rule in isolation; with normalization this would never be necessary")) + (let ([stx (make-right-chiral + #'(#%partial-application + ((#%host-expression map) + (#%host-expression sqr))))]) + (check-equal? (syntax->datum + (deforest-rewrite + #`(thread #,stx))) + '(thread + (esc + (λ (lst) + ((cstream->list (inline-compose1 (map-cstream-next sqr) list->cstream-next)) lst)))) + "deforestation of filter -- note this tests the rule in isolation; with normalization this would never be necessary")) + (let ([stx (map make-right-chiral + (syntax->list + #'(values + (#%partial-application + ((#%host-expression filter) + (#%host-expression odd?))) + (#%partial-application + ((#%host-expression map) + (#%host-expression sqr))) + values)))]) + (check-equal? (syntax->datum + (deforest-rewrite + #`(thread #,@stx))) + '(thread + values + (esc + (λ (lst) + ((cstream->list + (inline-compose1 + (map-cstream-next + sqr) + (filter-cstream-next + odd?) + list->cstream-next)) + lst))) + values) + "deforestation in arbitrary positions")) + (let ([stx (map make-right-chiral + (syntax->list + #'((#%partial-application + ((#%host-expression map) + (#%host-expression string-upcase))) + (#%partial-application + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I"))))))]) + (check-equal? (syntax->datum + (deforest-rewrite + #`(thread #,@stx))) + '(thread + (esc + (λ (lst) + ((foldl-cstream + string-append + "I" + (inline-compose1 + (map-cstream-next + string-upcase) + list->cstream-next)) + lst)))) + "deforestation in arbitrary positions"))) (test-suite "fixed point" null))) diff --git a/qi-test/tests/qi.rkt b/qi-test/tests/qi.rkt index c3f675232..7bace1617 100644 --- a/qi-test/tests/qi.rkt +++ b/qi-test/tests/qi.rkt @@ -8,7 +8,8 @@ (prefix-in threading: "threading.rkt") (prefix-in definitions: "definitions.rkt") (prefix-in macro: "macro.rkt") - (prefix-in util: "util.rkt")) + (prefix-in util: "util.rkt") + (prefix-in compiler: "compiler.rkt")) (define tests (test-suite @@ -20,7 +21,8 @@ threading:tests definitions:tests macro:tests - util:tests)) + util:tests + compiler:tests)) (module+ test (void From 83675036b8e232c7da69f20b4d017fdc5a6cf365 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 5 Oct 2023 12:51:33 -0700 Subject: [PATCH 216/338] consistent naming in rewrite rules --- qi-lib/flow/core/compiler.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 3e3dee900..227202b1a 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -89,7 +89,7 @@ list->cstream-next)) lst)))])) - (define (normalize-rewrites stx) + (define (normalize-rewrite stx) ;; TODO: the "active" components of the expansions should be ;; optimized, i.e. they should be wrapped with a recursive ;; call to the optimizer @@ -103,7 +103,7 @@ #'(thread _0 ... (amp (if f g ground)) _1 ...)] ;; merge amps in sequence [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) - #`(thread _0 ... #,(normalize-rewrites #'(amp (thread f g))) _1 ...)] + #`(thread _0 ... #,(normalize-rewrite #'(amp (thread f g))) _1 ...)] ;; merge pass filters in sequence [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) #'(thread _0 ... (pass (and f g)) _1 ...)] @@ -178,7 +178,7 @@ stx)) (define (normalize-pass stx) - (find-and-map/qi (fix normalize-rewrites) + (find-and-map/qi (fix normalize-rewrite) stx)) (define (optimize-flow stx) From a70f882975c4d3a7b3605f017d3d38777196a541 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 5 Oct 2023 17:48:31 -0700 Subject: [PATCH 217/338] add a benchmark using `foldl` --- qi-sdk/profile/nonlocal/qi/main.rkt | 6 ++++++ qi-sdk/profile/nonlocal/racket/main.rkt | 4 ++++ qi-sdk/profile/nonlocal/spec.rkt | 3 +++ 3 files changed, 13 insertions(+) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 175ff8c8c..69f1094f4 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -14,6 +14,7 @@ collatz filter-map filter-map-foldr + filter-map-foldl filter-map-values range-map-sum double-list @@ -77,6 +78,11 @@ (map sqr) (foldr + 0))) +(define-flow filter-map-foldl + (~>> (filter odd?) + (map sqr) + (foldl + 0))) + ;; (define-flow filter-map ;; (~>> (filter odd?) ;; (map sqr) diff --git a/qi-sdk/profile/nonlocal/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt index 61ad1c455..e40670fbe 100644 --- a/qi-sdk/profile/nonlocal/racket/main.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -9,6 +9,7 @@ collatz filter-map filter-map-foldr + filter-map-foldl filter-map-values range-map-sum double-list @@ -63,6 +64,9 @@ (define (filter-map-foldr lst) (foldr + 0 (map sqr (filter odd? lst)))) +(define (filter-map-foldl lst) + (foldl + 0 (map sqr (filter odd? lst)))) + (define (filter-map-values . vs) (apply values (map sqr (filter odd? vs)))) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index e1f6f2837..b6e640f6f 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -29,6 +29,9 @@ (bm "filter-map-foldr" check-large-list 50000) + (bm "filter-map-foldl" + check-large-list + 50000) (bm "range-map-sum" check-value-large 5000) From c767e5752bb1a59c244648a751818384b48cbb8d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 6 Oct 2023 17:52:02 -0700 Subject: [PATCH 218/338] rename stream-related syntax classes for clarity (wip from today's meeting) --- qi-lib/flow/core/compiler.rkt | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 227202b1a..2cdf49e25 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -33,7 +33,9 @@ (define (compile-flow stx) (process-bindings (optimize-flow stx))) - (define-syntax-class fusable-list-operation + ;; TODO: define another syntax class, fusable-stream-producer, + ;; to match e.g. `upto` (range) and `unfold`. + (define-syntax-class fusable-stream-transformer #:attributes (f next) #:datum-literals (#%host-expression #%partial-application) (pattern (~and (#%partial-application @@ -51,7 +53,7 @@ #:when (and chirality (eq? chirality 'right)) #:attr next #'filter-cstream-next)) - (define-syntax-class fusable-fold-operation + (define-syntax-class fusable-stream-consumer #:attributes (op init end) #:datum-literals (#%host-expression #%partial-application) (pattern (~and (#%partial-application @@ -72,18 +74,22 @@ #:attr end #'(foldl-cstream op init))) (define-syntax-class non-fusable - (pattern (~not _:fusable-list-operation))) + (pattern (~not _:fusable-stream-transformer))) (define (generate-fused-operation ops) (syntax-parse (reverse ops) - [(g:fusable-fold-operation op:fusable-list-operation ...) + ;; TODO: add a new rule here for a fusable-stream-producer at the end + [(g:fusable-stream-consumer op:fusable-stream-transformer ...) #`(esc (λ (lst) ((#,@#'g.end (inline-compose1 [op.next op.f] ... list->cstream-next)) lst)))] - [(op:fusable-list-operation ...) + [(op:fusable-stream-transformer ...) #'(esc (λ (lst) + ;; have a contract here for the input + ;; validate it's a list, and error message + ;; can include the op syntax object ((cstream->list (inline-compose1 [op.next op.f] ... list->cstream-next)) @@ -153,12 +159,12 @@ (define (deforest-rewrite stx) (syntax-parse stx [((~datum thread) _0:non-fusable ... - f:fusable-list-operation ...+ - g:fusable-fold-operation + f:fusable-stream-transformer ...+ + g:fusable-stream-consumer _1 ...) #:with fused (generate-fused-operation (syntax->list #'(f ... g))) #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... f:fusable-list-operation ...+ _1 ...) + [((~datum thread) _0:non-fusable ... f:fusable-stream-transformer ...+ _1 ...) #:with fused (generate-fused-operation (syntax->list #'(f ...))) #'(thread _0 ... fused _1 ...)] [_ this-syntax])) From b254c6e684e7972173a0e9d23072bd1448222e80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 7 Oct 2023 09:18:27 +0200 Subject: [PATCH 219/338] Use macro-debugger-emit to see the process-bindings expansion step in macro stepper. --- qi-lib/flow/core/compiler.rkt | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 2cdf49e25..eb92a4ca8 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -10,7 +10,8 @@ racket/match (only-in racket/list make-list) "syntax.rkt" - "../aux-syntax.rkt") + "../aux-syntax.rkt" + macro-debugger/emit) "impl.rkt" (only-in racket/list make-list) racket/function @@ -270,8 +271,12 @@ ;; TODO: use syntax-parse and match ~> specifically. ;; Since macros are expanded "outside in," presumably ;; it will naturally wrap the outermost ~> - (wrap-with-scopes #`(qi0->racket #,(rewrite-all-bindings stx)) - (bound-identifiers stx)))) + (let ([stx1 (wrap-with-scopes #`(qi0->racket #,(rewrite-all-bindings stx)) + (bound-identifiers stx))]) + (emit-local-step stx stx1 #:id #'process-bindings) + stx1)) + + ) (define-syntax (qi0->racket stx) ;; this is a macro so it receives the entire expression From 2631c6c49b2173dced125e4ce0260699303f3094 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 7 Oct 2023 10:02:26 +0200 Subject: [PATCH 220/338] Make fix procedure compatible with syntax-parse rules following the find-and-map/qi specification. --- qi-lib/flow/core/compiler.rkt | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index eb92a4ca8..65ca89b79 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -170,11 +170,18 @@ #'(thread _0 ... fused _1 ...)] [_ this-syntax])) + ;; Applies f repeatedly to the init-val terminating the loop if the + ;; result of f is #f or the new syntax object is eq? to the previous + ;; (possibly initial) one. + ;; + ;; Caveats: + ;; * the syntax object is not inspected, only eq? is used + ;; * comparison is performed only between consecutive steps (does not handle cyclic occurences) (define ((fix f) init-val) - ;; may need to be modified to handle #f as a special terminator (let ([new-val (f init-val)]) - (if (eq? new-val init-val) - new-val + (if (or (not new-val) + (eq? new-val init-val)) + init-val ((fix f) new-val)))) (define (deforest-pass stx) From 8e9610786de97a0c0cc212d2728f36a8fc398abf Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 14 Oct 2023 09:02:18 -0700 Subject: [PATCH 221/338] macros for emitting expansion events for the macro stepper (wip from yesterday's meeting) --- qi-lib/flow/core/compiler.rkt | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 65ca89b79..c0b11f33b 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -29,6 +29,19 @@ [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) (begin-for-syntax + + ;; currently does not distinguish substeps of a parent expansion step + (define-syntax-rule (qi-expansion-step name stx0 stx1) + (let () + (emit-local-step stx0 stx1 #:id #'name) + stx1)) + + (define-syntax-rule (define-qi-expansion-step (name stx0) + body ...) + (define (name stx0) + (let ([stx1 (let () body ...)]) + (qi-expansion-step name stx0 stx1)))) + ;; note: this does not return compiled code but instead, ;; syntax whose expansion compiles the code (define (compile-flow stx) @@ -96,10 +109,11 @@ list->cstream-next)) lst)))])) - (define (normalize-rewrite stx) + (define-qi-expansion-step (normalize-rewrite stx) ;; TODO: the "active" components of the expansions should be ;; optimized, i.e. they should be wrapped with a recursive ;; call to the optimizer + ;; TODO: eliminate outdated rules here (syntax-parse stx ;; restorative optimization for "all" [((~datum thread) ((~datum amp) onex) (~datum AND)) @@ -274,16 +288,12 @@ (with-syntax ([(v ...) ids]) #`(let ([v undefined] ...) #,stx))) - (define (process-bindings stx) + (define-qi-expansion-step (process-bindings stx) ;; TODO: use syntax-parse and match ~> specifically. ;; Since macros are expanded "outside in," presumably ;; it will naturally wrap the outermost ~> - (let ([stx1 (wrap-with-scopes #`(qi0->racket #,(rewrite-all-bindings stx)) - (bound-identifiers stx))]) - (emit-local-step stx stx1 #:id #'process-bindings) - stx1)) - - ) + (wrap-with-scopes #`(qi0->racket #,(rewrite-all-bindings stx)) + (bound-identifiers stx)))) (define-syntax (qi0->racket stx) ;; this is a macro so it receives the entire expression From 3c413e775cc47fc561ed11d5f58f6972f5e1d491 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 20 Oct 2023 18:06:07 +0200 Subject: [PATCH 222/338] Fix nonlocal tests (use right threading) for deforestation optimizations, add preliminary support for multiple values in deforestation implementation. --- qi-lib/flow/core/impl.rkt | 96 +++++++++++++++++------------ qi-sdk/profile/nonlocal/qi/main.rkt | 4 +- 2 files changed, 58 insertions(+), 42 deletions(-) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 4a99312c0..5285923e6 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -246,51 +246,67 @@ (apply then-f args))))) ;; Stream fusion -(begin-encourage-inline - (define-inline (cstream->list next) - (λ (state) +(define-inline (cstream->list next) + (λ state (let loop ([state state]) - ((next (λ () null) + (apply + (next (λ () null) (λ (state) (loop state)) (λ (value state) - (cons value (loop state)))) + ;; Must be a list with single value + (cons (car value) (loop state)))) state)))) - (define-inline (foldr-cstream op init next) - (λ (state) - (let loop ([state state]) - ((next (λ () init) - (λ (state) (loop state)) - (λ (value state) - (op value (loop state)))) - state)))) - - (define-inline (foldl-cstream op init next) - (λ (state) - (let loop ([acc init] [state state]) - ((next (λ () acc) - (λ (state) (loop acc state)) - (λ (value state) - (loop (op value acc) state))) - state)))) - - (define-inline (list->cstream-next done skip yield) - (λ (state) - (cond [(null? state) (done)] - [else (yield (car state) (cdr state))]))) - - (define-inline (map-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (yield (f value) state))))) - - (define-inline (filter-cstream-next f next) +(define-inline (foldr-cstream op init next) + (λ state + (let loop ([state state]) + (apply + (next (λ () init) + (λ (state) (loop state)) + (λ (vals state) + ;; Vals must be a list with single value, the result + ;; must be single value as it is technically being + ;; merged into implicit accumulator (see foldl-cstream) + (op (car vals) (loop state)))) + state)))) + +(define-inline (foldl-cstream op init next) + (λ state + (let loop ([acc init] [state state]) + (apply + (next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + ;; Value must be a list with single value and the value + ;; stored in the accumulator must be a single value, + ;; not a list of results + (loop (op (car value) acc) state))) + state)))) + +;; Proper name should probably be lists->cstream-next +(define-inline (list->cstream-next done skip yield) + (lambda states + (cond ((andmap null? states) + (done)) + ;; yield is always called with a list of values taken from + ;; car of all lists passed as arguments of this procedure + (else (yield (map car states) (map cdr states)))))) + +(define-inline (map-cstream-next f next) + (lambda (done skip yield) + (next done + skip + (lambda (vals states) + ;; The resulting value must be wrapped in a list as any + ;; yield expects list of values as its first argument + (yield (list (apply f vals)) states))))) + +(define-inline (filter-cstream-next f next) (λ (done skip yield) (next done skip - (λ (value state) - (if (f value) - (yield value state) - (skip state))))))) + (λ (vals state) + (if (f (car vals)) + ;; vals is already a list of values + (yield vals state) + (skip state)))))) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 69f1094f4..6636aa7cf 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -70,8 +70,8 @@ (define-flow filter-map (~>> values - (~> (filter odd?) - (map sqr)))) + (~>> (filter odd?) + (map sqr)))) (define-flow filter-map-foldr (~>> (filter odd?) From df78d985395d36d2791acf786ab56e7ca03e2d00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 Nov 2023 20:06:59 +0100 Subject: [PATCH 223/338] Revert "Fix nonlocal tests (use right threading) for deforestation optimizations, add preliminary support for multiple values in deforestation implementation." This reverts commit 577d41565d317f50bbfee882b70e3423d8b2e913. --- qi-lib/flow/core/impl.rkt | 96 ++++++++++++----------------- qi-sdk/profile/nonlocal/qi/main.rkt | 4 +- 2 files changed, 42 insertions(+), 58 deletions(-) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 5285923e6..4a99312c0 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -246,67 +246,51 @@ (apply then-f args))))) ;; Stream fusion -(define-inline (cstream->list next) - (λ state +(begin-encourage-inline + (define-inline (cstream->list next) + (λ (state) (let loop ([state state]) - (apply - (next (λ () null) + ((next (λ () null) (λ (state) (loop state)) (λ (value state) - ;; Must be a list with single value - (cons (car value) (loop state)))) + (cons value (loop state)))) state)))) -(define-inline (foldr-cstream op init next) - (λ state - (let loop ([state state]) - (apply - (next (λ () init) - (λ (state) (loop state)) - (λ (vals state) - ;; Vals must be a list with single value, the result - ;; must be single value as it is technically being - ;; merged into implicit accumulator (see foldl-cstream) - (op (car vals) (loop state)))) - state)))) - -(define-inline (foldl-cstream op init next) - (λ state - (let loop ([acc init] [state state]) - (apply - (next (λ () acc) - (λ (state) (loop acc state)) - (λ (value state) - ;; Value must be a list with single value and the value - ;; stored in the accumulator must be a single value, - ;; not a list of results - (loop (op (car value) acc) state))) - state)))) - -;; Proper name should probably be lists->cstream-next -(define-inline (list->cstream-next done skip yield) - (lambda states - (cond ((andmap null? states) - (done)) - ;; yield is always called with a list of values taken from - ;; car of all lists passed as arguments of this procedure - (else (yield (map car states) (map cdr states)))))) - -(define-inline (map-cstream-next f next) - (lambda (done skip yield) - (next done - skip - (lambda (vals states) - ;; The resulting value must be wrapped in a list as any - ;; yield expects list of values as its first argument - (yield (list (apply f vals)) states))))) - -(define-inline (filter-cstream-next f next) + (define-inline (foldr-cstream op init next) + (λ (state) + (let loop ([state state]) + ((next (λ () init) + (λ (state) (loop state)) + (λ (value state) + (op value (loop state)))) + state)))) + + (define-inline (foldl-cstream op init next) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) + + (define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) + + (define-inline (map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state))))) + + (define-inline (filter-cstream-next f next) (λ (done skip yield) (next done skip - (λ (vals state) - (if (f (car vals)) - ;; vals is already a list of values - (yield vals state) - (skip state)))))) + (λ (value state) + (if (f value) + (yield value state) + (skip state))))))) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 6636aa7cf..69f1094f4 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -70,8 +70,8 @@ (define-flow filter-map (~>> values - (~>> (filter odd?) - (map sqr)))) + (~> (filter odd?) + (map sqr)))) (define-flow filter-map-foldr (~>> (filter odd?) From 5ec858e5b3d0e18ca50bf7e24551edb9f4099b1d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 Nov 2023 20:10:34 +0100 Subject: [PATCH 224/338] Fix the tests again. --- qi-sdk/profile/nonlocal/qi/main.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 69f1094f4..6636aa7cf 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -70,8 +70,8 @@ (define-flow filter-map (~>> values - (~> (filter odd?) - (map sqr)))) + (~>> (filter odd?) + (map sqr)))) (define-flow filter-map-foldr (~>> (filter odd?) From c296c178b325aae338429fa9741b68b70a752eaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 Nov 2023 20:25:36 +0100 Subject: [PATCH 225/338] Remove redundant inlining hint. --- qi-lib/flow/core/impl.rkt | 95 +++++++++++++++++++-------------------- 1 file changed, 47 insertions(+), 48 deletions(-) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 4a99312c0..aee95041e 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -246,51 +246,50 @@ (apply then-f args))))) ;; Stream fusion -(begin-encourage-inline - (define-inline (cstream->list next) - (λ (state) - (let loop ([state state]) - ((next (λ () null) - (λ (state) (loop state)) - (λ (value state) - (cons value (loop state)))) - state)))) - - (define-inline (foldr-cstream op init next) - (λ (state) - (let loop ([state state]) - ((next (λ () init) - (λ (state) (loop state)) - (λ (value state) - (op value (loop state)))) - state)))) - - (define-inline (foldl-cstream op init next) - (λ (state) - (let loop ([acc init] [state state]) - ((next (λ () acc) - (λ (state) (loop acc state)) - (λ (value state) - (loop (op value acc) state))) - state)))) - - (define-inline (list->cstream-next done skip yield) - (λ (state) - (cond [(null? state) (done)] - [else (yield (car state) (cdr state))]))) - - (define-inline (map-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (yield (f value) state))))) - - (define-inline (filter-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (if (f value) - (yield value state) - (skip state))))))) +(define-inline (cstream->list next) + (λ (state) + (let loop ([state state]) + ((next (λ () null) + (λ (state) (loop state)) + (λ (value state) + (cons value (loop state)))) + state)))) + +(define-inline (foldr-cstream op init next) + (λ (state) + (let loop ([state state]) + ((next (λ () init) + (λ (state) (loop state)) + (λ (value state) + (op value (loop state)))) + state)))) + +(define-inline (foldl-cstream op init next) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) + +(define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) + +(define-inline (map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state))))) + +(define-inline (filter-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (if (f value) + (yield value state) + (skip state))))))) From 49304785cd7bbaa53c9e26ffae0798cc4bd1079c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 Nov 2023 21:18:20 +0100 Subject: [PATCH 226/338] Preliminary fusion for no-argument range, supporting 1 or 2 values. --- qi-lib/flow/core/compiler.rkt | 27 +++++++++++++++++++++++++-- qi-lib/flow/core/impl.rkt | 15 ++++++++++++++- 2 files changed, 39 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index c0b11f33b..be7016fb1 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -16,7 +16,8 @@ (only-in racket/list make-list) racket/function racket/undefined - (prefix-in fancy: fancy-app)) + (prefix-in fancy: fancy-app) + racket/list) ;; "Composes" higher-order functions inline by directly applying them ;; to the result of each subsequent application, with the last argument @@ -49,6 +50,16 @@ ;; TODO: define another syntax class, fusable-stream-producer, ;; to match e.g. `upto` (range) and `unfold`. + (define-syntax-class fusable-stream-producer + #:attributes (next args) + #:datum-literals (#%host-expression #%partial-application) + (pattern (~and ((~literal esc) (#%host-expression (~literal range))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr next #'range->cstream-next + #:attr args #'range->cstream-args)) + (define-syntax-class fusable-stream-transformer #:attributes (f next) #:datum-literals (#%host-expression #%partial-application) @@ -92,7 +103,12 @@ (define (generate-fused-operation ops) (syntax-parse (reverse ops) - ;; TODO: add a new rule here for a fusable-stream-producer at the end + [(g:fusable-stream-consumer op:fusable-stream-transformer ... p:fusable-stream-producer) + #`(esc (λ args + ((#,@#'g.end + (inline-compose1 [op.next op.f] ... + p.next)) + (apply p.args args))))] [(g:fusable-stream-consumer op:fusable-stream-transformer ...) #`(esc (λ (lst) ((#,@#'g.end @@ -173,6 +189,13 @@ ;; one challenge: traversing the syntax tree (define (deforest-rewrite stx) (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + f:fusable-stream-transformer ...+ + g:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(p f ... g))) + #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... f:fusable-stream-transformer ...+ g:fusable-stream-consumer diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index aee95041e..5535570b0 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -22,6 +22,8 @@ kw-helper cstream->list list->cstream-next + range->cstream-next + range->cstream-args map-cstream-next filter-cstream-next foldr-cstream @@ -278,6 +280,17 @@ (cond [(null? state) (done)] [else (yield (car state) (cdr state))]))) +(define-inline (range->cstream-next done skip yield) + (λ (state) + (match-define (cons l h) state) + (cond [(< l h) + (yield l (cons (add1 l) h))] + [else (done)]))) + +(define-inline (range->cstream-args h/l (maybe-h #f)) + (cons (if maybe-h h/l 0) + (or maybe-h h/l))) + (define-inline (map-cstream-next f next) (λ (done skip yield) (next done @@ -292,4 +305,4 @@ (λ (value state) (if (f value) (yield value state) - (skip state))))))) + (skip state)))))) From cb23109915de4b6a0dc8928fb25aceb227c0b7c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 Nov 2023 21:33:41 +0100 Subject: [PATCH 227/338] Support for multiple arguments to curry in producer syntax class. --- qi-lib/flow/core/compiler.rkt | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index be7016fb1..4b6f84ff4 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -48,17 +48,23 @@ (define (compile-flow stx) (process-bindings (optimize-flow stx))) - ;; TODO: define another syntax class, fusable-stream-producer, - ;; to match e.g. `upto` (range) and `unfold`. (define-syntax-class fusable-stream-producer - #:attributes (next args) - #:datum-literals (#%host-expression #%partial-application) - (pattern (~and ((~literal esc) (#%host-expression (~literal range))) + #:attributes (next prepare) + #:datum-literals (#%host-expression #%partial-application esc) + (pattern (~and (esc (#%host-expression (~literal range))) + stx) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-args) + (pattern (~and ((#%partial-application + (#%host-expression (~literal range))) + (#%host-expression arg) ...) stx) #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) + #:with vindaloo (if (and chirality (eq? chirality 'right)) + #'curry + #'curryr) #:attr next #'range->cstream-next - #:attr args #'range->cstream-args)) + #:attr prepare #'(vindaloo range->cstream-args arg ...))) (define-syntax-class fusable-stream-transformer #:attributes (f next) @@ -108,7 +114,7 @@ ((#,@#'g.end (inline-compose1 [op.next op.f] ... p.next)) - (apply p.args args))))] + (apply p.prepare args))))] [(g:fusable-stream-consumer op:fusable-stream-transformer ...) #`(esc (λ (lst) ((#,@#'g.end From 313bb3f3f695dac56cd910aadc7e507edb91304b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 Nov 2023 21:59:53 +0100 Subject: [PATCH 228/338] Full support for range fusion. --- qi-lib/flow/core/compiler.rkt | 4 ++-- qi-lib/flow/core/impl.rkt | 14 ++++++++------ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 4b6f84ff4..dccb2918b 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -54,7 +54,7 @@ (pattern (~and (esc (#%host-expression (~literal range))) stx) #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-args) + #:attr prepare #'range->cstream-prepare) (pattern (~and ((#%partial-application (#%host-expression (~literal range))) (#%host-expression arg) ...) @@ -64,7 +64,7 @@ #'curry #'curryr) #:attr next #'range->cstream-next - #:attr prepare #'(vindaloo range->cstream-args arg ...))) + #:attr prepare #'(vindaloo range->cstream-prepare arg ...))) (define-syntax-class fusable-stream-transformer #:attributes (f next) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index 5535570b0..c0306a83c 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -23,7 +23,7 @@ cstream->list list->cstream-next range->cstream-next - range->cstream-args + range->cstream-prepare map-cstream-next filter-cstream-next foldr-cstream @@ -282,14 +282,16 @@ (define-inline (range->cstream-next done skip yield) (λ (state) - (match-define (cons l h) state) + (match-define (list l h s) state) (cond [(< l h) - (yield l (cons (add1 l) h))] + (yield l (cons (+ l s) (cdr state)))] [else (done)]))) -(define-inline (range->cstream-args h/l (maybe-h #f)) - (cons (if maybe-h h/l 0) - (or maybe-h h/l))) +(define range->cstream-prepare + (case-lambda + [(h) (list 0 h 1)] + [(l h) (list l h 1)] + [(l h s) (list l h s)])) (define-inline (map-cstream-next f next) (λ (done skip yield) From 0a4b506fe9237d32fc53cdf9ecf34c60dcdf7735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Mon, 6 Nov 2023 10:51:55 +0100 Subject: [PATCH 229/338] Finish stream fusion for producers, transformers, consumers and all their combinations. --- qi-lib/flow/core/compiler.rkt | 107 ++++++++++++++++++++++++++++------ 1 file changed, 89 insertions(+), 18 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index dccb2918b..b37ce538f 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -48,6 +48,10 @@ (define (compile-flow stx) (process-bindings (optimize-flow stx))) + ;; Used for producing the stream from particular + ;; expressions. Implicit producer is list->cstream-next and it is + ;; not created by using this class but rather explicitly used when + ;; no syntax class producer is matched. (define-syntax-class fusable-stream-producer #:attributes (next prepare) #:datum-literals (#%host-expression #%partial-application esc) @@ -55,9 +59,9 @@ stx) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare) - (pattern (~and ((#%partial-application - (#%host-expression (~literal range))) - (#%host-expression arg) ...) + (pattern (~and (#%partial-application + ((#%host-expression (~literal range)) + (#%host-expression arg) ...)) stx) #:do [(define chirality (syntax-property #'stx 'chirality))] #:with vindaloo (if (and chirality (eq? chirality 'right)) @@ -66,24 +70,46 @@ #:attr next #'range->cstream-next #:attr prepare #'(vindaloo range->cstream-prepare arg ...))) - (define-syntax-class fusable-stream-transformer + ;; Matches any stream transformer that can be in the head position + ;; of the fused sequence even when there is no explicit + ;; producer. Procedures accepting variable number of arguments like + ;; `map` cannot be in this class. + (define-syntax-class fusable-stream-transformer0 #:attributes (f next) #:datum-literals (#%host-expression #%partial-application) (pattern (~and (#%partial-application - ((#%host-expression (~literal map)) + ((#%host-expression (~literal filter)) (#%host-expression f))) stx) #:do [(define chirality (syntax-property #'stx 'chirality))] #:when (and chirality (eq? chirality 'right)) - #:attr next #'map-cstream-next) + #:attr next #'filter-cstream-next)) + + ;; All implemented stream transformers - within the stream, only + ;; single value is being passed and therefore procedures like `map` + ;; can (and should) be matched. + (define-syntax-class fusable-stream-transformer + #:attributes (f next) + #:datum-literals (#%host-expression #%partial-application) + (pattern (~and (#%partial-application + ((#%host-expression (~literal map)) + (#%host-expression f))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr next #'map-cstream-next) (pattern (~and (#%partial-application ((#%host-expression (~literal filter)) (#%host-expression f))) stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr next #'filter-cstream-next)) - + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr next #'filter-cstream-next)) + + ;; Terminates the fused sequence (consumes the stream) and produces + ;; an actual result value. The implicit consumer is cstream->list is + ;; not part of this class as it is added explicitly when generating + ;; the fused operation. (define-syntax-class fusable-stream-consumer #:attributes (op init end) #:datum-literals (#%host-expression #%partial-application) @@ -105,22 +131,50 @@ #:attr end #'(foldl-cstream op init))) (define-syntax-class non-fusable - (pattern (~not _:fusable-stream-transformer))) - + (pattern (~not (~or _:fusable-stream-transformer + _:fusable-stream-producer + _:fusable-stream-consumer)))) + + ;; Generates a syntax for the fused operation for given + ;; sequence. The syntax list must already conform to the rule that + ;; if the first operation is a fusable-stream-transformer, it must + ;; be a fusable-stream-transformer0 as well! (define (generate-fused-operation ops) (syntax-parse (reverse ops) - [(g:fusable-stream-consumer op:fusable-stream-transformer ... p:fusable-stream-producer) + [(g:fusable-stream-consumer + op:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; Contract probably not needed (prepare should produce + ;; meaningful error messages) #`(esc (λ args ((#,@#'g.end (inline-compose1 [op.next op.f] ... p.next)) (apply p.prepare args))))] - [(g:fusable-stream-consumer op:fusable-stream-transformer ...) + [(g:fusable-stream-consumer + p:fusable-stream-producer) + ;; dtto + #`(esc (λ args + ((#,@#'g.end p.next) + (apply p.prepare args))))] + ;; The list must contain fusable-stream-transformer0 as the last element! + [(g:fusable-stream-consumer + op:fusable-stream-transformer ...) + ;; TODO: Add contract #`(esc (λ (lst) ((#,@#'g.end (inline-compose1 [op.next op.f] ... list->cstream-next)) lst)))] + [(op:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; dtto + #`(esc (λ args + ((cstream->list + (inline-compose1 [op.next op.f] ... + p.next)) + (apply p.prepare args))))] + ;; dtto [(op:fusable-stream-transformer ...) #'(esc (λ (lst) ;; have a contract here for the input @@ -129,7 +183,8 @@ ((cstream->list (inline-compose1 [op.next op.f] ... list->cstream-next)) - lst)))])) + lst)))] + )) (define-qi-expansion-step (normalize-rewrite stx) ;; TODO: the "active" components of the expansions should be @@ -203,13 +258,29 @@ #:with fused (generate-fused-operation (syntax->list #'(p f ... g))) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + g:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(p g))) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 f:fusable-stream-transformer ...+ g:fusable-stream-consumer _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(f ... g))) + #:with fused (generate-fused-operation (syntax->list #'(f1 f ... g))) #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... f:fusable-stream-transformer ...+ _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(f ...))) + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(p f ...))) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(f1 f ...))) #'(thread _0 ... fused _1 ...)] [_ this-syntax])) From c5f7677cd43e16e9cc177ec12f119acde00f90aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 11 Nov 2023 10:31:59 +0100 Subject: [PATCH 230/338] Move the current deforestation (both syntax and implementation parts) into a separate module. --- qi-lib/flow/core/compiler.rkt | 184 +----------------------- qi-lib/flow/core/deforest.rkt | 255 ++++++++++++++++++++++++++++++++++ qi-lib/flow/core/impl.rkt | 72 +--------- 3 files changed, 258 insertions(+), 253 deletions(-) create mode 100644 qi-lib/flow/core/deforest.rkt diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index b37ce538f..77312969d 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -17,7 +17,8 @@ racket/function racket/undefined (prefix-in fancy: fancy-app) - racket/list) + racket/list + "deforest.rkt") ;; "Composes" higher-order functions inline by directly applying them ;; to the result of each subsequent application, with the last argument @@ -48,144 +49,6 @@ (define (compile-flow stx) (process-bindings (optimize-flow stx))) - ;; Used for producing the stream from particular - ;; expressions. Implicit producer is list->cstream-next and it is - ;; not created by using this class but rather explicitly used when - ;; no syntax class producer is matched. - (define-syntax-class fusable-stream-producer - #:attributes (next prepare) - #:datum-literals (#%host-expression #%partial-application esc) - (pattern (~and (esc (#%host-expression (~literal range))) - stx) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare) - (pattern (~and (#%partial-application - ((#%host-expression (~literal range)) - (#%host-expression arg) ...)) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:with vindaloo (if (and chirality (eq? chirality 'right)) - #'curry - #'curryr) - #:attr next #'range->cstream-next - #:attr prepare #'(vindaloo range->cstream-prepare arg ...))) - - ;; Matches any stream transformer that can be in the head position - ;; of the fused sequence even when there is no explicit - ;; producer. Procedures accepting variable number of arguments like - ;; `map` cannot be in this class. - (define-syntax-class fusable-stream-transformer0 - #:attributes (f next) - #:datum-literals (#%host-expression #%partial-application) - (pattern (~and (#%partial-application - ((#%host-expression (~literal filter)) - (#%host-expression f))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr next #'filter-cstream-next)) - - ;; All implemented stream transformers - within the stream, only - ;; single value is being passed and therefore procedures like `map` - ;; can (and should) be matched. - (define-syntax-class fusable-stream-transformer - #:attributes (f next) - #:datum-literals (#%host-expression #%partial-application) - (pattern (~and (#%partial-application - ((#%host-expression (~literal map)) - (#%host-expression f))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr next #'map-cstream-next) - (pattern (~and (#%partial-application - ((#%host-expression (~literal filter)) - (#%host-expression f))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr next #'filter-cstream-next)) - - ;; Terminates the fused sequence (consumes the stream) and produces - ;; an actual result value. The implicit consumer is cstream->list is - ;; not part of this class as it is added explicitly when generating - ;; the fused operation. - (define-syntax-class fusable-stream-consumer - #:attributes (op init end) - #:datum-literals (#%host-expression #%partial-application) - (pattern (~and (#%partial-application - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr end #'(foldr-cstream op init)) - (pattern (~and (#%partial-application - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr end #'(foldl-cstream op init))) - - (define-syntax-class non-fusable - (pattern (~not (~or _:fusable-stream-transformer - _:fusable-stream-producer - _:fusable-stream-consumer)))) - - ;; Generates a syntax for the fused operation for given - ;; sequence. The syntax list must already conform to the rule that - ;; if the first operation is a fusable-stream-transformer, it must - ;; be a fusable-stream-transformer0 as well! - (define (generate-fused-operation ops) - (syntax-parse (reverse ops) - [(g:fusable-stream-consumer - op:fusable-stream-transformer ... - p:fusable-stream-producer) - ;; Contract probably not needed (prepare should produce - ;; meaningful error messages) - #`(esc (λ args - ((#,@#'g.end - (inline-compose1 [op.next op.f] ... - p.next)) - (apply p.prepare args))))] - [(g:fusable-stream-consumer - p:fusable-stream-producer) - ;; dtto - #`(esc (λ args - ((#,@#'g.end p.next) - (apply p.prepare args))))] - ;; The list must contain fusable-stream-transformer0 as the last element! - [(g:fusable-stream-consumer - op:fusable-stream-transformer ...) - ;; TODO: Add contract - #`(esc (λ (lst) - ((#,@#'g.end - (inline-compose1 [op.next op.f] ... - list->cstream-next)) - lst)))] - [(op:fusable-stream-transformer ... - p:fusable-stream-producer) - ;; dtto - #`(esc (λ args - ((cstream->list - (inline-compose1 [op.next op.f] ... - p.next)) - (apply p.prepare args))))] - ;; dtto - [(op:fusable-stream-transformer ...) - #'(esc (λ (lst) - ;; have a contract here for the input - ;; validate it's a list, and error message - ;; can include the op syntax object - ((cstream->list - (inline-compose1 [op.next op.f] ... - list->cstream-next)) - lst)))] - )) - (define-qi-expansion-step (normalize-rewrite stx) ;; TODO: the "active" components of the expansions should be ;; optimized, i.e. they should be wrapped with a recursive @@ -241,49 +104,6 @@ ;; return syntax unchanged if there are no known optimizations [_ stx])) - ;; 0. "Qi-normal form" - ;; 1. deforestation pass - ;; 2. other passes ... - ;; e.g.: - ;; changing internal representation to lists from values - may affect passes - ;; passes as distinct stages is safe and interesting, a conservative start - ;; one challenge: traversing the syntax tree - (define (deforest-rewrite stx) - (syntax-parse stx - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - f:fusable-stream-transformer ...+ - g:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(p f ... g))) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - g:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(p g))) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - f1:fusable-stream-transformer0 - f:fusable-stream-transformer ...+ - g:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(f1 f ... g))) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - f:fusable-stream-transformer ...+ - _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(p f ...))) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - f1:fusable-stream-transformer0 - f:fusable-stream-transformer ...+ - _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(f1 f ...))) - #'(thread _0 ... fused _1 ...)] - [_ this-syntax])) - ;; Applies f repeatedly to the init-val terminating the loop if the ;; result of f is #f or the new syntax object is eq? to the previous ;; (possibly initial) one. diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt new file mode 100644 index 000000000..56de4656f --- /dev/null +++ b/qi-lib/flow/core/deforest.rkt @@ -0,0 +1,255 @@ +#lang racket/base + +(provide (for-syntax deforest-rewrite)) + +(require (for-syntax racket/base + syntax/parse) + racket/performance-hint + racket/match) + +(begin-for-syntax + + ;; Used for producing the stream from particular + ;; expressions. Implicit producer is list->cstream-next and it is + ;; not created by using this class but rather explicitly used when + ;; no syntax class producer is matched. + (define-syntax-class fusable-stream-producer + #:attributes (next prepare) + #:datum-literals (#%host-expression #%partial-application esc) + (pattern (~and (esc (#%host-expression (~literal range))) + stx) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-prepare) + (pattern (~and (#%partial-application + ((#%host-expression (~literal range)) + (#%host-expression arg) ...)) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:with vindaloo (if (and chirality (eq? chirality 'right)) + #'curry + #'curryr) + #:attr next #'range->cstream-next + #:attr prepare #'(vindaloo range->cstream-prepare arg ...))) + + ;; Matches any stream transformer that can be in the head position + ;; of the fused sequence even when there is no explicit + ;; producer. Procedures accepting variable number of arguments like + ;; `map` cannot be in this class. + (define-syntax-class fusable-stream-transformer0 + #:attributes (f next) + #:datum-literals (#%host-expression #%partial-application) + (pattern (~and (#%partial-application + ((#%host-expression (~literal filter)) + (#%host-expression f))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr next #'filter-cstream-next)) + + ;; All implemented stream transformers - within the stream, only + ;; single value is being passed and therefore procedures like `map` + ;; can (and should) be matched. + (define-syntax-class fusable-stream-transformer + #:attributes (f next) + #:datum-literals (#%host-expression #%partial-application) + (pattern (~and (#%partial-application + ((#%host-expression (~literal map)) + (#%host-expression f))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr next #'map-cstream-next) + (pattern (~and (#%partial-application + ((#%host-expression (~literal filter)) + (#%host-expression f))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr next #'filter-cstream-next)) + + ;; Terminates the fused sequence (consumes the stream) and produces + ;; an actual result value. The implicit consumer is cstream->list is + ;; not part of this class as it is added explicitly when generating + ;; the fused operation. + (define-syntax-class fusable-stream-consumer + #:attributes (op init end) + #:datum-literals (#%host-expression #%partial-application) + (pattern (~and (#%partial-application + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr end #'(foldr-cstream op init)) + (pattern (~and (#%partial-application + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (and chirality (eq? chirality 'right)) + #:attr end #'(foldl-cstream op init))) + + (define-syntax-class non-fusable + (pattern (~not (~or _:fusable-stream-transformer + _:fusable-stream-producer + _:fusable-stream-consumer)))) + + ;; Generates a syntax for the fused operation for given + ;; sequence. The syntax list must already conform to the rule that + ;; if the first operation is a fusable-stream-transformer, it must + ;; be a fusable-stream-transformer0 as well! + (define (generate-fused-operation ops) + (syntax-parse (reverse ops) + [(g:fusable-stream-consumer + op:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; Contract probably not needed (prepare should produce + ;; meaningful error messages) + #`(esc (λ args + ((#,@#'g.end + (inline-compose1 [op.next op.f] ... + p.next)) + (apply p.prepare args))))] + [(g:fusable-stream-consumer + p:fusable-stream-producer) + ;; dtto + #`(esc (λ args + ((#,@#'g.end p.next) + (apply p.prepare args))))] + ;; The list must contain fusable-stream-transformer0 as the last element! + [(g:fusable-stream-consumer + op:fusable-stream-transformer ...) + ;; TODO: Add contract + #`(esc (λ (lst) + ((#,@#'g.end + (inline-compose1 [op.next op.f] ... + list->cstream-next)) + lst)))] + [(op:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; dtto + #`(esc (λ args + ((cstream->list + (inline-compose1 [op.next op.f] ... + p.next)) + (apply p.prepare args))))] + ;; dtto + [(op:fusable-stream-transformer ...) + #'(esc (λ (lst) + ;; have a contract here for the input + ;; validate it's a list, and error message + ;; can include the op syntax object + ((cstream->list + (inline-compose1 [op.next op.f] ... + list->cstream-next)) + lst)))] + )) + + ;; 0. "Qi-normal form" + ;; 1. deforestation pass + ;; 2. other passes ... + ;; e.g.: + ;; changing internal representation to lists from values - may affect passes + ;; passes as distinct stages is safe and interesting, a conservative start + ;; one challenge: traversing the syntax tree + (define (deforest-rewrite stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + f:fusable-stream-transformer ...+ + g:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(p f ... g))) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + g:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(p g))) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 + f:fusable-stream-transformer ...+ + g:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(f1 f ... g))) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(p f ...))) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation (syntax->list #'(f1 f ...))) + #'(thread _0 ... fused _1 ...)] + [_ this-syntax])) + + ) + +;; Stream fusion +(define-inline (cstream->list next) + (λ (state) + (let loop ([state state]) + ((next (λ () null) + (λ (state) (loop state)) + (λ (value state) + (cons value (loop state)))) + state)))) + +(define-inline (foldr-cstream op init next) + (λ (state) + (let loop ([state state]) + ((next (λ () init) + (λ (state) (loop state)) + (λ (value state) + (op value (loop state)))) + state)))) + +(define-inline (foldl-cstream op init next) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) + +(define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) + +(define-inline (range->cstream-next done skip yield) + (λ (state) + (match-define (list l h s) state) + (cond [(< l h) + (yield l (cons (+ l s) (cdr state)))] + [else (done)]))) + +(define range->cstream-prepare + (case-lambda + [(h) (list 0 h 1)] + [(l h) (list l h 1)] + [(l h s) (list l h s)])) + +(define-inline (map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state))))) + +(define-inline (filter-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (if (f value) + (yield value state) + (skip state)))))) diff --git a/qi-lib/flow/core/impl.rkt b/qi-lib/flow/core/impl.rkt index c0306a83c..8cfc523a6 100644 --- a/qi-lib/flow/core/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -19,15 +19,7 @@ values->list feedback-times feedback-while - kw-helper - cstream->list - list->cstream-next - range->cstream-next - range->cstream-prepare - map-cstream-next - filter-cstream-next - foldr-cstream - foldl-cstream) + kw-helper) (require racket/match (only-in racket/function @@ -246,65 +238,3 @@ (loop (values->list (apply f args))) (apply then-f args))))) - -;; Stream fusion -(define-inline (cstream->list next) - (λ (state) - (let loop ([state state]) - ((next (λ () null) - (λ (state) (loop state)) - (λ (value state) - (cons value (loop state)))) - state)))) - -(define-inline (foldr-cstream op init next) - (λ (state) - (let loop ([state state]) - ((next (λ () init) - (λ (state) (loop state)) - (λ (value state) - (op value (loop state)))) - state)))) - -(define-inline (foldl-cstream op init next) - (λ (state) - (let loop ([acc init] [state state]) - ((next (λ () acc) - (λ (state) (loop acc state)) - (λ (value state) - (loop (op value acc) state))) - state)))) - -(define-inline (list->cstream-next done skip yield) - (λ (state) - (cond [(null? state) (done)] - [else (yield (car state) (cdr state))]))) - -(define-inline (range->cstream-next done skip yield) - (λ (state) - (match-define (list l h s) state) - (cond [(< l h) - (yield l (cons (+ l s) (cdr state)))] - [else (done)]))) - -(define range->cstream-prepare - (case-lambda - [(h) (list 0 h 1)] - [(l h) (list l h 1)] - [(l h s) (list l h s)])) - -(define-inline (map-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (yield (f value) state))))) - -(define-inline (filter-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (if (f value) - (yield value state) - (skip state)))))) From 7e7e41f5062bd353b5c97cb9d32083dc51ad7ac6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 11 Nov 2023 19:09:29 +0100 Subject: [PATCH 231/338] Fix missing requires (for ~literal matching), streamline procedures naming in implementation, move inline-compose1 too. --- qi-lib/flow/core/compiler.rkt | 10 -- qi-lib/flow/core/deforest.rkt | 167 ++++++++++++++++------------------ 2 files changed, 80 insertions(+), 97 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 77312969d..102ea12e9 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -20,16 +20,6 @@ racket/list "deforest.rkt") -;; "Composes" higher-order functions inline by directly applying them -;; to the result of each subsequent application, with the last argument -;; being passed to the penultimate application as a (single) argument. -;; This is specialized to our implementation of stream fusion in the -;; arguments it expects and how it uses them. -(define-syntax inline-compose1 - (syntax-rules () - [(_ f) f] - [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) - (begin-for-syntax ;; currently does not distinguish substeps of a parent expansion step diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 56de4656f..a03ae77a0 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -5,7 +5,24 @@ (require (for-syntax racket/base syntax/parse) racket/performance-hint - racket/match) + racket/match + racket/function + racket/list) + +;; These bindings are used for ~literal matching to introduce implicit +;; producer/consumer when none is explicitly given in the flow. +(define-syntax cstream->list #'-cstream->list) +(define-syntax list->cstream #'-list->cstream) + +;; "Composes" higher-order functions inline by directly applying them +;; to the result of each subsequent application, with the last argument +;; being passed to the penultimate application as a (single) argument. +;; This is specialized to our implementation of stream fusion in the +;; arguments it expects and how it uses them. +(define-syntax inline-compose1 + (syntax-rules () + [(_ f) f] + [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) (begin-for-syntax @@ -29,7 +46,10 @@ #'curry #'curryr) #:attr next #'range->cstream-next - #:attr prepare #'(vindaloo range->cstream-prepare arg ...))) + #:attr prepare #'(vindaloo range->cstream-prepare arg ...)) + (pattern (~literal list->cstream) + #:attr next #'list->cstream-next + #:attr prepare #'identity)) ;; Matches any stream transformer that can be in the head position ;; of the fused sequence even when there is no explicit @@ -72,7 +92,7 @@ ;; not part of this class as it is added explicitly when generating ;; the fused operation. (define-syntax-class fusable-stream-consumer - #:attributes (op init end) + #:attributes (end) #:datum-literals (#%host-expression #%partial-application) (pattern (~and (#%partial-application ((#%host-expression (~literal foldr)) @@ -81,7 +101,7 @@ stx) #:do [(define chirality (syntax-property #'stx 'chirality))] #:when (and chirality (eq? chirality 'right)) - #:attr end #'(foldr-cstream op init)) + #:attr end #'(foldr-cstream-next op init)) (pattern (~and (#%partial-application ((#%host-expression (~literal foldl)) (#%host-expression op) @@ -89,7 +109,9 @@ stx) #:do [(define chirality (syntax-property #'stx 'chirality))] #:when (and chirality (eq? chirality 'right)) - #:attr end #'(foldl-cstream op init))) + #:attr end #'(foldl-cstream-next op init)) + (pattern (~literal cstream->list) + #:attr end #'(cstream-next->list))) (define-syntax-class non-fusable (pattern (~not (~or _:fusable-stream-transformer @@ -102,50 +124,16 @@ ;; be a fusable-stream-transformer0 as well! (define (generate-fused-operation ops) (syntax-parse (reverse ops) - [(g:fusable-stream-consumer - op:fusable-stream-transformer ... + [(c:fusable-stream-consumer + t:fusable-stream-transformer ... p:fusable-stream-producer) ;; Contract probably not needed (prepare should produce ;; meaningful error messages) #`(esc (λ args - ((#,@#'g.end - (inline-compose1 [op.next op.f] ... + ((#,@#'c.end + (inline-compose1 [t.next t.f] ... p.next)) - (apply p.prepare args))))] - [(g:fusable-stream-consumer - p:fusable-stream-producer) - ;; dtto - #`(esc (λ args - ((#,@#'g.end p.next) - (apply p.prepare args))))] - ;; The list must contain fusable-stream-transformer0 as the last element! - [(g:fusable-stream-consumer - op:fusable-stream-transformer ...) - ;; TODO: Add contract - #`(esc (λ (lst) - ((#,@#'g.end - (inline-compose1 [op.next op.f] ... - list->cstream-next)) - lst)))] - [(op:fusable-stream-transformer ... - p:fusable-stream-producer) - ;; dtto - #`(esc (λ args - ((cstream->list - (inline-compose1 [op.next op.f] ... - p.next)) - (apply p.prepare args))))] - ;; dtto - [(op:fusable-stream-transformer ...) - #'(esc (λ (lst) - ;; have a contract here for the input - ;; validate it's a list, and error message - ;; can include the op syntax object - ((cstream->list - (inline-compose1 [op.next op.f] ... - list->cstream-next)) - lst)))] - )) + (apply p.prepare args))))])) ;; 0. "Qi-normal form" ;; 1. deforestation pass @@ -158,67 +146,41 @@ (syntax-parse stx [((~datum thread) _0:non-fusable ... p:fusable-stream-producer - f:fusable-stream-transformer ...+ - g:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(p f ... g))) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - g:fusable-stream-consumer + ;; There can be zero transformers here: + t:fusable-stream-transformer ... + c:fusable-stream-consumer _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(p g))) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c))) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... - f1:fusable-stream-transformer0 - f:fusable-stream-transformer ...+ - g:fusable-stream-consumer + t1:fusable-stream-transformer0 + t:fusable-stream-transformer ... + c:fusable-stream-consumer _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(f1 f ... g))) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c))) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... p:fusable-stream-producer - f:fusable-stream-transformer ...+ + ;; Must be 1 or more transformers here: + t:fusable-stream-transformer ...+ _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(p f ...))) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list))) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... f1:fusable-stream-transformer0 f:fusable-stream-transformer ...+ _1 ...) - #:with fused (generate-fused-operation (syntax->list #'(f1 f ...))) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list))) #'(thread _0 ... fused _1 ...)] [_ this-syntax])) ) -;; Stream fusion -(define-inline (cstream->list next) - (λ (state) - (let loop ([state state]) - ((next (λ () null) - (λ (state) (loop state)) - (λ (value state) - (cons value (loop state)))) - state)))) - -(define-inline (foldr-cstream op init next) - (λ (state) - (let loop ([state state]) - ((next (λ () init) - (λ (state) (loop state)) - (λ (value state) - (op value (loop state)))) - state)))) - -(define-inline (foldl-cstream op init next) - (λ (state) - (let loop ([acc init] [state state]) - ((next (λ () acc) - (λ (state) (loop acc state)) - (λ (value state) - (loop (op value acc) state))) - state)))) +;; Producers (define-inline (list->cstream-next done skip yield) (λ (state) @@ -238,6 +200,8 @@ [(l h) (list l h 1)] [(l h s) (list l h s)])) +;; Transformers + (define-inline (map-cstream-next f next) (λ (done skip yield) (next done @@ -253,3 +217,32 @@ (if (f value) (yield value state) (skip state)))))) + +;; Consumers + +(define-inline (cstream-next->list next) + (λ (state) + (let loop ([state state]) + ((next (λ () null) + (λ (state) (loop state)) + (λ (value state) + (cons value (loop state)))) + state)))) + +(define-inline (foldr-cstream-next op init next) + (λ (state) + (let loop ([state state]) + ((next (λ () init) + (λ (state) (loop state)) + (λ (value state) + (op value (loop state)))) + state)))) + +(define-inline (foldl-cstream-next op init next) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) From c1e9ce096921130c803f7522ed544f1bef3aa8f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 11 Nov 2023 20:23:03 +0100 Subject: [PATCH 232/338] Cleanup unused pattern variable, implement car deforestation. --- qi-lib/flow/core/deforest.rkt | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index a03ae77a0..28bb785cd 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -33,8 +33,7 @@ (define-syntax-class fusable-stream-producer #:attributes (next prepare) #:datum-literals (#%host-expression #%partial-application esc) - (pattern (~and (esc (#%host-expression (~literal range))) - stx) + (pattern (esc (#%host-expression (~literal range))) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare) (pattern (~and (#%partial-application @@ -111,7 +110,9 @@ #:when (and chirality (eq? chirality 'right)) #:attr end #'(foldl-cstream-next op init)) (pattern (~literal cstream->list) - #:attr end #'(cstream-next->list))) + #:attr end #'(cstream-next->list)) + (pattern (esc (#%host-expression (~literal car))) + #:attr end #'(car-cstream-next))) (define-syntax-class non-fusable (pattern (~not (~or _:fusable-stream-transformer @@ -246,3 +247,11 @@ (λ (value state) (loop (op value acc) state))) state)))) + +(define-inline (car-cstream-next next) + (λ (state) + (let loop ([state state]) + ((next (λ () (error 'car "Empty list!")) + (λ (state) (loop state)) + (λ (value state) + value)))))) From 6eae07857e718a1b048f2c5ef23c4d36967d259e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 17 Nov 2023 20:56:30 +0100 Subject: [PATCH 233/338] Re-add begin-encourage-inline based on the benchmarks. --- qi-lib/flow/core/deforest.rkt | 130 ++++++++++++++++++---------------- 1 file changed, 67 insertions(+), 63 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 28bb785cd..92a880b0a 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -181,77 +181,81 @@ ) -;; Producers +(begin-encourage-inline -(define-inline (list->cstream-next done skip yield) - (λ (state) - (cond [(null? state) (done)] - [else (yield (car state) (cdr state))]))) + ;; Producers -(define-inline (range->cstream-next done skip yield) - (λ (state) - (match-define (list l h s) state) - (cond [(< l h) - (yield l (cons (+ l s) (cdr state)))] - [else (done)]))) + (define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) -(define range->cstream-prepare - (case-lambda - [(h) (list 0 h 1)] - [(l h) (list l h 1)] - [(l h s) (list l h s)])) + (define-inline (range->cstream-next done skip yield) + (λ (state) + (match-define (list l h s) state) + (cond [(< l h) + (yield l (cons (+ l s) (cdr state)))] + [else (done)]))) -;; Transformers + (define range->cstream-prepare + (case-lambda + [(h) (list 0 h 1)] + [(l h) (list l h 1)] + [(l h s) (list l h s)])) -(define-inline (map-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (yield (f value) state))))) + ;; Transformers -(define-inline (filter-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (if (f value) - (yield value state) - (skip state)))))) + (define-inline (map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (yield (f value) state))))) -;; Consumers + (define-inline (filter-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (if (f value) + (yield value state) + (skip state)))))) -(define-inline (cstream-next->list next) - (λ (state) - (let loop ([state state]) - ((next (λ () null) - (λ (state) (loop state)) - (λ (value state) - (cons value (loop state)))) - state)))) + ;; Consumers -(define-inline (foldr-cstream-next op init next) - (λ (state) - (let loop ([state state]) - ((next (λ () init) - (λ (state) (loop state)) - (λ (value state) - (op value (loop state)))) - state)))) + (define-inline (cstream-next->list next) + (λ (state) + (let loop ([state state]) + ((next (λ () null) + (λ (state) (loop state)) + (λ (value state) + (cons value (loop state)))) + state)))) -(define-inline (foldl-cstream-next op init next) - (λ (state) - (let loop ([acc init] [state state]) - ((next (λ () acc) - (λ (state) (loop acc state)) - (λ (value state) - (loop (op value acc) state))) - state)))) + (define-inline (foldr-cstream-next op init next) + (λ (state) + (let loop ([state state]) + ((next (λ () init) + (λ (state) (loop state)) + (λ (value state) + (op value (loop state)))) + state)))) -(define-inline (car-cstream-next next) - (λ (state) - (let loop ([state state]) - ((next (λ () (error 'car "Empty list!")) - (λ (state) (loop state)) - (λ (value state) - value)))))) + (define-inline (foldl-cstream-next op init next) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) + + (define-inline (car-cstream-next next) + (λ (state) + (let loop ([state state]) + ((next (λ () (error 'car "Empty list!")) + (λ (state) (loop state)) + (λ (value state) + value)))))) + + ) From 1f800afcf01f27566211c46d7d45acc45422aa92 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 00:08:57 -0800 Subject: [PATCH 234/338] add `range-map` benchmark --- qi-sdk/profile/nonlocal/qi/main.rkt | 5 +++++ qi-sdk/profile/nonlocal/racket/main.rkt | 4 ++++ qi-sdk/profile/nonlocal/spec.rkt | 3 +++ 3 files changed, 12 insertions(+) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 6636aa7cf..5f2288f49 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -12,6 +12,7 @@ pingala eratosthenes collatz + range-map filter-map filter-map-foldr filter-map-foldl @@ -83,6 +84,10 @@ (map sqr) (foldl + 0))) +(define-flow range-map + (~>> (range 0) + (map sqr))) + ;; (define-flow filter-map ;; (~>> (filter odd?) ;; (map sqr) diff --git a/qi-sdk/profile/nonlocal/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt index e40670fbe..525462047 100644 --- a/qi-sdk/profile/nonlocal/racket/main.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -7,6 +7,7 @@ pingala eratosthenes collatz + range-map filter-map filter-map-foldr filter-map-foldl @@ -58,6 +59,9 @@ [(odd? n) (cons n (collatz (+ (* 3 n) 1)))] [(even? n) (cons n (collatz (quotient n 2)))])) +(define (range-map v) + (map sqr (range 0 v))) + (define (filter-map lst) (map sqr (filter odd? lst))) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index b6e640f6f..6f9e4695a 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -20,6 +20,9 @@ (bm "root-mean-square" check-list 500000) + (bm "range-map" + check-value + 500000) (bm "filter-map" check-list 500000) From b6f2ac5e720fde2bf824e6f87b3b3afe1a52756f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 12:04:00 -0800 Subject: [PATCH 235/338] fix compiler tests --- qi-test/tests/compiler.rkt | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 07ceb8aea..8155dadd3 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -20,6 +20,7 @@ #'(#%partial-application ((#%host-expression filter) (#%host-expression odd?))))]) + ;; note this tests the rule in isolation; with normalization this would never be necessary (check-equal? (syntax->datum (deforest-rewrite #`(thread #,stx))) @@ -27,19 +28,17 @@ (esc (λ (lst) ((cstream->list (inline-compose1 (filter-cstream-next odd?) list->cstream-next)) lst)))) - "deforestation of map -- note this tests the rule in isolation; with normalization this would never be necessary")) + "deforest filter")) (let ([stx (make-right-chiral #'(#%partial-application ((#%host-expression map) (#%host-expression sqr))))]) + ;; note this tests the rule in isolation; with normalization this would never be necessary (check-equal? (syntax->datum (deforest-rewrite #`(thread #,stx))) - '(thread - (esc - (λ (lst) - ((cstream->list (inline-compose1 (map-cstream-next sqr) list->cstream-next)) lst)))) - "deforestation of filter -- note this tests the rule in isolation; with normalization this would never be necessary")) + '(thread (#%partial-application ((#%host-expression map) (#%host-expression sqr)))) + "does not deforest map in the head position")) (let ([stx (map make-right-chiral (syntax->list #'(values @@ -70,7 +69,7 @@ (let ([stx (map make-right-chiral (syntax->list #'((#%partial-application - ((#%host-expression map) + ((#%host-expression filter) (#%host-expression string-upcase))) (#%partial-application ((#%host-expression foldl) @@ -86,7 +85,7 @@ string-append "I" (inline-compose1 - (map-cstream-next + (filter-cstream-next string-upcase) list->cstream-next)) lst)))) From cbda30c96f8d796e8aaf4d2c35920f21644a9fb6 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 09:05:01 -0800 Subject: [PATCH 236/338] add a (failing) test for deforestation in nested positions --- qi-test/tests/compiler.rkt | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 8155dadd3..05e403052 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -66,6 +66,34 @@ lst))) values) "deforestation in arbitrary positions")) + (let ([stx (map make-right-chiral + (syntax->list + #`(values + #,(cons 'thread (map make-right-chiral + (syntax->list + #'((#%partial-application + ((#%host-expression filter) + (#%host-expression odd?))) + (#%partial-application + ((#%host-expression map) + (#%host-expression sqr))))))))))]) + (check-equal? (syntax->datum + (deforest-rewrite + #`(thread #,@stx))) + '(thread + values + (esc + (λ (lst) + ((cstream->list + (inline-compose1 + (map-cstream-next + sqr) + (filter-cstream-next + odd?) + list->cstream-next)) + lst))) + values) + "deforestation in nested positions")) (let ([stx (map make-right-chiral (syntax->list #'((#%partial-application From 39dd1e3e2460f57d39a003191ff91796742a1a84 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 09:05:30 -0800 Subject: [PATCH 237/338] remove testing-related nesting in qi deforestation benchmark --- qi-sdk/profile/nonlocal/qi/main.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 5f2288f49..21c799bc5 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -70,9 +70,8 @@ ;; (~>> (filter odd?) (map sqr))) (define-flow filter-map - (~>> values - (~>> (filter odd?) - (map sqr)))) + (~>> (filter odd?) + (map sqr))) (define-flow filter-map-foldr (~>> (filter odd?) From fef36b319dd5df0feb65ee7cb9940adc7bec3243 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 12:07:40 -0800 Subject: [PATCH 238/338] validate that `range` deforestation doesn't harm performance --- qi-sdk/profile/nonlocal/spec.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index 6f9e4695a..d1a76f5b1 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -21,8 +21,8 @@ check-list 500000) (bm "range-map" - check-value - 500000) + check-value-large + 50000) (bm "filter-map" check-list 500000) From 3b83b544e17f1ff12d6ca55dc1456e481df5e0ee Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 15:25:04 -0800 Subject: [PATCH 239/338] fix (most) compiler tests again --- qi-test/tests/compiler.rkt | 50 ++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 05e403052..261e7d3c5 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -2,7 +2,7 @@ (provide tests) -(require (for-template qi/flow/core/compiler) +(require (for-template qi/flow/core/deforest) (only-in qi/flow/extended/syntax make-right-chiral) rackunit @@ -16,18 +16,21 @@ (test-suite "deforestation" ;; (~>> values (filter odd?) (map sqr) values) - (let ([stx (make-right-chiral - #'(#%partial-application - ((#%host-expression filter) - (#%host-expression odd?))))]) - ;; note this tests the rule in isolation; with normalization this would never be necessary + (let ([stx (map make-right-chiral + (syntax->list #'((#%partial-application + ((#%host-expression filter) + (#%host-expression odd?))) + (#%partial-application + ((#%host-expression map) + (#%host-expression sqr))))))]) (check-equal? (syntax->datum (deforest-rewrite - #`(thread #,stx))) + #`(thread #,@stx))) '(thread (esc - (λ (lst) - ((cstream->list (inline-compose1 (filter-cstream-next odd?) list->cstream-next)) lst)))) + (λ args + ((cstream-next->list (inline-compose1 (map-cstream-next sqr) (filter-cstream-next odd?) list->cstream-next)) + (apply identity args))))) "deforest filter")) (let ([stx (make-right-chiral #'(#%partial-application @@ -55,28 +58,29 @@ '(thread values (esc - (λ (lst) - ((cstream->list + (λ args + ((cstream-next->list (inline-compose1 (map-cstream-next sqr) (filter-cstream-next odd?) list->cstream-next)) - lst))) + (apply identity args)))) values) "deforestation in arbitrary positions")) (let ([stx (map make-right-chiral (syntax->list #`(values - #,(cons 'thread (map make-right-chiral - (syntax->list - #'((#%partial-application - ((#%host-expression filter) - (#%host-expression odd?))) - (#%partial-application - ((#%host-expression map) - (#%host-expression sqr))))))))))]) + (thread + #,@(map make-right-chiral + (syntax->list + #'((#%partial-application + ((#%host-expression filter) + (#%host-expression odd?))) + (#%partial-application + ((#%host-expression map) + (#%host-expression sqr))))))))))]) (check-equal? (syntax->datum (deforest-rewrite #`(thread #,@stx))) @@ -108,15 +112,15 @@ #`(thread #,@stx))) '(thread (esc - (λ (lst) - ((foldl-cstream + (λ args + ((foldl-cstream-next string-append "I" (inline-compose1 (filter-cstream-next string-upcase) list->cstream-next)) - lst)))) + (apply identity args))))) "deforestation in arbitrary positions"))) (test-suite "fixed point" From 791692c1caaca5c0334444564dc1bcced2a31463 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 16:51:50 -0800 Subject: [PATCH 240/338] remove outdated compiler rewrite rule --- qi-lib/flow/core/compiler.rkt | 3 --- 1 file changed, 3 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 102ea12e9..1bfc53068 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -45,9 +45,6 @@ ;; call to the optimizer ;; TODO: eliminate outdated rules here (syntax-parse stx - ;; restorative optimization for "all" - [((~datum thread) ((~datum amp) onex) (~datum AND)) - #`(esc (give (curry andmap #,(compile-flow #'onex))))] ;; "deforestation" for values ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) From cbd6b2b9219b2acd17abaec87d7f113212f4d4e1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 17:10:43 -0800 Subject: [PATCH 241/338] normalization rule to collapse `values` inside a threading form --- qi-lib/flow/core/compiler.rkt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 1bfc53068..1c16ac170 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -88,7 +88,12 @@ ;; and we can only know this at runtime. [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) #'(thread _0 ... _1 ...)] - ;; return syntax unchanged if there are no known optimizations + ;; collapse `values` and `_` inside a threading form + [((~datum thread) _0 ... (~literal values) _1 ...) + #'(thread _0 ... _1 ...)] + [((~datum thread) _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] + ;; return syntax unchanged if there are no applicable normalizations [_ stx])) ;; Applies f repeatedly to the init-val terminating the loop if the From cacdbad54ccf63d7a28811e160d30c443437eb81 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 17 Nov 2023 17:37:29 -0800 Subject: [PATCH 242/338] Add initial tests for the normalization pass This uses the approach of independently normalizing two expressions we expect to be equivalent, and comparing the results for equality. This allows us to avoid dealing with the intricacies of the normalized output in our tests while still making useful and sufficient assertions about it. The approach was suggested by Sam and Gus on Discourse: https://racket.discourse.group/t/best-practices-for-testing-compiler-optimizations/2369 --- qi-lib/flow/core/compiler.rkt | 11 ++++--- qi-test/tests/compiler.rkt | 56 ++++++++++++++++------------------- 2 files changed, 32 insertions(+), 35 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 1c16ac170..fbdc04a20 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -1,9 +1,7 @@ #lang racket/base (provide (for-syntax compile-flow - ;; TODO: only used in unit tests, maybe try - ;; using a submodule to avoid providing these usually - deforest-rewrite)) + normalize-pass)) (require (for-syntax racket/base syntax/parse @@ -28,6 +26,11 @@ (emit-local-step stx0 stx1 #:id #'name) stx1)) + ;; TODO: move this to a common utils module for use in all + ;; modules implementing optimization passes + ;; Also, resolve + ;; "syntax-local-expand-observer: not currently expanding" + ;; issue encountered in running compiler unit tests (define-syntax-rule (define-qi-expansion-step (name stx0) body ...) (define (name stx0) @@ -39,7 +42,7 @@ (define (compile-flow stx) (process-bindings (optimize-flow stx))) - (define-qi-expansion-step (normalize-rewrite stx) + (define (normalize-rewrite stx) ;; TODO: the "active" components of the expansions should be ;; optimized, i.e. they should be wrapped with a recursive ;; call to the optimizer diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 261e7d3c5..2ab721eb1 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -2,20 +2,27 @@ (provide tests) -(require (for-template qi/flow/core/deforest) +(require (for-template qi/flow/core/deforest + qi/flow/core/compiler) (only-in qi/flow/extended/syntax make-right-chiral) rackunit rackunit/text-ui (only-in math sqr)) +(define-syntax-rule (test-normalize a b msg) + (check-equal? (syntax->datum + (normalize-pass a)) + (syntax->datum + (normalize-pass b)) + msg)) + (define tests (test-suite "compiler tests" (test-suite "deforestation" - ;; (~>> values (filter odd?) (map sqr) values) (let ([stx (map make-right-chiral (syntax->list #'((#%partial-application ((#%host-expression filter) @@ -42,6 +49,7 @@ #`(thread #,stx))) '(thread (#%partial-application ((#%host-expression map) (#%host-expression sqr)))) "does not deforest map in the head position")) + ;; (~>> values (filter odd?) (map sqr) values) (let ([stx (map make-right-chiral (syntax->list #'(values @@ -69,35 +77,6 @@ (apply identity args)))) values) "deforestation in arbitrary positions")) - (let ([stx (map make-right-chiral - (syntax->list - #`(values - (thread - #,@(map make-right-chiral - (syntax->list - #'((#%partial-application - ((#%host-expression filter) - (#%host-expression odd?))) - (#%partial-application - ((#%host-expression map) - (#%host-expression sqr))))))))))]) - (check-equal? (syntax->datum - (deforest-rewrite - #`(thread #,@stx))) - '(thread - values - (esc - (λ (lst) - ((cstream->list - (inline-compose1 - (map-cstream-next - sqr) - (filter-cstream-next - odd?) - list->cstream-next)) - lst))) - values) - "deforestation in nested positions")) (let ([stx (map make-right-chiral (syntax->list #'((#%partial-application @@ -122,6 +101,21 @@ list->cstream-next)) (apply identity args))))) "deforestation in arbitrary positions"))) + (test-suite + "normalization" + (test-normalize #'(thread + (thread (filter odd?) + (map sqr))) + #'(thread (filter odd?) + (map sqr)) + "nested threads are collapsed") + (test-normalize #'(thread values + sqr) + #'(thread sqr) + "values inside threading is elided") + (test-normalize #'(thread sqr) + #'sqr + "trivial threading is collapsed")) (test-suite "fixed point" null))) From 40c0737fde2ac154af5d91f8c86a86b537ace622 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 20 Nov 2023 12:25:42 -0800 Subject: [PATCH 243/338] improve `range-map-sum` benchmark --- qi-sdk/profile/nonlocal/qi/main.rkt | 5 +---- qi-sdk/profile/nonlocal/racket/main.rkt | 5 +---- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 21c799bc5..f6311a188 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -94,11 +94,8 @@ ;; (filter (λ (v) (< v 10))) ;; (map sqr))) -(define (~sum vs) - (apply + vs)) - (define-flow range-map-sum - (~>> (range 1) (map sqr) ~sum)) + (~>> (range 0) (map sqr) (foldr + 0))) ;; (define filter-double ;; (map (☯ (when odd? diff --git a/qi-sdk/profile/nonlocal/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt index 525462047..1f942b12c 100644 --- a/qi-sdk/profile/nonlocal/racket/main.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -75,11 +75,8 @@ (apply values (map sqr (filter odd? vs)))) -(define (~sum vs) - (apply + vs)) - (define (range-map-sum n) - (~sum (map sqr (range 1 n)))) + (apply + (map sqr (range 0 n)))) (define (double-list lst) (apply append (map (λ (v) (list v v)) lst))) From 1bac5b437d8cd5c7974c366705951968ba04d28a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 20 Nov 2023 12:30:45 -0800 Subject: [PATCH 244/338] add a "long functional pipeline" benchmark --- qi-sdk/profile/nonlocal/qi/main.rkt | 15 +++++++++------ qi-sdk/profile/nonlocal/racket/main.rkt | 11 +++++++++++ qi-sdk/profile/nonlocal/spec.rkt | 3 +++ qi-sdk/profile/util.rkt | 3 +++ 4 files changed, 26 insertions(+), 6 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index f6311a188..1581dd11c 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -16,6 +16,7 @@ filter-map filter-map-foldr filter-map-foldl + long-functional-pipeline filter-map-values range-map-sum double-list @@ -87,12 +88,14 @@ (~>> (range 0) (map sqr))) -;; (define-flow filter-map -;; (~>> (filter odd?) -;; (map sqr) -;; identity -;; (filter (λ (v) (< v 10))) -;; (map sqr))) +(define-flow long-functional-pipeline + (~>> (range 0) + (filter odd?) + (map sqr) + values + (filter (λ (v) (< (remainder v 10) 5))) + (map (λ (v) (* 2 v))) + (foldl + 0))) (define-flow range-map-sum (~>> (range 0) (map sqr) (foldr + 0))) diff --git a/qi-sdk/profile/nonlocal/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt index 1f942b12c..76f461acd 100644 --- a/qi-sdk/profile/nonlocal/racket/main.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -11,6 +11,7 @@ filter-map filter-map-foldr filter-map-foldl + long-functional-pipeline filter-map-values range-map-sum double-list @@ -71,6 +72,16 @@ (define (filter-map-foldl lst) (foldl + 0 (map sqr (filter odd? lst)))) +(define (long-functional-pipeline v) + (foldl + + 0 + (map (λ (v) (* 2 v)) + (filter (λ (v) (< (remainder v 10) 5)) + (values + (map sqr + (filter odd? + (range 0 v)))))))) + (define (filter-map-values . vs) (apply values (map sqr (filter odd? vs)))) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index d1a76f5b1..c8a7c38d7 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -35,6 +35,9 @@ (bm "filter-map-foldl" check-large-list 50000) + (bm "long-functional-pipeline" + check-value-large + 5000) (bm "range-map-sum" check-value-large 5000) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index b831bd1e6..27a0be0ef 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -5,6 +5,7 @@ check-value check-value-medium-large check-value-large + check-value-very-large check-list check-large-list check-values @@ -63,6 +64,8 @@ (define check-value-large (curryr check-value #(1000))) +(define check-value-very-large (curryr check-value #(100000))) + ;; This uses the same list input each time. Not sure if that ;; may end up being cached at some level and thus obfuscate ;; the results? On the other hand, From 2fd527583efe72063d15c5d677c81e3026e84d72 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 20 Nov 2023 12:36:26 -0800 Subject: [PATCH 245/338] remove unused code --- qi-sdk/profile/nonlocal/qi/main.rkt | 8 -------- 1 file changed, 8 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 1581dd11c..ab0a52ad9 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -1,10 +1,5 @@ #lang racket/base -(require racket/match - racket/function) - -(require racket/performance-hint) - (provide conditionals composition root-mean-square @@ -67,9 +62,6 @@ ;; (define-flow filter-map ;; (~> △ (>< (if odd? sqr ⏚)) ▽)) -;; (define-flow filter-map -;; (~>> (filter odd?) (map sqr))) - (define-flow filter-map (~>> (filter odd?) (map sqr))) From 6ada8964c337197b4aa8c44f565964a844929925 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 20 Nov 2023 12:55:44 -0800 Subject: [PATCH 246/338] Replace `range-map` benchmark with `range-map-car` This will be more useful, e.g. to compare against `range-map-sum` which must consume the entire stream. --- qi-sdk/profile/nonlocal/qi/main.rkt | 13 +++++++------ qi-sdk/profile/nonlocal/racket/main.rkt | 14 +++++++------- qi-sdk/profile/nonlocal/spec.rkt | 2 +- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index ab0a52ad9..2f919ba68 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -7,7 +7,7 @@ pingala eratosthenes collatz - range-map + range-map-car filter-map filter-map-foldr filter-map-foldl @@ -76,9 +76,13 @@ (map sqr) (foldl + 0))) -(define-flow range-map +(define-flow range-map-car (~>> (range 0) - (map sqr))) + (map sqr) + car)) + +(define-flow range-map-sum + (~>> (range 0) (map sqr) (foldr + 0))) (define-flow long-functional-pipeline (~>> (range 0) @@ -89,9 +93,6 @@ (map (λ (v) (* 2 v))) (foldl + 0))) -(define-flow range-map-sum - (~>> (range 0) (map sqr) (foldr + 0))) - ;; (define filter-double ;; (map (☯ (when odd? ;; (-< _ _))) diff --git a/qi-sdk/profile/nonlocal/racket/main.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt index 76f461acd..897698053 100644 --- a/qi-sdk/profile/nonlocal/racket/main.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -7,7 +7,7 @@ pingala eratosthenes collatz - range-map + range-map-car filter-map filter-map-foldr filter-map-foldl @@ -60,9 +60,6 @@ [(odd? n) (cons n (collatz (+ (* 3 n) 1)))] [(even? n) (cons n (collatz (quotient n 2)))])) -(define (range-map v) - (map sqr (range 0 v))) - (define (filter-map lst) (map sqr (filter odd? lst))) @@ -72,6 +69,12 @@ (define (filter-map-foldl lst) (foldl + 0 (map sqr (filter odd? lst)))) +(define (range-map-car v) + (car (map sqr (range 0 v)))) + +(define (range-map-sum n) + (apply + (map sqr (range 0 n)))) + (define (long-functional-pipeline v) (foldl + 0 @@ -86,9 +89,6 @@ (apply values (map sqr (filter odd? vs)))) -(define (range-map-sum n) - (apply + (map sqr (range 0 n)))) - (define (double-list lst) (apply append (map (λ (v) (list v v)) lst))) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt index c8a7c38d7..eb7b5388f 100644 --- a/qi-sdk/profile/nonlocal/spec.rkt +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -20,7 +20,7 @@ (bm "root-mean-square" check-list 500000) - (bm "range-map" + (bm "range-map-car" check-value-large 50000) (bm "filter-map" From 94969e5de215fb39539e13cef35dabd4ea173295 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 20 Nov 2023 13:19:53 -0800 Subject: [PATCH 247/338] failing unit test for range-map-car --- qi-test/tests/flow.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 4c800a5b9..7535a54e5 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1550,7 +1550,10 @@ "ABCI") (check-equal? ((☯ (~>> (map string-upcase) (foldl string-append "I"))) (list "a" "b" "c")) - "CBAI"))))) + "CBAI") + (check-equal? ((☯ (~>> (range 10) (map sqr) car)) + 0) + 0))))) (module+ main (void (run-tests tests))) From b3dd07e17afe6fcb0c96605cfc2554a27ceef4aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Mon, 20 Nov 2023 22:21:56 +0100 Subject: [PATCH 248/338] Partial implementation of producer prepare contract. --- qi-lib/flow/core/deforest.rkt | 42 +++++++++++++++++++++++++---------- 1 file changed, 30 insertions(+), 12 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 92a880b0a..d581cb672 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -3,11 +3,13 @@ (provide (for-syntax deforest-rewrite)) (require (for-syntax racket/base - syntax/parse) + syntax/parse + racket/syntax-srcloc) racket/performance-hint racket/match racket/function - racket/list) + racket/list + racket/contract/base) ;; These bindings are used for ~literal matching to introduce implicit ;; producer/consumer when none is explicitly given in the flow. @@ -31,11 +33,13 @@ ;; not created by using this class but rather explicitly used when ;; no syntax class producer is matched. (define-syntax-class fusable-stream-producer - #:attributes (next prepare) + #:attributes (next prepare contract name) #:datum-literals (#%host-expression #%partial-application esc) (pattern (esc (#%host-expression (~literal range))) #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare) + #:attr prepare #'range->cstream-prepare + #:attr contract #'any/c + #:attr name #''range) (pattern (~and (#%partial-application ((#%host-expression (~literal range)) (#%host-expression arg) ...)) @@ -45,10 +49,14 @@ #'curry #'curryr) #:attr next #'range->cstream-next - #:attr prepare #'(vindaloo range->cstream-prepare arg ...)) + #:attr prepare #'(vindaloo range->cstream-prepare arg ...) + #:attr contract #'any/c + #:attr name #''range) (pattern (~literal list->cstream) #:attr next #'list->cstream-next - #:attr prepare #'identity)) + #:attr prepare #'values + #:attr contract #'(-> list? any) + #:attr name #''list->cstream)) ;; Matches any stream transformer that can be in the head position ;; of the fused sequence even when there is no explicit @@ -123,7 +131,7 @@ ;; sequence. The syntax list must already conform to the rule that ;; if the first operation is a fusable-stream-transformer, it must ;; be a fusable-stream-transformer0 as well! - (define (generate-fused-operation ops) + (define (generate-fused-operation ops ctx) (syntax-parse (reverse ops) [(c:fusable-stream-consumer t:fusable-stream-transformer ... @@ -134,7 +142,13 @@ ((#,@#'c.end (inline-compose1 [t.next t.f] ... p.next)) - (apply p.prepare args))))])) + (apply (contract p.contract + p.prepare + p.name + '#,ctx + #f + #,(syntax-srcloc ctx)) + args))))])) ;; 0. "Qi-normal form" ;; 1. deforestation pass @@ -152,7 +166,8 @@ c:fusable-stream-consumer _1 ...) #:with fused (generate-fused-operation - (syntax->list #'(p t ... c))) + (syntax->list #'(p t ... c)) + stx) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... t1:fusable-stream-transformer0 @@ -160,7 +175,8 @@ c:fusable-stream-consumer _1 ...) #:with fused (generate-fused-operation - (syntax->list #'(list->cstream t1 t ... c))) + (syntax->list #'(list->cstream t1 t ... c)) + stx) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... p:fusable-stream-producer @@ -168,14 +184,16 @@ t:fusable-stream-transformer ...+ _1 ...) #:with fused (generate-fused-operation - (syntax->list #'(p t ... cstream->list))) + (syntax->list #'(p t ... cstream->list)) + stx) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... f1:fusable-stream-transformer0 f:fusable-stream-transformer ...+ _1 ...) #:with fused (generate-fused-operation - (syntax->list #'(list->cstream f1 f ... cstream->list))) + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) #'(thread _0 ... fused _1 ...)] [_ this-syntax])) From 0d3b197a42e40e0fe0719a293d560500555c9d0c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 20 Nov 2023 13:51:29 -0800 Subject: [PATCH 249/338] Refactor normalize pass into its own module --- qi-lib/flow/core/compiler.rkt | 60 ++----------------------------- qi-lib/flow/core/normalize.rkt | 66 ++++++++++++++++++++++++++++++++++ 2 files changed, 68 insertions(+), 58 deletions(-) create mode 100644 qi-lib/flow/core/normalize.rkt diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index fbdc04a20..31a2a94c7 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -16,7 +16,8 @@ racket/undefined (prefix-in fancy: fancy-app) racket/list - "deforest.rkt") + "deforest.rkt" + "normalize.rkt") (begin-for-syntax @@ -42,63 +43,6 @@ (define (compile-flow stx) (process-bindings (optimize-flow stx))) - (define (normalize-rewrite stx) - ;; TODO: the "active" components of the expansions should be - ;; optimized, i.e. they should be wrapped with a recursive - ;; call to the optimizer - ;; TODO: eliminate outdated rules here - (syntax-parse stx - ;; "deforestation" for values - ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) - [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) - #'(thread _0 ... (amp (if f g ground)) _1 ...)] - ;; merge amps in sequence - [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) - #`(thread _0 ... #,(normalize-rewrite #'(amp (thread f g))) _1 ...)] - ;; merge pass filters in sequence - [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) - #'(thread _0 ... (pass (and f g)) _1 ...)] - ;; collapse deterministic conditionals - [((~datum if) (~datum #t) f g) #'f] - [((~datum if) (~datum #f) f g) #'g] - ;; trivial threading form - [((~datum thread) f) - #'f] - ;; associative laws for ~> - [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) ; note: greedy matching - #'(thread _0 ... f ... _1 ...)] - ;; left and right identity for ~> - [((~datum thread) _0 ... (~datum _) _1 ...) - #'(thread _0 ... _1 ...)] - ;; composition of identity flows is the identity flow - [((~datum thread) (~datum _) ...) - #'_] - ;; identity flows composed using a relay - [((~datum relay) (~datum _) ...) - #'_] - ;; amp and identity - [((~datum amp) (~datum _)) - #'_] - ;; trivial tee junction - [((~datum tee) f) - #'f] - ;; merge adjacent gens - [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) - #'(tee _0 ... (gen a ... b ...) _1 ...)] - ;; prism identities - ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's - ;; only valid if the input is in fact a list, and is an error otherwise, - ;; and we can only know this at runtime. - [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) - #'(thread _0 ... _1 ...)] - ;; collapse `values` and `_` inside a threading form - [((~datum thread) _0 ... (~literal values) _1 ...) - #'(thread _0 ... _1 ...)] - [((~datum thread) _0 ... (~datum _) _1 ...) - #'(thread _0 ... _1 ...)] - ;; return syntax unchanged if there are no applicable normalizations - [_ stx])) - ;; Applies f repeatedly to the init-val terminating the loop if the ;; result of f is #f or the new syntax object is eq? to the previous ;; (possibly initial) one. diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt new file mode 100644 index 000000000..54f47b73b --- /dev/null +++ b/qi-lib/flow/core/normalize.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +(provide (for-syntax normalize-rewrite)) + +(require (for-syntax racket/base + syntax/parse)) + +(begin-for-syntax + + ;; 0. "Qi-normal form" + (define (normalize-rewrite stx) + ;; TODO: the "active" components of the expansions should be + ;; optimized, i.e. they should be wrapped with a recursive + ;; call to the optimizer + ;; TODO: eliminate outdated rules here + (syntax-parse stx + ;; "deforestation" for values + ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) + [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) + #'(thread _0 ... (amp (if f g ground)) _1 ...)] + ;; merge amps in sequence + [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) + #`(thread _0 ... #,(normalize-rewrite #'(amp (thread f g))) _1 ...)] + ;; merge pass filters in sequence + [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) + #'(thread _0 ... (pass (and f g)) _1 ...)] + ;; collapse deterministic conditionals + [((~datum if) (~datum #t) f g) #'f] + [((~datum if) (~datum #f) f g) #'g] + ;; trivial threading form + [((~datum thread) f) + #'f] + ;; associative laws for ~> + [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) ; note: greedy matching + #'(thread _0 ... f ... _1 ...)] + ;; left and right identity for ~> + [((~datum thread) _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] + ;; composition of identity flows is the identity flow + [((~datum thread) (~datum _) ...) + #'_] + ;; identity flows composed using a relay + [((~datum relay) (~datum _) ...) + #'_] + ;; amp and identity + [((~datum amp) (~datum _)) + #'_] + ;; trivial tee junction + [((~datum tee) f) + #'f] + ;; merge adjacent gens + [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + #'(tee _0 ... (gen a ... b ...) _1 ...)] + ;; prism identities + ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's + ;; only valid if the input is in fact a list, and is an error otherwise, + ;; and we can only know this at runtime. + [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) + #'(thread _0 ... _1 ...)] + ;; collapse `values` and `_` inside a threading form + [((~datum thread) _0 ... (~literal values) _1 ...) + #'(thread _0 ... _1 ...)] + [((~datum thread) _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] + ;; return syntax unchanged if there are no applicable normalizations + [_ stx]))) From 84b85e007b8a59b866826616893c0e133c11c525 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 20 Nov 2023 13:57:33 -0800 Subject: [PATCH 250/338] note a todo for normalization, and remove an outdated comment --- qi-lib/flow/core/normalize.rkt | 3 --- qi-sdk/profile/nonlocal/qi/main.rkt | 3 +++ 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index 54f47b73b..83c6584fe 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -9,9 +9,6 @@ ;; 0. "Qi-normal form" (define (normalize-rewrite stx) - ;; TODO: the "active" components of the expansions should be - ;; optimized, i.e. they should be wrapped with a recursive - ;; call to the optimizer ;; TODO: eliminate outdated rules here (syntax-parse stx ;; "deforestation" for values diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt index 2f919ba68..7d9f154ac 100644 --- a/qi-sdk/profile/nonlocal/qi/main.rkt +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -82,6 +82,9 @@ car)) (define-flow range-map-sum + ;; TODO: this should be written as (apply +) + ;; and that should be normalized to (foldr/l + 0) + ;; (depending on which of foldl/foldr is more performant) (~>> (range 0) (map sqr) (foldr + 0))) (define-flow long-functional-pipeline From 0bc343ba5d7d3d60787b995f58a2e9ff9d6cd3ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Tue, 21 Nov 2023 09:17:24 +0100 Subject: [PATCH 251/338] Fix car stream consumer, generate all possible contracts for range variants. --- qi-lib/flow/core/deforest.rkt | 41 +++++++++++++++++++++++++++++------ 1 file changed, 34 insertions(+), 7 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index d581cb672..83a4ca597 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -35,23 +35,49 @@ (define-syntax-class fusable-stream-producer #:attributes (next prepare contract name) #:datum-literals (#%host-expression #%partial-application esc) + ;; Explicit range producers. We have to conver all four variants + ;; as they all come with different runtime contracts! (pattern (esc (#%host-expression (~literal range))) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare - #:attr contract #'any/c + #:attr contract #'(->* (real?) (real? real?) any) #:attr name #''range) (pattern (~and (#%partial-application ((#%host-expression (~literal range)) - (#%host-expression arg) ...)) + (#%host-expression arg1))) stx) #:do [(define chirality (syntax-property #'stx 'chirality))] #:with vindaloo (if (and chirality (eq? chirality 'right)) #'curry #'curryr) #:attr next #'range->cstream-next - #:attr prepare #'(vindaloo range->cstream-prepare arg ...) - #:attr contract #'any/c + #:attr prepare #'(vindaloo range->cstream-prepare arg1) + #:attr contract #'(->* () (real? real?) any) #:attr name #''range) + (pattern (~and (#%partial-application + ((#%host-expression (~literal range)) + (#%host-expression arg1) + (#%host-expression arg2))) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:with vindaloo (if (and chirality (eq? chirality 'right)) + #'curry + #'curryr) + #:attr next #'range->cstream-next + #:attr prepare #'(vindaloo range->cstream-prepare arg1 arg2) + #:attr contract #'(->* () (real?) any) + #:attr name #''range) + (pattern (#%partial-application + ((#%host-expression (~literal range)) + (#%host-expression arg1) + (#%host-expression arg2) + (#%host-expression arg3))) + #:attr next #'range->cstream-next + #:attr prepare #'(λ () (range->cstream-prepare arg1 arg2 arg3)) + #:attr contract #'(-> any) + #:attr name #''range) + + ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) #:attr next #'list->cstream-next #:attr prepare #'values @@ -136,8 +162,8 @@ [(c:fusable-stream-consumer t:fusable-stream-transformer ... p:fusable-stream-producer) - ;; Contract probably not needed (prepare should produce - ;; meaningful error messages) + ;; A static runtime contract is placed at the beginning of the + ;; fused sequence. #`(esc (λ args ((#,@#'c.end (inline-compose1 [t.next t.f] ... @@ -274,6 +300,7 @@ ((next (λ () (error 'car "Empty list!")) (λ (state) (loop state)) (λ (value state) - value)))))) + value)) + state)))) ) From e3b15215c22ecec4326a5c37ee1a077a6604e2f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Wed, 22 Nov 2023 17:13:59 +0100 Subject: [PATCH 252/338] Deforestation producers - currying prepare in the right order, contract only for the resulting lambda expression. --- qi-lib/flow/core/deforest.rkt | 57 ++++++++++++++++++++--------------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 83a4ca597..37a8a10dc 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -33,7 +33,7 @@ ;; not created by using this class but rather explicitly used when ;; no syntax class producer is matched. (define-syntax-class fusable-stream-producer - #:attributes (next prepare contract name) + #:attributes (next prepare contract name curry) #:datum-literals (#%host-expression #%partial-application esc) ;; Explicit range producers. We have to conver all four variants ;; as they all come with different runtime contracts! @@ -41,7 +41,8 @@ #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare #:attr contract #'(->* (real?) (real? real?) any) - #:attr name #''range) + #:attr name #''range + #:attr curry #'(λ (v) v)) (pattern (~and (#%partial-application ((#%host-expression (~literal range)) (#%host-expression arg1))) @@ -51,9 +52,10 @@ #'curry #'curryr) #:attr next #'range->cstream-next - #:attr prepare #'(vindaloo range->cstream-prepare arg1) + #:attr prepare #'range->cstream-prepare #:attr contract #'(->* () (real? real?) any) - #:attr name #''range) + #:attr name #''range + #:attr curry #'(λ (v) (vindaloo v arg1))) (pattern (~and (#%partial-application ((#%host-expression (~literal range)) (#%host-expression arg1) @@ -64,25 +66,28 @@ #'curry #'curryr) #:attr next #'range->cstream-next - #:attr prepare #'(vindaloo range->cstream-prepare arg1 arg2) + #:attr prepare #'range->cstream-prepare #:attr contract #'(->* () (real?) any) - #:attr name #''range) + #:attr name #''range + #:attr curry #'(λ (v) (vindaloo v arg1 arg2))) (pattern (#%partial-application ((#%host-expression (~literal range)) (#%host-expression arg1) (#%host-expression arg2) (#%host-expression arg3))) #:attr next #'range->cstream-next - #:attr prepare #'(λ () (range->cstream-prepare arg1 arg2 arg3)) + #:attr prepare #'range->cstream-prepare #:attr contract #'(-> any) - #:attr name #''range) + #:attr name #''range + #:attr curry #'(λ (v) (λ () (v arg1 arg2 arg3)))) ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) #:attr next #'list->cstream-next - #:attr prepare #'values + #:attr prepare #'list->cstream-prepare #:attr contract #'(-> list? any) - #:attr name #''list->cstream)) + #:attr name #''list->cstream + #:attr curry #'(lambda (v) v))) ;; Matches any stream transformer that can be in the head position ;; of the fused sequence even when there is no explicit @@ -164,17 +169,16 @@ p:fusable-stream-producer) ;; A static runtime contract is placed at the beginning of the ;; fused sequence. - #`(esc (λ args - ((#,@#'c.end - (inline-compose1 [t.next t.f] ... - p.next)) - (apply (contract p.contract - p.prepare - p.name - '#,ctx - #f - #,(syntax-srcloc ctx)) - args))))])) + #`(esc (contract p.contract + (p.curry + (p.prepare + (#,@#'c.end + (inline-compose1 [t.next t.f] ... + p.next)))) + p.name + '#,ctx + #f + #,(syntax-srcloc ctx)))])) ;; 0. "Qi-normal form" ;; 1. deforestation pass @@ -234,6 +238,9 @@ (cond [(null? state) (done)] [else (yield (car state) (cdr state))]))) + (define-inline ((list->cstream-prepare next) lst) + (next lst)) + (define-inline (range->cstream-next done skip yield) (λ (state) (match-define (list l h s) state) @@ -241,11 +248,11 @@ (yield l (cons (+ l s) (cdr state)))] [else (done)]))) - (define range->cstream-prepare + (define (range->cstream-prepare next) (case-lambda - [(h) (list 0 h 1)] - [(l h) (list l h 1)] - [(l h s) (list l h s)])) + [(h) (next (list 0 h 1))] + [(l h) (next (list l h 1))] + [(l h s) (next (list l h s))])) ;; Transformers From ad72a8d0c746ef0a8787cb7144b297eca2b9ff03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Wed, 22 Nov 2023 19:28:50 +0100 Subject: [PATCH 253/338] Preliminary implementation of consumer contracts with car as an example. --- qi-lib/flow/core/deforest.rkt | 41 ++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 37a8a10dc..ec4ea0150 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -126,9 +126,7 @@ #:attr next #'filter-cstream-next)) ;; Terminates the fused sequence (consumes the stream) and produces - ;; an actual result value. The implicit consumer is cstream->list is - ;; not part of this class as it is added explicitly when generating - ;; the fused operation. + ;; an actual result value. (define-syntax-class fusable-stream-consumer #:attributes (end) #:datum-literals (#%host-expression #%partial-application) @@ -153,40 +151,40 @@ (pattern (esc (#%host-expression (~literal car))) #:attr end #'(car-cstream-next))) + ;; Used only in deforest-rewrite to properly recognize the end of + ;; fusable sequence. (define-syntax-class non-fusable (pattern (~not (~or _:fusable-stream-transformer _:fusable-stream-producer _:fusable-stream-consumer)))) ;; Generates a syntax for the fused operation for given - ;; sequence. The syntax list must already conform to the rule that - ;; if the first operation is a fusable-stream-transformer, it must - ;; be a fusable-stream-transformer0 as well! + ;; sequence. The syntax list must already be in the following form: + ;; (producer transformer ... consumer) (define (generate-fused-operation ops ctx) (syntax-parse (reverse ops) [(c:fusable-stream-consumer t:fusable-stream-transformer ... p:fusable-stream-producer) ;; A static runtime contract is placed at the beginning of the - ;; fused sequence. + ;; fused sequence. And runtime checks for consumers are in + ;; their respective implementation procedure. #`(esc (contract p.contract (p.curry (p.prepare (#,@#'c.end (inline-compose1 [t.next t.f] ... - p.next)))) + p.next) + '#,ctx + #,(syntax-srcloc ctx)))) p.name '#,ctx #f #,(syntax-srcloc ctx)))])) - ;; 0. "Qi-normal form" - ;; 1. deforestation pass - ;; 2. other passes ... - ;; e.g.: - ;; changing internal representation to lists from values - may affect passes - ;; passes as distinct stages is safe and interesting, a conservative start - ;; one challenge: traversing the syntax tree + ;; Performs one step of deforestation rewrite. Should be used as + ;; many times as needed - until it returns the source syntax + ;; unchanged. (define (deforest-rewrite stx) (syntax-parse stx [((~datum thread) _0:non-fusable ... @@ -274,7 +272,7 @@ ;; Consumers - (define-inline (cstream-next->list next) + (define-inline (cstream-next->list next ctx src) (λ (state) (let loop ([state state]) ((next (λ () null) @@ -283,7 +281,7 @@ (cons value (loop state)))) state)))) - (define-inline (foldr-cstream-next op init next) + (define-inline (foldr-cstream-next op init next ctx src) (λ (state) (let loop ([state state]) ((next (λ () init) @@ -292,7 +290,7 @@ (op value (loop state)))) state)))) - (define-inline (foldl-cstream-next op init next) + (define-inline (foldl-cstream-next op init next ctx src) (λ (state) (let loop ([acc init] [state state]) ((next (λ () acc) @@ -301,10 +299,13 @@ (loop (op value acc) state))) state)))) - (define-inline (car-cstream-next next) + (define-inline (car-cstream-next next ctx src) (λ (state) (let loop ([state state]) - ((next (λ () (error 'car "Empty list!")) + ((next (λ () ((contract (-> pair? any) + (λ (v) v) + 'car-cstream-next ctx #f + src) '())) (λ (state) (loop state)) (λ (value state) value)) From 414c2ee8f783d4ea95b80c2f2200fc2686a8c735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 23 Nov 2023 21:52:13 +0100 Subject: [PATCH 254/338] Unified range producer syntax class + currying contracted pipeline. --- qi-lib/flow/core/deforest.rkt | 76 +++++++++++++---------------------- 1 file changed, 27 insertions(+), 49 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index ec4ea0150..43fb19dec 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -37,49 +37,26 @@ #:datum-literals (#%host-expression #%partial-application esc) ;; Explicit range producers. We have to conver all four variants ;; as they all come with different runtime contracts! - (pattern (esc (#%host-expression (~literal range))) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare - #:attr contract #'(->* (real?) (real? real?) any) - #:attr name #''range - #:attr curry #'(λ (v) v)) - (pattern (~and (#%partial-application - ((#%host-expression (~literal range)) - (#%host-expression arg1))) + (pattern (~and (~or (esc (#%host-expression (~literal range))) + (#%partial-application + ((#%host-expression (~literal range)) + (#%host-expression arg) ...))) stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] + #:do [(define chirality (syntax-property #'stx 'chirality)) + (define num-args (if (attribute arg) + (length (syntax->list #'(arg ...))) + 0))] #:with vindaloo (if (and chirality (eq? chirality 'right)) #'curry #'curryr) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare - #:attr contract #'(->* () (real? real?) any) - #:attr name #''range - #:attr curry #'(λ (v) (vindaloo v arg1))) - (pattern (~and (#%partial-application - ((#%host-expression (~literal range)) - (#%host-expression arg1) - (#%host-expression arg2))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:with vindaloo (if (and chirality (eq? chirality 'right)) - #'curry - #'curryr) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare - #:attr contract #'(->* () (real?) any) - #:attr name #''range - #:attr curry #'(λ (v) (vindaloo v arg1 arg2))) - (pattern (#%partial-application - ((#%host-expression (~literal range)) - (#%host-expression arg1) - (#%host-expression arg2) - (#%host-expression arg3))) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare - #:attr contract #'(-> any) + #:attr contract #'(->* (real?) (real? real?) any) #:attr name #''range - #:attr curry #'(λ (v) (λ () (v arg1 arg2 arg3)))) + #:attr curry (case num-args + ((0) #'(λ (v) v)) + ((1 2) #'(λ (v) (vindaloo v arg ...))) + ((3) #'(λ (v) (v arg ...))))) ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) @@ -169,18 +146,19 @@ ;; A static runtime contract is placed at the beginning of the ;; fused sequence. And runtime checks for consumers are in ;; their respective implementation procedure. - #`(esc (contract p.contract - (p.curry - (p.prepare - (#,@#'c.end - (inline-compose1 [t.next t.f] ... - p.next) - '#,ctx - #,(syntax-srcloc ctx)))) - p.name - '#,ctx - #f - #,(syntax-srcloc ctx)))])) + #`(esc + (p.curry + (contract p.contract + (p.prepare + (#,@#'c.end + (inline-compose1 [t.next t.f] ... + p.next) + '#,ctx + #,(syntax-srcloc ctx))) + p.name + '#,ctx + #f + #,(syntax-srcloc ctx))))])) ;; Performs one step of deforestation rewrite. Should be used as ;; many times as needed - until it returns the source syntax @@ -246,7 +224,7 @@ (yield l (cons (+ l s) (cdr state)))] [else (done)]))) - (define (range->cstream-prepare next) + (define-inline (range->cstream-prepare next) (case-lambda [(h) (next (list 0 h 1))] [(l h) (next (list l h 1))] From 7bad400f1c715831b935af3fdf075eeb9b842256 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 24 Nov 2023 20:56:17 +0100 Subject: [PATCH 255/338] fusable-stream-producer: limit the number of arguments to range to 1 to 3 --- qi-lib/flow/core/deforest.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 43fb19dec..e3621a2ae 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -40,7 +40,7 @@ (pattern (~and (~or (esc (#%host-expression (~literal range))) (#%partial-application ((#%host-expression (~literal range)) - (#%host-expression arg) ...))) + (~seq (~between (#%host-expression arg) 1 3) ...)))) stx) #:do [(define chirality (syntax-property #'stx 'chirality)) (define num-args (if (attribute arg) From 5c85b2d1473c060001998e537a8237a4fdff4822 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 21 Nov 2023 19:04:18 -0800 Subject: [PATCH 256/338] move a simplification from the code generation step to normalization --- qi-lib/flow/core/compiler.rkt | 5 +---- qi-lib/flow/core/normalize.rkt | 2 ++ 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 31a2a94c7..dd3a1f056 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -551,7 +551,4 @@ the DSL. #'(curry natex prarg-pre ...)] [((~datum #%blanket-template) (natex (~datum __) prarg-post ...+)) - #'(curryr natex prarg-post ...)] - ;; TODO: this should be a compiler optimization - [((~datum #%blanket-template) (natex (~datum __))) - #'natex]))) + #'(curryr natex prarg-post ...)]))) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index 83c6584fe..f55fbcc27 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -59,5 +59,7 @@ #'(thread _0 ... _1 ...)] [((~datum thread) _0 ... (~datum _) _1 ...) #'(thread _0 ... _1 ...)] + [((~datum #%blanket-template) (hex (~datum __))) + #'hex] ;; return syntax unchanged if there are no applicable normalizations [_ stx]))) From c4a49953041e479c11faf120949fb5c0bf8afb23 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 21 Nov 2023 19:12:31 -0800 Subject: [PATCH 257/338] Simplify deforestation tests to high level assertions This doesn't check that expressions are deforested _correctly_ so in that respect it is worse than before, but it is in one respect more useful and that is that it's possible to assert that deforestation is _not_ happening without needing to know the exact expected target expression. If deforestation is not correctly done, we could expect that either the regular unit tests or the benchmarks would reveal that. --- qi-test/tests/compiler.rkt | 69 ++++++++++++-------------------------- 1 file changed, 22 insertions(+), 47 deletions(-) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 2ab721eb1..d394a4a1f 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -8,7 +8,8 @@ make-right-chiral) rackunit rackunit/text-ui - (only-in math sqr)) + (only-in math sqr) + racket/string) (define-syntax-rule (test-normalize a b msg) (check-equal? (syntax->datum @@ -17,6 +18,10 @@ (normalize-pass b)) msg)) +(define (deforested? exp) + (string-contains? (format "~a" exp) "cstream")) + + (define tests (test-suite "compiler tests" @@ -30,25 +35,19 @@ (#%partial-application ((#%host-expression map) (#%host-expression sqr))))))]) - (check-equal? (syntax->datum - (deforest-rewrite - #`(thread #,@stx))) - '(thread - (esc - (λ args - ((cstream-next->list (inline-compose1 (map-cstream-next sqr) (filter-cstream-next odd?) list->cstream-next)) - (apply identity args))))) - "deforest filter")) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforest filter")) (let ([stx (make-right-chiral #'(#%partial-application ((#%host-expression map) (#%host-expression sqr))))]) ;; note this tests the rule in isolation; with normalization this would never be necessary - (check-equal? (syntax->datum - (deforest-rewrite - #`(thread #,stx))) - '(thread (#%partial-application ((#%host-expression map) (#%host-expression sqr)))) - "does not deforest map in the head position")) + (check-false (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,stx)))) + "does not deforest map in the head position")) ;; (~>> values (filter odd?) (map sqr) values) (let ([stx (map make-right-chiral (syntax->list @@ -60,23 +59,10 @@ ((#%host-expression map) (#%host-expression sqr))) values)))]) - (check-equal? (syntax->datum - (deforest-rewrite - #`(thread #,@stx))) - '(thread - values - (esc - (λ args - ((cstream-next->list - (inline-compose1 - (map-cstream-next - sqr) - (filter-cstream-next - odd?) - list->cstream-next)) - (apply identity args)))) - values) - "deforestation in arbitrary positions")) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforestation in arbitrary positions")) (let ([stx (map make-right-chiral (syntax->list #'((#%partial-application @@ -86,21 +72,10 @@ ((#%host-expression foldl) (#%host-expression string-append) (#%host-expression "I"))))))]) - (check-equal? (syntax->datum - (deforest-rewrite - #`(thread #,@stx))) - '(thread - (esc - (λ args - ((foldl-cstream-next - string-append - "I" - (inline-compose1 - (filter-cstream-next - string-upcase) - list->cstream-next)) - (apply identity args))))) - "deforestation in arbitrary positions"))) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforestation in arbitrary positions"))) (test-suite "normalization" (test-normalize #'(thread From 1b0c6182e334e496153d24a53497118bcffbfe85 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 25 Nov 2023 16:38:44 -0800 Subject: [PATCH 258/338] Handle a simplified host expression in the compiler This fixes the recently introduced build failure, where an expression that had been reduced in the course of normalization to a simple host expression wasn't being recognized as a core form in the Qi compiler. --- qi-lib/flow/core/compiler.rkt | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index dd3a1f056..ea6c6f542 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -271,7 +271,16 @@ ;; and need to handle the keyword arguments differently ;; from the positional arguments. #'(lambda args - ((kw-helper natex args) prarg ...)))])) + ((kw-helper natex args) prarg ...)))] + ;; if in the course of optimization we ever end up with a fully + ;; simplified host expression, the compiler would a priori reject it as + ;; not being a core Qi expression. So we add this extra rule here + ;; to simply pass this expression through. + ;; TODO: should `#%host-expression` be formally declared as being part + ;; of the core language by including it in the syntax-spec grammar + ;; in extended/expander.rkt? + [((~datum #%host-expression) hex) + this-syntax])) ;; The form-specific parsers, which are delegated to from ;; the qi0->racket macro: From 9857e65caa8b0c60ada006f4f9516fa1d0bfd3aa Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Nov 2023 17:33:48 -0800 Subject: [PATCH 259/338] failing compiler tests for deforesting templates --- qi-test/tests/compiler.rkt | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index d394a4a1f..0cc5af315 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -75,7 +75,31 @@ (check-true (deforested? (syntax->datum (deforest-rewrite #`(thread #,@stx)))) - "deforestation in arbitrary positions"))) + "deforestation in arbitrary positions")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression filter) + (#%host-expression odd?) + _)) + (#%fine-template + ((#%host-expression map) + (#%host-expression sqr) + _))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforest fine-grained template forms")) + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforest blanket template forms"))) (test-suite "normalization" (test-normalize #'(thread From d50e5e9c99c5478a03a242f9c02047a4d8769ea1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Nov 2023 20:22:14 -0800 Subject: [PATCH 260/338] Rewrite partial application to a use of a blanket template This simplifies the core language by eliminating the need for `#%partial-application` as a core form. It also allows us to deal with the concept of chirality only in the expander and largely deal only in terms of explicit templates in the compiler. The only place where we still need chirality in the compiler is in `clos`, which is a way to pre-supply arguments at runtime rather than at compile time. There's no obvious syntactic way to designate which side the pre-supplied arguments should be placed on here. We could introduce `clos` and `closr` core forms to differentiate these cases but that doesn't really simplify it (although it would be another step in the direction of making our core language explicit and not reliant on syntax properties). --- qi-lib/flow/core/compiler.rkt | 23 ++++----------------- qi-lib/flow/extended/expander.rkt | 34 ++++++++++++++++++++++--------- qi-lib/flow/extended/syntax.rkt | 8 +++++++- 3 files changed, 35 insertions(+), 30 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index ea6c6f542..9289a890f 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -255,23 +255,6 @@ [((~datum #%fine-template) (prarg-pre ... (~datum _) prarg-post ...)) #'(fancy:#%app prarg-pre ... _ prarg-post ...)] - ;; Pre-supplied arguments without a template - [((~datum #%partial-application) (natex prarg ...+)) - ;; we use currying instead of templates when a template hasn't - ;; explicitly been indicated since in such cases, we cannot - ;; always infer the appropriate arity for a template (e.g. it - ;; may change under composition within the form), while a - ;; curried function will accept any number of arguments - #:do [(define chirality (syntax-property this-syntax 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(lambda args - (apply natex prarg ... args)) - ;; TODO: keyword arguments don't work for the left-chiral case - ;; since we can't just blanket place the pre-supplied args - ;; and need to handle the keyword arguments differently - ;; from the positional arguments. - #'(lambda args - ((kw-helper natex args) prarg ...)))] ;; if in the course of optimization we ever end up with a fully ;; simplified host expression, the compiler would a priori reject it as ;; not being a core Qi expression. So we add this extra rule here @@ -557,7 +540,9 @@ the DSL. prarg-post ...) prarg-pre ...)] [((~datum #%blanket-template) (natex prarg-pre ...+ (~datum __))) - #'(curry natex prarg-pre ...)] + #'(lambda args + (apply natex prarg-pre ... args))] [((~datum #%blanket-template) (natex (~datum __) prarg-post ...+)) - #'(curryr natex prarg-post ...)]))) + #'(lambda args + ((kw-helper natex args) prarg-post ...))]))) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index a22608df1..0c152f195 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -168,23 +168,37 @@ ;; by wrapping them with #%-prefixed forms, similar to Racket's ;; approach to a similiar case - "interposition points." These ;; new forms can then be treated as core forms in the compiler. + ;; + ;; Be careful with these tagging rules, though -- if they are too + ;; lax in their match criteria they may produce infinite code + ;; unless their output is matched prior to reaching the tagging rule. + ;; So core forms expected to be produced by these tagging rules + ;; should generally occur before the tagging rule + (#%blanket-template (arg:arg-stx ...)) (~> f:blanket-template-form #'(#%blanket-template f)) - (#%blanket-template (arg:arg-stx ...)) - + (#%fine-template (arg:arg-stx ...)) (~> f:fine-template-form #'(#%fine-template f)) - (#%fine-template (arg:arg-stx ...)) - - ;; The core rule must come before the tagging rule here since - ;; the former as a production of the latter would still match - ;; the latter (i.e. it is still a parenthesized expression), - ;; which would lead to infinite code generation. - (#%partial-application (arg:arg-stx ...)) + ;; When there is a partial application where a template hasn't + ;; explicitly been indicated, we rewrite it to an equivalent use + ;; of a blanket template. + ;; We use a blanket rather than fine template since in such cases, + ;; we cannot always infer the appropriate arity for a template + ;; (e.g. it may change under composition within the form), while a + ;; blanket template will accept any number of arguments (~> f:partial-application-form - #'(#%partial-application f)) + #:do [(define chirality (syntax-property this-syntax 'chirality))] + (if (and chirality (eq? chirality 'right)) + (datum->syntax this-syntax + (append (syntax->list this-syntax) + (list '__))) + (datum->syntax this-syntax + (let ([stx-list (syntax->list this-syntax)]) + (cons (car stx-list) + (cons '__ (cdr stx-list))))))) ;; literally indicated function identifier ;; ;; functions defined in the Qi binding space take precedence over diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index 288c9ca7e..7ac643dcb 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -31,6 +31,12 @@ onex:clause #:with parsed #'onex)) +(define-syntax-class pre-supplied-argument + (pattern + (~not + (~or (~datum _) + (~datum __))))) + (define (make-right-chiral stx) (syntax-property stx 'chirality 'right)) @@ -55,7 +61,7 @@ (define-syntax-class partial-application-form ;; "prarg" = "pre-supplied argument" (pattern - (natex prarg ...+))) + (natex prarg:pre-supplied-argument ...+))) (define-syntax-class any-stx (pattern _)) From 342fe96ae51eafa30ae7b8d83972f629edf36e52 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Nov 2023 20:35:58 -0800 Subject: [PATCH 261/338] A test to validate pre-supplying keyword arguments A comment in the code indicated that this wasn't supported for left chiral forms, but that seems to have been outdated, as this test proves. --- qi-test/tests/flow.rkt | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 7535a54e5..58ad17eff 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -449,6 +449,10 @@ "p" "q") "pabqab" "threading without template") + (check-equal? ((☯ (~> (sort 3 1 2 #:key sqr))) + <) + (list 1 4 9) + "pre-supplied keyword arguments with left chirality") (check-equal? ((☯ (thread add1 (* 2) number->string @@ -482,10 +486,10 @@ "p" "q") "abpq" "right-threading without template") - (check-equal? ((☯ (~>> △ (sort < #:key identity))) + (check-equal? ((☯ (~>> △ (sort < #:key sqr))) (list 2 1 3)) - (list 1 2 3) - "right-threading with keyword arg pre-supplied") + (list 1 4 9) + "pre-supplied keyword arguments with right chirality") (check-equal? ((☯ (~>> (sort <))) #:key identity 2 1 3) (list 1 2 3) From a53dca3a45b54eb4a7a7435521077d6a12148a82 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Nov 2023 20:39:09 -0800 Subject: [PATCH 262/338] remove unused import --- qi-lib/flow/extended/forms.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 0ffe9db5f..16c60f612 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -10,7 +10,6 @@ [effect ε]))) (require (for-syntax racket/base - (only-in racket/list make-list) "syntax.rkt" "../aux-syntax.rkt") syntax/parse/define From 8c4bf63cd85ecabaae3b1f26289c89d4645fac4e Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Tue, 28 Nov 2023 23:09:05 -0800 Subject: [PATCH 263/338] match blanket templates in transformers and consumers --- qi-lib/flow/core/deforest.rkt | 74 +++++++++++++++------------------ qi-test/tests/compiler.rkt | 77 ++++++++++++++++------------------- 2 files changed, 66 insertions(+), 85 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index e3621a2ae..52129588b 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -34,11 +34,11 @@ ;; no syntax class producer is matched. (define-syntax-class fusable-stream-producer #:attributes (next prepare contract name curry) - #:datum-literals (#%host-expression #%partial-application esc) + #:datum-literals (#%host-expression #%blanket-template esc) ;; Explicit range producers. We have to conver all four variants ;; as they all come with different runtime contracts! (pattern (~and (~or (esc (#%host-expression (~literal range))) - (#%partial-application + (#%blanket-template ((#%host-expression (~literal range)) (~seq (~between (#%host-expression arg) 1 3) ...)))) stx) @@ -72,57 +72,47 @@ ;; `map` cannot be in this class. (define-syntax-class fusable-stream-transformer0 #:attributes (f next) - #:datum-literals (#%host-expression #%partial-application) - (pattern (~and (#%partial-application - ((#%host-expression (~literal filter)) - (#%host-expression f))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr next #'filter-cstream-next)) + #:datum-literals (#%host-expression #%blanket-template __) + (pattern (#%blanket-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + __)) + #:attr next #'filter-cstream-next)) ;; All implemented stream transformers - within the stream, only ;; single value is being passed and therefore procedures like `map` ;; can (and should) be matched. (define-syntax-class fusable-stream-transformer #:attributes (f next) - #:datum-literals (#%host-expression #%partial-application) - (pattern (~and (#%partial-application - ((#%host-expression (~literal map)) - (#%host-expression f))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr next #'map-cstream-next) - (pattern (~and (#%partial-application - ((#%host-expression (~literal filter)) - (#%host-expression f))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr next #'filter-cstream-next)) + #:datum-literals (#%host-expression #%blanket-template __) + (pattern (#%blanket-template + ((#%host-expression (~literal map)) + (#%host-expression f) + __)) + #:attr next #'map-cstream-next) + (pattern (#%blanket-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + __)) + #:attr next #'filter-cstream-next)) ;; Terminates the fused sequence (consumes the stream) and produces ;; an actual result value. (define-syntax-class fusable-stream-consumer #:attributes (end) - #:datum-literals (#%host-expression #%partial-application) - (pattern (~and (#%partial-application - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr end #'(foldr-cstream-next op init)) - (pattern (~and (#%partial-application - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (and chirality (eq? chirality 'right)) - #:attr end #'(foldl-cstream-next op init)) + #:datum-literals (#%host-expression #%blanket-template __) + (pattern (#%blanket-template + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init) + __)) + #:attr end #'(foldr-cstream-next op init)) + (pattern (#%blanket-template + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init) + __)) + #:attr end #'(foldl-cstream-next op init)) (pattern (~literal cstream->list) #:attr end #'(cstream-next->list)) (pattern (esc (#%host-expression (~literal car))) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 0cc5af315..e000af1f0 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -28,50 +28,53 @@ (test-suite "deforestation" - (let ([stx (map make-right-chiral - (syntax->list #'((#%partial-application - ((#%host-expression filter) - (#%host-expression odd?))) - (#%partial-application - ((#%host-expression map) - (#%host-expression sqr))))))]) + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __))))]) (check-true (deforested? (syntax->datum (deforest-rewrite #`(thread #,@stx)))) "deforest filter")) - (let ([stx (make-right-chiral - #'(#%partial-application - ((#%host-expression map) - (#%host-expression sqr))))]) + (let ([stx #'(#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __))]) ;; note this tests the rule in isolation; with normalization this would never be necessary (check-false (deforested? (syntax->datum (deforest-rewrite #`(thread #,stx)))) "does not deforest map in the head position")) ;; (~>> values (filter odd?) (map sqr) values) - (let ([stx (map make-right-chiral - (syntax->list - #'(values - (#%partial-application - ((#%host-expression filter) - (#%host-expression odd?))) - (#%partial-application - ((#%host-expression map) - (#%host-expression sqr))) - values)))]) + (let ([stx (syntax->list + #'(values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)) + values))]) (check-true (deforested? (syntax->datum (deforest-rewrite #`(thread #,@stx)))) "deforestation in arbitrary positions")) - (let ([stx (map make-right-chiral - (syntax->list - #'((#%partial-application - ((#%host-expression filter) - (#%host-expression string-upcase))) - (#%partial-application - ((#%host-expression foldl) - (#%host-expression string-append) - (#%host-expression "I"))))))]) + (let ([stx (syntax->list + #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __))))]) (check-true (deforested? (syntax->datum (deforest-rewrite #`(thread #,@stx)))) @@ -87,19 +90,7 @@ (check-true (deforested? (syntax->datum (deforest-rewrite #`(thread #,@stx)))) - "deforest fine-grained template forms")) - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __))))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforest blanket template forms"))) + "deforest fine-grained template forms"))) (test-suite "normalization" (test-normalize #'(thread From 71c31e698ab9d02cc290b2080e070367ce6ce2b0 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 01:37:42 -0800 Subject: [PATCH 264/338] add a failing test to show an issue with bindings and currying --- qi-lib/flow/core/compiler.rkt | 5 +++++ qi-test/tests/flow.rkt | 16 ++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 9289a890f..f0092c39c 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -534,6 +534,11 @@ the DSL. (define (blanket-template-form-parser stx) (syntax-parse stx ;; "prarg" = "pre-supplied argument" + ;; Note: use of currying here doesn't play well with bindings + ;; because curry / curryr immediately evaluate their arguments + ;; and resolve any references to bindings at compile time, + ;; whereas a lambda delays evaluation until runtime when the + ;; reference is actually resolvable. [((~datum #%blanket-template) (natex prarg-pre ...+ (~datum __) prarg-post ...+)) #'(curry (curryr natex diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 58ad17eff..ea76fde0e 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -354,6 +354,22 @@ (check-equal? ((☯ (~> (as v) (+ v))) 3) 3 "binds a single value") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 _ v))) 3) + 9 + "reference in a fine template") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 v))) 3) + 9 + "reference in a left-chiral partial application") + (check-equal? ((☯ (~>> (-< (as v) + _) (+ 3 v))) 3) + 9 + "reference in a right-chiral partial application") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 __ v))) 3) + 9 + "reference in a blanket template") (check-false ((☯ (~> (as v) live?)) 3) "binding does not propagate the value") (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) From 0cb4993610506a4104a74e12d0cb6cc032436e8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 25 Nov 2023 20:37:43 +0100 Subject: [PATCH 265/338] Add support for #%fine-template in deforested consumers. --- qi-lib/flow/core/deforest.rkt | 39 ++++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 52129588b..e56fa8cf5 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -100,6 +100,7 @@ ;; an actual result value. (define-syntax-class fusable-stream-consumer #:attributes (end) +<<<<<<< HEAD #:datum-literals (#%host-expression #%blanket-template __) (pattern (#%blanket-template ((#%host-expression (~literal foldr)) @@ -113,9 +114,45 @@ (#%host-expression init) __)) #:attr end #'(foldl-cstream-next op init)) +======= + #:datum-literals (#%host-expression #%partial-application #%fine-template) + (pattern (~and (~or (#%partial-application + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init))) + (~and (#%fine-template + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init) + _)) + with-fine-template)) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (or (attribute with-fine-template) + (and chirality (eq? chirality 'right))) + #:attr end #'(foldr-cstream-next op init)) + (pattern (~and (~or (#%partial-application + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init))) + (~and (#%fine-template + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init) + _)) + with-fine-template)) + stx) + #:do [(define chirality (syntax-property #'stx 'chirality))] + #:when (or (attribute with-fine-template) + (and chirality (eq? chirality 'right))) + #:attr end #'(foldl-cstream-next op init)) +>>>>>>> 2e8206c (Add support for #%fine-template in deforested consumers.) (pattern (~literal cstream->list) #:attr end #'(cstream-next->list)) - (pattern (esc (#%host-expression (~literal car))) + (pattern (~or (esc (#%host-expression (~literal car))) + (#%fine-template + ((#%host-expression (~literal car)) + _))) #:attr end #'(car-cstream-next))) ;; Used only in deforest-rewrite to properly recognize the end of From 38d48d677eb220a832f594ec2eb6316453df1598 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 25 Nov 2023 20:39:01 +0100 Subject: [PATCH 266/338] Add missing literal. --- qi-lib/flow/core/deforest.rkt | 2 -- 1 file changed, 2 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index e56fa8cf5..15b89addc 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -100,7 +100,6 @@ ;; an actual result value. (define-syntax-class fusable-stream-consumer #:attributes (end) -<<<<<<< HEAD #:datum-literals (#%host-expression #%blanket-template __) (pattern (#%blanket-template ((#%host-expression (~literal foldr)) @@ -114,7 +113,6 @@ (#%host-expression init) __)) #:attr end #'(foldl-cstream-next op init)) -======= #:datum-literals (#%host-expression #%partial-application #%fine-template) (pattern (~and (~or (#%partial-application ((#%host-expression (~literal foldr)) From 8c95d628c3bc989ea4ec4f64592429f4b477becc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 25 Nov 2023 21:05:21 +0100 Subject: [PATCH 267/338] Matching _ as ~datum. --- qi-lib/flow/core/deforest.rkt | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 15b89addc..54388319e 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -113,7 +113,6 @@ (#%host-expression init) __)) #:attr end #'(foldl-cstream-next op init)) - #:datum-literals (#%host-expression #%partial-application #%fine-template) (pattern (~and (~or (#%partial-application ((#%host-expression (~literal foldr)) (#%host-expression op) @@ -122,7 +121,7 @@ ((#%host-expression (~literal foldr)) (#%host-expression op) (#%host-expression init) - _)) + (~datum _))) with-fine-template)) stx) #:do [(define chirality (syntax-property #'stx 'chirality))] @@ -137,20 +136,19 @@ ((#%host-expression (~literal foldl)) (#%host-expression op) (#%host-expression init) - _)) + (~datum _))) with-fine-template)) stx) #:do [(define chirality (syntax-property #'stx 'chirality))] #:when (or (attribute with-fine-template) (and chirality (eq? chirality 'right))) #:attr end #'(foldl-cstream-next op init)) ->>>>>>> 2e8206c (Add support for #%fine-template in deforested consumers.) (pattern (~literal cstream->list) #:attr end #'(cstream-next->list)) (pattern (~or (esc (#%host-expression (~literal car))) (#%fine-template ((#%host-expression (~literal car)) - _))) + (~datum _)))) #:attr end #'(car-cstream-next))) ;; Used only in deforest-rewrite to properly recognize the end of From 1d7cd1d963546424d5a44c6219bae641df0d9007 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 26 Nov 2023 20:40:05 +0100 Subject: [PATCH 268/338] deforestation error reporting: implement partial de-expander for flows --- qi-lib/flow/core/deforest.rkt | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 54388319e..18c46c558 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -28,6 +28,26 @@ (begin-for-syntax + ;; Partially reconstructs original flow expressions. The chirality + ;; is lost and the form is already normalized at this point though! + (define (prettify-flow-syntax stx) + (syntax-parse stx + #:datum-literals (#%partial-application #%host-expression) + (((~literal thread) + expr ...) + #`(~> #,@(prettify-flow-syntax #'(expr ...)))) + ((#%partial-application + (expr ...)) + (for/list ((ex (in-list (syntax->list #'(expr ...))))) + (prettify-flow-syntax ex))) + ((#%host-expression expr) #'expr) + (((~literal esc) expr) (prettify-flow-syntax #'expr)) + ((expr ...) + (for/list ((ex (in-list (syntax->list #'(expr ...))))) + (prettify-flow-syntax ex))) + (expr #'expr) + )) + ;; Used for producing the stream from particular ;; expressions. Implicit producer is list->cstream-next and it is ;; not created by using this class but rather explicitly used when @@ -176,10 +196,10 @@ (#,@#'c.end (inline-compose1 [t.next t.f] ... p.next) - '#,ctx + '#,(prettify-flow-syntax ctx) #,(syntax-srcloc ctx))) p.name - '#,ctx + '#,(prettify-flow-syntax ctx) #f #,(syntax-srcloc ctx))))])) From 368380cec770cf38752bab9facf434978a9ecb35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Mon, 27 Nov 2023 19:10:08 +0100 Subject: [PATCH 269/338] Currying for #%fine-template deforested producers. --- qi-lib/flow/core/deforest.rkt | 40 ++++++++++++++++++++++++++++++----- 1 file changed, 35 insertions(+), 5 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 18c46c558..1aebbc876 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -32,7 +32,7 @@ ;; is lost and the form is already normalized at this point though! (define (prettify-flow-syntax stx) (syntax-parse stx - #:datum-literals (#%partial-application #%host-expression) + #:datum-literals (#%partial-application #%host-expression esc) (((~literal thread) expr ...) #`(~> #,@(prettify-flow-syntax #'(expr ...)))) @@ -41,12 +41,34 @@ (for/list ((ex (in-list (syntax->list #'(expr ...))))) (prettify-flow-syntax ex))) ((#%host-expression expr) #'expr) - (((~literal esc) expr) (prettify-flow-syntax #'expr)) + ((esc expr) (prettify-flow-syntax #'expr)) ((expr ...) (for/list ((ex (in-list (syntax->list #'(expr ...))))) (prettify-flow-syntax ex))) - (expr #'expr) - )) + (expr #'expr))) + + ;; Special "curry"ing for #%fine-templates. All #%host-expressions + ;; are passed as they are and all (~datum _) are replaced by wrapper + ;; lambda arguments. + (define (make-fine-curry argstx) + (define argstxlst (syntax->list argstx)) + (define temporaries (generate-temporaries argstxlst)) + (define-values (allargs tmpargs0) + (for/lists (a b) + ((tmp (in-list temporaries)) + (arg (in-list argstxlst))) + (syntax-parse arg + #:datum-literals (#%host-expression) + ((#%host-expression ex) + (values #'ex + #f)) + ((~datum _) (values tmp tmp))))) + (define tmpargs (filter (λ (v) v) tmpargs0)) + (with-syntax (((carg ...) tmpargs) + ((aarg ...) allargs)) + #'(λ (proc) + (λ (carg ...) + (proc aarg ...))))) ;; Used for producing the stream from particular ;; expressions. Implicit producer is list->cstream-next and it is @@ -76,7 +98,15 @@ #:attr curry (case num-args ((0) #'(λ (v) v)) ((1 2) #'(λ (v) (vindaloo v arg ...))) - ((3) #'(λ (v) (v arg ...))))) + ((3) #'(λ (v) (λ () (v arg ...)))))) + (pattern (#%fine-template + ((#%host-expression (~literal range)) + arg ...)) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-prepare + #:attr contract #'(->* (real?) (real? real?) any) + #:attr name #''range + #:attr curry (make-fine-curry #'(arg ...))) ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) From 9478c1be35095b54a788dd7435c9eb69dd02b104 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Wed, 29 Nov 2023 20:50:01 +0100 Subject: [PATCH 270/338] Work on simplifying deforestation pass. --- qi-lib/flow/core/deforest.rkt | 20 +++----------------- 1 file changed, 3 insertions(+), 17 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 1aebbc876..b3130deb0 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -76,29 +76,15 @@ ;; no syntax class producer is matched. (define-syntax-class fusable-stream-producer #:attributes (next prepare contract name curry) - #:datum-literals (#%host-expression #%blanket-template esc) + #:datum-literals (#%host-expression #%blanket-template #%fine-template esc) ;; Explicit range producers. We have to conver all four variants ;; as they all come with different runtime contracts! - (pattern (~and (~or (esc (#%host-expression (~literal range))) - (#%blanket-template - ((#%host-expression (~literal range)) - (~seq (~between (#%host-expression arg) 1 3) ...)))) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality)) - (define num-args (if (attribute arg) - (length (syntax->list #'(arg ...))) - 0))] - #:with vindaloo (if (and chirality (eq? chirality 'right)) - #'curry - #'curryr) + (pattern (esc (#%host-expression (~literal range))) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare #:attr contract #'(->* (real?) (real? real?) any) #:attr name #''range - #:attr curry (case num-args - ((0) #'(λ (v) v)) - ((1 2) #'(λ (v) (vindaloo v arg ...))) - ((3) #'(λ (v) (λ () (v arg ...)))))) + #:attr curry #'(λ (v) v)) (pattern (#%fine-template ((#%host-expression (~literal range)) arg ...)) From 4f3a2177f7576c1554468c534e083e9e9cd4fdc0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Wed, 29 Nov 2023 21:52:33 +0100 Subject: [PATCH 271/338] deforestation: simplify consumer syntax patterns --- qi-lib/flow/core/deforest.rkt | 97 ++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 40 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index b3130deb0..0152b372f 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -53,30 +53,53 @@ (define (make-fine-curry argstx) (define argstxlst (syntax->list argstx)) (define temporaries (generate-temporaries argstxlst)) - (define-values (allargs tmpargs0) - (for/lists (a b) - ((tmp (in-list temporaries)) - (arg (in-list argstxlst))) + (define-values (allargs tmpargs) + (for/fold ((all '()) + (tmps '()) + #:result (values (reverse all) + (reverse tmps))) + ((tmp (in-list temporaries)) + (arg (in-list argstxlst))) (syntax-parse arg #:datum-literals (#%host-expression) ((#%host-expression ex) - (values #'ex - #f)) - ((~datum _) (values tmp tmp))))) - (define tmpargs (filter (λ (v) v) tmpargs0)) + (values (cons #'ex all) + tmps)) + ((~datum _) + (values (cons tmp all) + (cons tmp tmps)))))) (with-syntax (((carg ...) tmpargs) ((aarg ...) allargs)) #'(λ (proc) (λ (carg ...) (proc aarg ...))))) + ;; Special curry for #%blanket-template. Raises syntax error if + ;; there are too many arguments. If the number of arguments is + ;; exactly the maximum, wraps into lambda without any arguments. If + ;; less than maximum, curries it from both left and right. + (define (make-blanket-curry prestx poststx maxargs) + (define prelst (syntax->list prestx)) + (define postlst (syntax->list poststx)) + (define numargs (+ (length prelst) (length postlst))) + (with-syntax (((pre-arg ...) prelst) + ((post-arg ...) postlst)) + (cond ((> numargs maxargs) + (raise-syntax-error "too many arguments")) + ((= numargs maxargs) + #'(λ (v) + (v pre-arg ... post-arg ...))) + (else + #'(λ (v) + (curryr (curry v pre-arg ...) post-arg ...)))))) + ;; Used for producing the stream from particular ;; expressions. Implicit producer is list->cstream-next and it is ;; not created by using this class but rather explicitly used when ;; no syntax class producer is matched. (define-syntax-class fusable-stream-producer #:attributes (next prepare contract name curry) - #:datum-literals (#%host-expression #%blanket-template #%fine-template esc) + #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) ;; Explicit range producers. We have to conver all four variants ;; as they all come with different runtime contracts! (pattern (esc (#%host-expression (~literal range))) @@ -93,6 +116,18 @@ #:attr contract #'(->* (real?) (real? real?) any) #:attr name #''range #:attr curry (make-fine-curry #'(arg ...))) + (pattern (#%blanket-template + ((#%host-expression (~literal range)) + (#%host-expression pre-arg) ... + __ + (#%host-expression post-arg) ...)) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-prepare + #:attr name #''range + #:attr curry (make-blanket-curry #'(pre-arg ...) + #'(post-arg ...) + 3) + #:attr contract #'(->* (real?) (real? real?) any)) ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) @@ -136,48 +171,30 @@ ;; an actual result value. (define-syntax-class fusable-stream-consumer #:attributes (end) - #:datum-literals (#%host-expression #%blanket-template __) + #:datum-literals (#%host-expression #%blanket-template __ #%fine-template esc) (pattern (#%blanket-template ((#%host-expression (~literal foldr)) (#%host-expression op) (#%host-expression init) __)) - #:attr end #'(foldr-cstream-next op init)) + #:attr end #'(foldr-cstream-next op init)) (pattern (#%blanket-template ((#%host-expression (~literal foldl)) (#%host-expression op) (#%host-expression init) __)) - #:attr end #'(foldl-cstream-next op init)) - (pattern (~and (~or (#%partial-application - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init))) - (~and (#%fine-template - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init) - (~datum _))) - with-fine-template)) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (or (attribute with-fine-template) - (and chirality (eq? chirality 'right))) + #:attr end #'(foldl-cstream-next op init)) + (pattern (#%fine-template + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init) + (~datum _))) #:attr end #'(foldr-cstream-next op init)) - (pattern (~and (~or (#%partial-application - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init))) - (~and (#%fine-template - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init) - (~datum _))) - with-fine-template)) - stx) - #:do [(define chirality (syntax-property #'stx 'chirality))] - #:when (or (attribute with-fine-template) - (and chirality (eq? chirality 'right))) + (pattern (#%fine-template + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init) + (~datum _))) #:attr end #'(foldl-cstream-next op init)) (pattern (~literal cstream->list) #:attr end #'(cstream-next->list)) From 5d87af2b902cc7d6d022b6cda90b9cfc8abe58a3 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 12:54:32 -0800 Subject: [PATCH 272/338] add a few compiler tests for deforestation --- qi-test/tests/compiler.rkt | 51 +++++++++++++++++++++++++++++++++++++- 1 file changed, 50 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index e000af1f0..7b6efc206 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -26,8 +26,19 @@ (test-suite "compiler tests" + ;; Note that these test deforestation in isolation + ;; without necessarily taking normalization (a preceding + ;; step in compilation) into account (test-suite "deforestation" + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-false (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "does not deforest single stream component in isolation")) (let ([stx (syntax->list #'((#%blanket-template ((#%host-expression filter) (#%host-expression odd?) @@ -40,11 +51,46 @@ (deforest-rewrite #`(thread #,@stx)))) "deforest filter")) + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression range) + (#%host-expression 10) + __)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforest range")) + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (esc (#%host-expression car))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforest car")) + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "deforest range")) (let ([stx #'(#%blanket-template ((#%host-expression map) (#%host-expression sqr) + __) + ((#%host-expression filter) + (#%host-expression odd?) __))]) - ;; note this tests the rule in isolation; with normalization this would never be necessary (check-false (deforested? (syntax->datum (deforest-rewrite #`(thread #,stx)))) @@ -106,6 +152,9 @@ (test-normalize #'(thread sqr) #'sqr "trivial threading is collapsed")) + (test-suite + "compilation sequences" + null) (test-suite "fixed point" null))) From 8c6e5b3292ef28b80c4f3b8b6e54799ab0b7900e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Wed, 29 Nov 2023 22:24:14 +0100 Subject: [PATCH 273/338] deforestation: fix blanket template with all arguments, expand transformer patterns --- qi-lib/flow/core/deforest.rkt | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 0152b372f..570472a37 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -88,10 +88,10 @@ (raise-syntax-error "too many arguments")) ((= numargs maxargs) #'(λ (v) - (v pre-arg ... post-arg ...))) + (λ () + (v pre-arg ... post-arg ...)))) (else - #'(λ (v) - (curryr (curry v pre-arg ...) post-arg ...)))))) + #'(λ (v) (curry (curryr v post-arg ...) pre-arg ...)))))) ;; Used for producing the stream from particular ;; expressions. Implicit producer is list->cstream-next and it is @@ -156,15 +156,23 @@ (define-syntax-class fusable-stream-transformer #:attributes (f next) #:datum-literals (#%host-expression #%blanket-template __) - (pattern (#%blanket-template - ((#%host-expression (~literal map)) - (#%host-expression f) - __)) + (pattern (~or (#%blanket-template + ((#%host-expression (~literal map)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~literal map)) + (#%host-expression f) + _))) #:attr next #'map-cstream-next) - (pattern (#%blanket-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - __)) + (pattern (~or (#%blanket-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~literal filter)) + (#%host-expression f)) + _)) #:attr next #'filter-cstream-next)) ;; Terminates the fused sequence (consumes the stream) and produces From 19780208aac568477543fd061b08fe77cfb1e66d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 14:58:30 -0800 Subject: [PATCH 274/338] reorganize compiler tests along producer, transformer, etc. --- qi-test/tests/compiler.rkt | 256 ++++++++++++++++++++++--------------- 1 file changed, 153 insertions(+), 103 deletions(-) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 7b6efc206..6e34c37e5 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -31,112 +31,162 @@ ;; step in compilation) into account (test-suite "deforestation" - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) - (check-false (deforested? (syntax->datum + (test-suite + "general" + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-false (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "does not deforest single stream component in isolation")) + (let ([stx #'(#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __) + ((#%host-expression filter) + (#%host-expression odd?) + __))]) + (check-false (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,stx)))) + "does not deforest map in the head position")) + ;; (~>> values (filter odd?) (map sqr) values) + (let ([stx (syntax->list + #'(values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)) + values))]) + (check-true (deforested? (syntax->datum (deforest-rewrite #`(thread #,@stx)))) - "does not deforest single stream component in isolation")) - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __))))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforest filter")) - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression range) - (#%host-expression 10) - __)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforest range")) - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (esc (#%host-expression car))))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforest car")) - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __))))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforest range")) - (let ([stx #'(#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __) - ((#%host-expression filter) - (#%host-expression odd?) - __))]) - (check-false (deforested? (syntax->datum + "deforestation in arbitrary positions")) + (let ([stx (syntax->list + #'(values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __)) + values))]) + (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,stx)))) - "does not deforest map in the head position")) - ;; (~>> values (filter odd?) (map sqr) values) - (let ([stx (syntax->list - #'(values - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __)) - values))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforestation in arbitrary positions")) - (let ([stx (syntax->list - #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression string-upcase) - __)) - (#%blanket-template - ((#%host-expression foldl) - (#%host-expression string-append) - (#%host-expression "I") - __))))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforestation in arbitrary positions")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression filter) - (#%host-expression odd?) - _)) - (#%fine-template - ((#%host-expression map) - (#%host-expression sqr) - _))))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - #`(thread #,@stx)))) - "deforest fine-grained template forms"))) + #`(thread #,@stx)))) + "deforestation in arbitrary positions"))) + (test-suite + "transformers" + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "filter")) + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "filter-map (two transformers)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression filter) + (#%host-expression odd?) + _)) + (#%fine-template + ((#%host-expression map) + (#%host-expression sqr) + _))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "fine-grained template forms"))) + (test-suite + "producers" + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression range) + (#%host-expression 10) + __)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "range")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + (#%host-expression 10) + _)) + (#%fine-template + ((#%host-expression filter) + (#%host-expression odd?) + _))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "fine template in range"))) + (test-suite + "consumers" + (let ([stx (syntax->list #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (esc (#%host-expression car))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "car")) + (let ([stx (syntax->list + #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "foldl")) + (let ([stx (syntax->list + #'((#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldr) + (#%host-expression string-append) + (#%host-expression "I") + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "foldr")))) (test-suite "normalization" (test-normalize #'(thread From 097c968b17ed22be112c868241966968f3da9cff Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 15:30:35 -0800 Subject: [PATCH 275/338] combinatorial deforestation tests for producers using templates --- qi-test/tests/compiler.rkt | 252 +++++++++++++++++++++++++++++++++++-- 1 file changed, 244 insertions(+), 8 deletions(-) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 6e34c37e5..59ab63143 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -124,10 +124,7 @@ "fine-grained template forms"))) (test-suite "producers" - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression range) - (#%host-expression 10) - __)) + (let ([stx (syntax->list #'((#%host-expression range) (#%blanket-template ((#%host-expression filter) (#%host-expression odd?) @@ -138,16 +135,255 @@ "range")) (let ([stx (syntax->list #'((#%fine-template ((#%host-expression range) - (#%host-expression 10) _)) - (#%fine-template + (#%blanket-template ((#%host-expression filter) (#%host-expression odd?) - _))))]) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range _)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range _ _)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 _)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range _ 10)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range _ _ _)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range _ _ 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range _ 10 _)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range _ 10 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 _ _)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 _ 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 10 _)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range __)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 __)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range __ 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 10 __)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range __ 10 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 __ 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 10 1 __)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 10 __ 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + #`(thread #,@stx)))) + "(range 0 __ 10 1)")) + (let ([stx (syntax->list #'((#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __))))]) (check-true (deforested? (syntax->datum (deforest-rewrite #`(thread #,@stx)))) - "fine template in range"))) + "(range __ 0 10 1)"))) (test-suite "consumers" (let ([stx (syntax->list #'((#%blanket-template From becec47366b3f0393f797d1967bf90307950b401 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 17:32:52 -0800 Subject: [PATCH 276/338] Simplify compiler tests --- qi-lib/flow/core/compiler.rkt | 7 +- qi-lib/flow/extended/syntax.rkt | 3 +- qi-test/tests/compiler.rkt | 617 +++++++++++++++++--------------- 3 files changed, 332 insertions(+), 295 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index f0092c39c..91f3ca1d7 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -1,7 +1,8 @@ #lang racket/base (provide (for-syntax compile-flow - normalize-pass)) + normalize-pass + fix)) (require (for-syntax racket/base syntax/parse @@ -69,8 +70,8 @@ stx)) (define (optimize-flow stx) - ;; (deforest-pass (normalize-pass stx)) - (deforest-pass (normalize-pass stx)))) + (deforest-pass + (normalize-pass stx)))) ;; Transformation rules for the `as` binding form: ;; diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index 7ac643dcb..a289c89ed 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -6,8 +6,7 @@ blanket-template-form fine-template-form partial-application-form - any-stx - make-right-chiral) + any-stx) (require syntax/parse "../aux-syntax.rkt" diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 59ab63143..020013e62 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -4,12 +4,11 @@ (require (for-template qi/flow/core/deforest qi/flow/core/compiler) - (only-in qi/flow/extended/syntax - make-right-chiral) rackunit rackunit/text-ui (only-in math sqr) - racket/string) + racket/string + (only-in racket/function curryr)) (define-syntax-rule (test-normalize a b msg) (check-equal? (syntax->datum @@ -26,22 +25,32 @@ (test-suite "compiler tests" - ;; Note that these test deforestation in isolation - ;; without necessarily taking normalization (a preceding - ;; step in compilation) into account + (test-suite + "fixed point" + (check-equal? ((fix abs) -1) 1) + (check-equal? ((fix abs) -1) 1) + (let ([integer-div2 (compose floor (curryr / 2))]) + (check-equal? ((fix integer-div2) 10) + 0))) (test-suite "deforestation" + ;; Note that these test deforestation in isolation + ;; without necessarily taking normalization (a preceding + ;; step in compilation) into account + (test-suite "general" - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-false (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "does not deforest single stream component in isolation")) - (let ([stx #'(#%blanket-template + (let ([stx #'(thread + #%blanket-template ((#%host-expression map) (#%host-expression sqr) __) @@ -50,379 +59,409 @@ __))]) (check-false (deforested? (syntax->datum (deforest-rewrite - #`(thread #,stx)))) + stx))) "does not deforest map in the head position")) ;; (~>> values (filter odd?) (map sqr) values) - (let ([stx (syntax->list - #'(values - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __)) - values))]) + (let ([stx #'(thread + values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)) + values)]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "deforestation in arbitrary positions")) - (let ([stx (syntax->list - #'(values - (#%blanket-template - ((#%host-expression filter) - (#%host-expression string-upcase) - __)) - (#%blanket-template - ((#%host-expression foldl) - (#%host-expression string-append) - (#%host-expression "I") - __)) - values))]) + (let ([stx #'(thread + values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __)) + values)]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "deforestation in arbitrary positions"))) + (test-suite "transformers" - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __))))]) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "filter")) - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __))))]) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "filter-map (two transformers)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression filter) - (#%host-expression odd?) - _)) - (#%fine-template - ((#%host-expression map) - (#%host-expression sqr) - _))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression filter) + (#%host-expression odd?) + _)) + (#%fine-template + ((#%host-expression map) + (#%host-expression sqr) + _)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "fine-grained template forms"))) + (test-suite "producers" - (let ([stx (syntax->list #'((#%host-expression range) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%host-expression range) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "range")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range _)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range _ _)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 _)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range _ 10)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range _ _ _)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range _ _ 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range _ 10 _)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range _ 10 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 _ _)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 _ 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 10 _)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range __)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 __)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range __ 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 10 __)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range __ 10 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 __ 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 10 1 __)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 10 __ 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range 0 __ 10 1)")) - (let ([stx (syntax->list #'((#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __))))]) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "(range __ 0 10 1)"))) + (test-suite "consumers" - (let ([stx (syntax->list #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (esc (#%host-expression car))))]) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (esc (#%host-expression car)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "car")) - (let ([stx (syntax->list - #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression string-upcase) - __)) - (#%blanket-template - ((#%host-expression foldl) - (#%host-expression string-append) - (#%host-expression "I") - __))))]) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "foldl")) - (let ([stx (syntax->list - #'((#%blanket-template - ((#%host-expression filter) - (#%host-expression string-upcase) - __)) - (#%blanket-template - ((#%host-expression foldr) - (#%host-expression string-append) - (#%host-expression "I") - __))))]) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldr) + (#%host-expression string-append) + (#%host-expression "I") + __)))]) (check-true (deforested? (syntax->datum (deforest-rewrite - #`(thread #,@stx)))) + stx))) "foldr")))) + (test-suite "normalization" (test-normalize #'(thread @@ -438,11 +477,9 @@ (test-normalize #'(thread sqr) #'sqr "trivial threading is collapsed")) + (test-suite "compilation sequences" - null) - (test-suite - "fixed point" null))) (module+ main From f60de73f7b6b84c6c48fbfdc5701e31552263065 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 17:47:54 -0800 Subject: [PATCH 277/338] fix invalid test --- qi-test/tests/flow.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index ea76fde0e..4b5d459ac 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1571,8 +1571,7 @@ (check-equal? ((☯ (~>> (map string-upcase) (foldl string-append "I"))) (list "a" "b" "c")) "CBAI") - (check-equal? ((☯ (~>> (range 10) (map sqr) car)) - 0) + (check-equal? ((☯ (~>> (range 10) (map sqr) car))) 0))))) (module+ main From 633c15161443a677c39c58e60c86605da2eeaf23 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 18:01:24 -0800 Subject: [PATCH 278/338] Fix "anaphoric references" issue (resolves failing test) See "The Artist Formerly Known as Bindingspec" in the Qi meeting notes for more context on this issue. We had formerly fixed this for partial application, but hadn't noticed the same issue also affected blanket templates. Recently we committed a fix for the two cases of the template being on the beginning or end (which is what partial application without a template now expands to). This adds the fix for the remaining case where a template is somewhere in the middle of the expression. --- qi-lib/flow/core/compiler.rkt | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 91f3ca1d7..e60655f93 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -537,18 +537,26 @@ the DSL. ;; "prarg" = "pre-supplied argument" ;; Note: use of currying here doesn't play well with bindings ;; because curry / curryr immediately evaluate their arguments - ;; and resolve any references to bindings at compile time, - ;; whereas a lambda delays evaluation until runtime when the - ;; reference is actually resolvable. + ;; and resolve any references to bindings at compile time. + ;; That's why we use a lambda which delays evaluation until runtime + ;; when the reference is actually resolvable. See "anaphoric references" + ;; in the compiler meeting notes, + ;; "The Artist Formerly Known as Bindingspec" [((~datum #%blanket-template) (natex prarg-pre ...+ (~datum __) prarg-post ...+)) - #'(curry (curryr natex - prarg-post ...) - prarg-pre ...)] + ;; "(curry (curryr ...) ...)" + #'(lambda largs + (apply + (lambda rargs + ((kw-helper natex rargs) prarg-post ...)) + prarg-pre ... + largs))] [((~datum #%blanket-template) (natex prarg-pre ...+ (~datum __))) + ;; "curry" #'(lambda args (apply natex prarg-pre ... args))] [((~datum #%blanket-template) (natex (~datum __) prarg-post ...+)) + ;; "curryr" #'(lambda args ((kw-helper natex args) prarg-post ...))]))) From e55174a3a3b5eb4a2b091be5e3b873370bd253cb Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 29 Nov 2023 18:41:15 -0800 Subject: [PATCH 279/338] tests for keyword arguments in templates --- qi-test/tests/flow.rkt | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 4b5d459ac..554f0f0bc 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -709,9 +709,13 @@ "abc") (check-equal? ((☯ (string-append __ "c")) "a" "b") - "abc")) + "abc") + (check-equal? ((☯ (sort < __ #:key sqr)) + 3 1 2) + (list 1 4 9) + "keyword arguments in a blanket template")) (test-suite - "template with single argument" + "fine template with single argument" (check-false ((☯ (apply > _)) (list 1 2 3))) (check-true ((☯ (apply > _)) @@ -730,13 +734,21 @@ (check-equal? ((☯ (foldl string-append "" _)) (list "a" "b" "c")) "cba" - "foldl in predicate")) + "foldl in predicate") + (check-equal? ((☯ (sort < 3 _ 2 #:key sqr)) + 1) + (list 1 4 9) + "keyword arguments in a fine template")) (test-suite - "template with multiple arguments" + "fine template with multiple arguments" (check-true ((☯ (< 1 _ 5 _ 10)) 3 7) "template with multiple arguments") (check-false ((☯ (< 1 _ 5 _ 10)) 3 5) - "template with multiple arguments")) + "template with multiple arguments") + (check-equal? ((☯ (sort < _ _ 2 #:key sqr)) + 3 1) + (list 1 4 9) + "keyword arguments in a fine template")) (test-suite "templating behavior is contained to intentional template syntax" (check-exn exn:fail:syntax? From aa83cf81516ab4052626c62e21d732bbd495f609 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 09:59:45 +0100 Subject: [PATCH 280/338] deforestation: fix blanket template currying --- qi-lib/flow/core/deforest.rkt | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 570472a37..378cca088 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -91,7 +91,11 @@ (λ () (v pre-arg ... post-arg ...)))) (else - #'(λ (v) (curry (curryr v post-arg ...) pre-arg ...)))))) + #'(λ (v) + (λ rest + (apply v pre-arg ... + (append rest + (list post-arg ...))))))))) ;; Used for producing the stream from particular ;; expressions. Implicit producer is list->cstream-next and it is @@ -155,7 +159,7 @@ ;; can (and should) be matched. (define-syntax-class fusable-stream-transformer #:attributes (f next) - #:datum-literals (#%host-expression #%blanket-template __) + #:datum-literals (#%host-expression #%blanket-template __ #%fine-template) (pattern (~or (#%blanket-template ((#%host-expression (~literal map)) (#%host-expression f) From ab879c8d6347cbb646202bb1b7822ffead51dc98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 10:18:05 +0100 Subject: [PATCH 281/338] deforestation: report too many arguments for blanket templates in syntax phase --- qi-lib/flow/core/deforest.rkt | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 378cca088..5b350bc61 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -7,7 +7,6 @@ racket/syntax-srcloc) racket/performance-hint racket/match - racket/function racket/list racket/contract/base) @@ -32,19 +31,17 @@ ;; is lost and the form is already normalized at this point though! (define (prettify-flow-syntax stx) (syntax-parse stx - #:datum-literals (#%partial-application #%host-expression esc) + #:datum-literals (#%partial-application #%host-expression esc #%blanket-template) (((~literal thread) expr ...) #`(~> #,@(prettify-flow-syntax #'(expr ...)))) - ((#%partial-application + ((#%blanket-template (expr ...)) - (for/list ((ex (in-list (syntax->list #'(expr ...))))) - (prettify-flow-syntax ex))) + (map prettify-flow-syntax (syntax->list #'(expr ...)))) ((#%host-expression expr) #'expr) ((esc expr) (prettify-flow-syntax #'expr)) ((expr ...) - (for/list ((ex (in-list (syntax->list #'(expr ...))))) - (prettify-flow-syntax ex))) + (map prettify-flow-syntax (syntax->list #'(expr ...)))) (expr #'expr))) ;; Special "curry"ing for #%fine-templates. All #%host-expressions @@ -78,14 +75,15 @@ ;; there are too many arguments. If the number of arguments is ;; exactly the maximum, wraps into lambda without any arguments. If ;; less than maximum, curries it from both left and right. - (define (make-blanket-curry prestx poststx maxargs) + (define (make-blanket-curry prestx poststx maxargs form-stx) (define prelst (syntax->list prestx)) (define postlst (syntax->list poststx)) (define numargs (+ (length prelst) (length postlst))) (with-syntax (((pre-arg ...) prelst) ((post-arg ...) postlst)) (cond ((> numargs maxargs) - (raise-syntax-error "too many arguments")) + (raise-syntax-error 'range "too many arguments" + (prettify-flow-syntax form-stx))) ((= numargs maxargs) #'(λ (v) (λ () @@ -104,8 +102,7 @@ (define-syntax-class fusable-stream-producer #:attributes (next prepare contract name curry) #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) - ;; Explicit range producers. We have to conver all four variants - ;; as they all come with different runtime contracts! + ;; Explicit range producers. (pattern (esc (#%host-expression (~literal range))) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare @@ -120,17 +117,20 @@ #:attr contract #'(->* (real?) (real? real?) any) #:attr name #''range #:attr curry (make-fine-curry #'(arg ...))) - (pattern (#%blanket-template - ((#%host-expression (~literal range)) - (#%host-expression pre-arg) ... - __ - (#%host-expression post-arg) ...)) + (pattern (~and (#%blanket-template + ((#%host-expression (~literal range)) + (#%host-expression pre-arg) ... + __ + (#%host-expression post-arg) ...)) + form-stx) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare #:attr name #''range #:attr curry (make-blanket-curry #'(pre-arg ...) #'(post-arg ...) - 3) + 3 + #'form-stx + ) #:attr contract #'(->* (real?) (real? real?) any)) ;; The implicit stream producer from plain list. From 25c781e6c784d41262070d2d5f29e0d24de8da09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 10:33:44 +0100 Subject: [PATCH 282/338] deforestation: preliminary support for argument count limits in syntax phase --- qi-lib/flow/core/deforest.rkt | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 5b350bc61..07c664dc5 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -47,8 +47,17 @@ ;; Special "curry"ing for #%fine-templates. All #%host-expressions ;; are passed as they are and all (~datum _) are replaced by wrapper ;; lambda arguments. - (define (make-fine-curry argstx) + (define ((make-fine-curry argstx minargs maxargs form-stx name) ctx) (define argstxlst (syntax->list argstx)) + (define numargs (length argstxlst)) + (cond ((< numargs minargs) + (raise-syntax-error name "too little arguments" + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))) + ((> numargs maxargs) + (raise-syntax-error name "too many arguments" + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx)))) (define temporaries (generate-temporaries argstxlst)) (define-values (allargs tmpargs) (for/fold ((all '()) @@ -75,14 +84,15 @@ ;; there are too many arguments. If the number of arguments is ;; exactly the maximum, wraps into lambda without any arguments. If ;; less than maximum, curries it from both left and right. - (define (make-blanket-curry prestx poststx maxargs form-stx) + (define ((make-blanket-curry prestx poststx maxargs form-stx name) ctx) (define prelst (syntax->list prestx)) (define postlst (syntax->list poststx)) (define numargs (+ (length prelst) (length postlst))) (with-syntax (((pre-arg ...) prelst) ((post-arg ...) postlst)) (cond ((> numargs maxargs) - (raise-syntax-error 'range "too many arguments" + (raise-syntax-error name "too many arguments" + (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx))) ((= numargs maxargs) #'(λ (v) @@ -108,15 +118,16 @@ #:attr prepare #'range->cstream-prepare #:attr contract #'(->* (real?) (real? real?) any) #:attr name #''range - #:attr curry #'(λ (v) v)) - (pattern (#%fine-template - ((#%host-expression (~literal range)) - arg ...)) + #:attr curry (λ (ctx) #'(λ (v) v))) + (pattern (~and (#%fine-template + ((#%host-expression (~literal range)) + arg ...)) + form-stx) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare #:attr contract #'(->* (real?) (real? real?) any) #:attr name #''range - #:attr curry (make-fine-curry #'(arg ...))) + #:attr curry (make-fine-curry #'(arg ...) 1 3 #'form-stx 'range)) (pattern (~and (#%blanket-template ((#%host-expression (~literal range)) (#%host-expression pre-arg) ... @@ -130,6 +141,7 @@ #'(post-arg ...) 3 #'form-stx + 'range ) #:attr contract #'(->* (real?) (real? real?) any)) @@ -139,7 +151,7 @@ #:attr prepare #'list->cstream-prepare #:attr contract #'(-> list? any) #:attr name #''list->cstream - #:attr curry #'(lambda (v) v))) + #:attr curry (λ (ctx) #'(λ (v) v)))) ;; Matches any stream transformer that can be in the head position ;; of the fused sequence even when there is no explicit @@ -235,7 +247,7 @@ ;; fused sequence. And runtime checks for consumers are in ;; their respective implementation procedure. #`(esc - (p.curry + (#,((attribute p.curry) ctx) (contract p.contract (p.prepare (#,@#'c.end From 19ad84377d0ea85216f1b399c789c3f6c6b9d1e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 10:40:48 +0100 Subject: [PATCH 283/338] deforestation: update prettify-flow-syntax de-expander to reflect latest syntax template changes --- qi-lib/flow/core/deforest.rkt | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 07c664dc5..0434e2b35 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -31,17 +31,15 @@ ;; is lost and the form is already normalized at this point though! (define (prettify-flow-syntax stx) (syntax-parse stx - #:datum-literals (#%partial-application #%host-expression esc #%blanket-template) + #:datum-literals (#%host-expression esc #%blanket-template #%fine-template) (((~literal thread) expr ...) - #`(~> #,@(prettify-flow-syntax #'(expr ...)))) - ((#%blanket-template + #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))) + (((~or #%blanket-template #%fine-template) (expr ...)) (map prettify-flow-syntax (syntax->list #'(expr ...)))) ((#%host-expression expr) #'expr) ((esc expr) (prettify-flow-syntax #'expr)) - ((expr ...) - (map prettify-flow-syntax (syntax->list #'(expr ...)))) (expr #'expr))) ;; Special "curry"ing for #%fine-templates. All #%host-expressions From d283221485456a21bd63eb18e22fbce664cbdb83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 10:50:24 +0100 Subject: [PATCH 284/338] deforestation: unify range producer syntax patterns into one --- qi-lib/flow/core/deforest.rkt | 51 +++++++++++++++++------------------ 1 file changed, 24 insertions(+), 27 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 0434e2b35..e4cf42237 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -111,37 +111,34 @@ #:attributes (next prepare contract name curry) #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) ;; Explicit range producers. - (pattern (esc (#%host-expression (~literal range))) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare - #:attr contract #'(->* (real?) (real? real?) any) - #:attr name #''range - #:attr curry (λ (ctx) #'(λ (v) v))) - (pattern (~and (#%fine-template - ((#%host-expression (~literal range)) - arg ...)) + (pattern (~and (~or (esc (#%host-expression (~literal range))) + (~and (#%fine-template + ((#%host-expression (~literal range)) + arg ...)) + fine?) + (~and (#%blanket-template + ((#%host-expression (~literal range)) + (#%host-expression pre-arg) ... + __ + (#%host-expression post-arg) ...)) + blanket?)) form-stx) #:attr next #'range->cstream-next #:attr prepare #'range->cstream-prepare #:attr contract #'(->* (real?) (real? real?) any) - #:attr name #''range - #:attr curry (make-fine-curry #'(arg ...) 1 3 #'form-stx 'range)) - (pattern (~and (#%blanket-template - ((#%host-expression (~literal range)) - (#%host-expression pre-arg) ... - __ - (#%host-expression post-arg) ...)) - form-stx) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare - #:attr name #''range - #:attr curry (make-blanket-curry #'(pre-arg ...) - #'(post-arg ...) - 3 - #'form-stx - 'range - ) - #:attr contract #'(->* (real?) (real? real?) any)) + #:attr name #'range + #:attr curry (cond + ((attribute blanket?) + (make-blanket-curry #'(pre-arg ...) + #'(post-arg ...) + 3 + #'form-stx + 'range + )) + ((attribute fine?) + (make-fine-curry #'(arg ...) 1 3 #'form-stx 'range)) + (else + (λ (ctx) #'(λ (v) v))))) ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) From 0b58fd650ca146a01d14fc5c33bb95105e82c5b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 11:13:27 +0100 Subject: [PATCH 285/338] deforestation: do not duplicate producer name for contracts and error messages --- qi-lib/flow/core/deforest.rkt | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index e4cf42237..e8529f5b2 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -45,15 +45,17 @@ ;; Special "curry"ing for #%fine-templates. All #%host-expressions ;; are passed as they are and all (~datum _) are replaced by wrapper ;; lambda arguments. - (define ((make-fine-curry argstx minargs maxargs form-stx name) ctx) + (define ((make-fine-curry argstx minargs maxargs form-stx) ctx name) (define argstxlst (syntax->list argstx)) (define numargs (length argstxlst)) (cond ((< numargs minargs) - (raise-syntax-error name "too little arguments" + (raise-syntax-error (syntax->datum name) + "too little arguments" (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx))) ((> numargs maxargs) - (raise-syntax-error name "too many arguments" + (raise-syntax-error (syntax->datum name) + "too many arguments" (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx)))) (define temporaries (generate-temporaries argstxlst)) @@ -82,14 +84,15 @@ ;; there are too many arguments. If the number of arguments is ;; exactly the maximum, wraps into lambda without any arguments. If ;; less than maximum, curries it from both left and right. - (define ((make-blanket-curry prestx poststx maxargs form-stx name) ctx) + (define ((make-blanket-curry prestx poststx maxargs form-stx) ctx name) (define prelst (syntax->list prestx)) (define postlst (syntax->list poststx)) (define numargs (+ (length prelst) (length postlst))) (with-syntax (((pre-arg ...) prelst) ((post-arg ...) postlst)) (cond ((> numargs maxargs) - (raise-syntax-error name "too many arguments" + (raise-syntax-error (syntax->datum name) + "too many arguments" (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx))) ((= numargs maxargs) @@ -133,12 +136,11 @@ #'(post-arg ...) 3 #'form-stx - 'range )) ((attribute fine?) - (make-fine-curry #'(arg ...) 1 3 #'form-stx 'range)) + (make-fine-curry #'(arg ...) 1 3 #'form-stx)) (else - (λ (ctx) #'(λ (v) v))))) + (λ (ctx name) #'(λ (v) v))))) ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) @@ -242,7 +244,7 @@ ;; fused sequence. And runtime checks for consumers are in ;; their respective implementation procedure. #`(esc - (#,((attribute p.curry) ctx) + (#,((attribute p.curry) ctx (attribute p.name)) (contract p.contract (p.prepare (#,@#'c.end From 6f7782044598a6d664b75daba9222216928cf070 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 11:39:09 +0100 Subject: [PATCH 286/338] deforestation: unified producer curry maker --- qi-lib/flow/core/deforest.rkt | 36 ++++++++++++++++++++++++----------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index e8529f5b2..ea47efd1c 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -106,6 +106,27 @@ (append rest (list post-arg ...))))))))) + ;; Unifying producer curry makers. The ellipsis escaping allows for + ;; simple specification of pattern variable names as bound in the + ;; syntax pattern. + (define-syntax make-producer-curry + (syntax-rules () + ((_ min-args max-args + blanket? pre-arg post-arg + fine? arg + form-stx) + (cond + ((attribute blanket?) + (make-blanket-curry #'(pre-arg (... ...)) + #'(post-arg (... ...)) + max-args + #'form-stx + )) + ((attribute fine?) + (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)) + (else + (λ (ctx name) #'(λ (v) v))))))) + ;; Used for producing the stream from particular ;; expressions. Implicit producer is list->cstream-next and it is ;; not created by using this class but rather explicitly used when @@ -130,17 +151,10 @@ #:attr prepare #'range->cstream-prepare #:attr contract #'(->* (real?) (real? real?) any) #:attr name #'range - #:attr curry (cond - ((attribute blanket?) - (make-blanket-curry #'(pre-arg ...) - #'(post-arg ...) - 3 - #'form-stx - )) - ((attribute fine?) - (make-fine-curry #'(arg ...) 1 3 #'form-stx)) - (else - (λ (ctx name) #'(λ (v) v))))) + #:attr curry (make-producer-curry 1 3 + blanket? pre-arg post-arg + fine? arg + form-stx)) ;; The implicit stream producer from plain list. (pattern (~literal list->cstream) From 121edbe6a5f73baf86a2eebce328eb9b7ef19d78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 11:44:35 +0100 Subject: [PATCH 287/338] deforestation: fix new producer curry semantics for implicit list->cstream producer --- qi-lib/flow/core/deforest.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index ea47efd1c..fb6601b28 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -162,7 +162,7 @@ #:attr prepare #'list->cstream-prepare #:attr contract #'(-> list? any) #:attr name #''list->cstream - #:attr curry (λ (ctx) #'(λ (v) v)))) + #:attr curry (λ (ctx name) #'(λ (v) v)))) ;; Matches any stream transformer that can be in the head position ;; of the fused sequence even when there is no explicit From 7473a89a6c2e5eff24f3a8eb9776aa161139bdc7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 12:14:42 +0100 Subject: [PATCH 288/338] deforestation: more patterns unification --- qi-lib/flow/core/deforest.rkt | 59 +++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 27 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index fb6601b28..295f63c75 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -192,6 +192,7 @@ (#%host-expression f) _))) #:attr next #'map-cstream-next) + (pattern (~or (#%blanket-template ((#%host-expression (~literal filter)) (#%host-expression f) @@ -206,38 +207,42 @@ ;; an actual result value. (define-syntax-class fusable-stream-consumer #:attributes (end) - #:datum-literals (#%host-expression #%blanket-template __ #%fine-template esc) - (pattern (#%blanket-template - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init) - __)) - #:attr end #'(foldr-cstream-next op init)) - (pattern (#%blanket-template - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init) - __)) - #:attr end #'(foldl-cstream-next op init)) - (pattern (#%fine-template - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init) - (~datum _))) + #:datum-literals (#%host-expression #%blanket-template _ __ #%fine-template esc) + (pattern (~or (#%blanket-template + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init) + _))) #:attr end #'(foldr-cstream-next op init)) - (pattern (#%fine-template - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init) - (~datum _))) + + (pattern (~or (#%blanket-template + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init) + _))) #:attr end #'(foldl-cstream-next op init)) - (pattern (~literal cstream->list) - #:attr end #'(cstream-next->list)) + (pattern (~or (esc (#%host-expression (~literal car))) (#%fine-template ((#%host-expression (~literal car)) - (~datum _)))) - #:attr end #'(car-cstream-next))) + _)) + (#%blanket-template + ((#%host-expression (~literal car)) + __))) + #:attr end #'(car-cstream-next)) + + (pattern (~literal cstream->list) + #:attr end #'(cstream-next->list))) ;; Used only in deforest-rewrite to properly recognize the end of ;; fusable sequence. From 62a70cbede0dfa28c49f9d7237c467e074b762e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 12:19:30 +0100 Subject: [PATCH 289/338] deforestation: improve invalid argument count error messages for static arguments --- qi-lib/flow/core/deforest.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 295f63c75..cc51516ce 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -50,12 +50,14 @@ (define numargs (length argstxlst)) (cond ((< numargs minargs) (raise-syntax-error (syntax->datum name) - "too little arguments" + (format "too little arguments - given ~a - accepts at least ~a" + numargs minargs) (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx))) ((> numargs maxargs) (raise-syntax-error (syntax->datum name) - "too many arguments" + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx)))) (define temporaries (generate-temporaries argstxlst)) @@ -92,7 +94,8 @@ ((post-arg ...) postlst)) (cond ((> numargs maxargs) (raise-syntax-error (syntax->datum name) - "too many arguments" + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx))) ((= numargs maxargs) From 98b1fe746eb0f011516e74061a2349a8dfc2a3f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 16:02:08 +0100 Subject: [PATCH 290/338] deforestation: fix error message --- qi-lib/flow/core/deforest.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index cc51516ce..4f5f5a930 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -50,7 +50,7 @@ (define numargs (length argstxlst)) (cond ((< numargs minargs) (raise-syntax-error (syntax->datum name) - (format "too little arguments - given ~a - accepts at least ~a" + (format "too few arguments - given ~a - accepts at least ~a" numargs minargs) (prettify-flow-syntax ctx) (prettify-flow-syntax form-stx))) From 0cb82dca541c300d3d77d6a4e5f40e81d7b89afe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 19:04:35 +0100 Subject: [PATCH 291/338] deforestation: full blame information at runtime --- qi-lib/flow/core/deforest.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 4f5f5a930..d76c7ca7d 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -333,8 +333,10 @@ (cond [(null? state) (done)] [else (yield (car state) (cdr state))]))) - (define-inline ((list->cstream-prepare next) lst) - (next lst)) + (define-inline (list->cstream-prepare next) + (case-lambda + [(lst) (next lst)] + [rest (void)])) (define-inline (range->cstream-next done skip yield) (λ (state) @@ -347,7 +349,8 @@ (case-lambda [(h) (next (list 0 h 1))] [(l h) (next (list l h 1))] - [(l h s) (next (list l h s))])) + [(l h s) (next (list l h s))] + [rest (void)])) ;; Transformers From 7e59b4195599a10022bd836e76ff829e4dbd9e9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 20:42:57 +0100 Subject: [PATCH 292/338] deforestation: add range producer semantic tests --- qi-test/tests/flow.rkt | 99 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 98 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 554f0f0bc..ff01c95b9 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1584,7 +1584,104 @@ (list "a" "b" "c")) "CBAI") (check-equal? ((☯ (~>> (range 10) (map sqr) car))) - 0))))) + 0)) + ;; Semantic tests of the range producer that cover all combinations: + (test-equal? "~>>range [1-3] (10)" + (~>> (10) range (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>range [1-3] (10)" + (~> (10) range (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> range [1-3] (5 10)" + (~>> (5 10) range (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> range [1-3] (5 10)" + (~> (5 10) range (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> range [1-3] (5 10 3)" + (~>> (5 10 3) range (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> range [1-3] (5 10 3)" + (~> (5 10 3) range (~>> (filter odd?) (map sqr))) + '(25)) + + + (test-equal? "~>> (range 10) [0-2] ()" + (~>> () (range 10) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~> (range 10) [0-2] ()" + (~> () (range 10) (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> (range 5) [0-2] (10)" + (~>> (10) (range 5) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 10) [0-2] (5)" + (~> (5) (range 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 3) [0-2] (5 10)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 5) [0-2] (10 3)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + + (test-equal? "~>> (range 5 10) [0-1] ()" + (~>> () (range 5 10) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 5 10) [0-1] ()" + (~> () (range 5 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 5 10) [0-1] (3)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 10 3) [0-1] (5)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 5 10 3) [0] ()" + (~>> () (range 5 10 3) (filter odd?) (map sqr)) + '(25)) + + + (test-equal? "~>> (range _) [1] (10)" + (~>> (10) (range _) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>> (range _ _) [2] (5 10)" + (~>> (5 10) (range _ _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ _ _) [3] (5 10 3)" + (~>> (5 10 3) (range _ _ _) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 _) [1] (10)" + (~>> (10) (range 5 _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ 10) [1] (5)" + (~>> (5) (range _ 10) (filter odd?) (map sqr)) + '(25 49 81)) + + + (test-equal? "~>> (range 5 _ _) [2] (10 3)" + (~>> (10 3) (range 5 _ _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 _) [2] (5 3)" + (~>> (5 3) (range _ 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ _ 3) [2] (5 10)" + (~>> (5 10) (range _ _ 3) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 10 _) [1] (3)" + (~>> (3) (range 5 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range 5 _ 3) [1] (10)" + (~>> (10) (range 5 _ 3) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 3) [1] (5)" + (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) + '(25)) + ))) (module+ main (void (run-tests tests))) From f41b32a57defcc3bb1b43b24cdd8065413a637b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 30 Nov 2023 21:21:57 +0100 Subject: [PATCH 293/338] deforestation: fix support for #%fine-template in fusable-stream-transformer0 and add missing esc in range producer test --- qi-lib/flow/core/deforest.rkt | 22 +++++++++++++--------- qi-test/tests/compiler.rkt | 2 +- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index d76c7ca7d..1c4b5490b 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -173,11 +173,15 @@ ;; `map` cannot be in this class. (define-syntax-class fusable-stream-transformer0 #:attributes (f next) - #:datum-literals (#%host-expression #%blanket-template __) - (pattern (#%blanket-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - __)) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + _))) #:attr next #'filter-cstream-next)) ;; All implemented stream transformers - within the stream, only @@ -185,7 +189,7 @@ ;; can (and should) be matched. (define-syntax-class fusable-stream-transformer #:attributes (f next) - #:datum-literals (#%host-expression #%blanket-template __ #%fine-template) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) (pattern (~or (#%blanket-template ((#%host-expression (~literal map)) (#%host-expression f) @@ -202,8 +206,8 @@ __)) (#%fine-template ((#%host-expression (~literal filter)) - (#%host-expression f)) - _)) + (#%host-expression f) + _))) #:attr next #'filter-cstream-next)) ;; Terminates the fused sequence (consumes the stream) and produces @@ -301,7 +305,7 @@ _1 ...) #:with fused (generate-fused-operation (syntax->list #'(list->cstream t1 t ... c)) - stx) + stx) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... p:fusable-stream-producer diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 020013e62..10d6d1451 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -139,7 +139,7 @@ (test-suite "producers" (let ([stx #'(thread - (#%host-expression range) + (esc (#%host-expression range)) (#%blanket-template ((#%host-expression filter) (#%host-expression odd?) From b518b17289bea0845f1ec77052908f54df7dbe4f Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 30 Nov 2023 12:38:11 -0800 Subject: [PATCH 294/338] include the new producer tests in the deforestation test suite --- qi-test/tests/flow.rkt | 175 ++++++++++++++++++++--------------------- 1 file changed, 86 insertions(+), 89 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index ff01c95b9..cb9c92e23 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1584,104 +1584,101 @@ (list "a" "b" "c")) "CBAI") (check-equal? ((☯ (~>> (range 10) (map sqr) car))) - 0)) - ;; Semantic tests of the range producer that cover all combinations: - (test-equal? "~>>range [1-3] (10)" - (~>> (10) range (filter odd?) (map sqr)) - '(1 9 25 49 81)) - (test-equal? "~>range [1-3] (10)" - (~> (10) range (~>> (filter odd?) (map sqr))) - '(1 9 25 49 81)) - (test-equal? "~>> range [1-3] (5 10)" - (~>> (5 10) range (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~> range [1-3] (5 10)" - (~> (5 10) range (~>> (filter odd?) (map sqr))) - '(25 49 81)) - (test-equal? "~>> range [1-3] (5 10 3)" - (~>> (5 10 3) range (filter odd?) (map sqr)) - '(25)) - (test-equal? "~> range [1-3] (5 10 3)" - (~> (5 10 3) range (~>> (filter odd?) (map sqr))) - '(25)) - - - (test-equal? "~>> (range 10) [0-2] ()" - (~>> () (range 10) (filter odd?) (map sqr)) - '(1 9 25 49 81)) - (test-equal? "~> (range 10) [0-2] ()" - (~> () (range 10) (~>> (filter odd?) (map sqr))) - '(1 9 25 49 81)) - (test-equal? "~>> (range 5) [0-2] (10)" - (~>> (10) (range 5) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~> (range 10) [0-2] (5)" - (~> (5) (range 10) (~>> (filter odd?) (map sqr))) - '(25 49 81)) - (test-equal? "~>> (range 3) [0-2] (5 10)" - (~>> (3) (range 5 10) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~> (range 5) [0-2] (10 3)" - (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) - '(25)) + 0) + ;; Semantic tests of the range producer that cover all combinations: + (test-equal? "~>>range [1-3] (10)" + (~>> (10) range (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>range [1-3] (10)" + (~> (10) range (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> range [1-3] (5 10)" + (~>> (5 10) range (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> range [1-3] (5 10)" + (~> (5 10) range (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> range [1-3] (5 10 3)" + (~>> (5 10 3) range (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> range [1-3] (5 10 3)" + (~> (5 10 3) range (~>> (filter odd?) (map sqr))) + '(25)) + (test-equal? "~>> (range 10) [0-2] ()" + (~>> () (range 10) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~> (range 10) [0-2] ()" + (~> () (range 10) (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> (range 5) [0-2] (10)" + (~>> (10) (range 5) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 10) [0-2] (5)" + (~> (5) (range 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 3) [0-2] (5 10)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 5) [0-2] (10 3)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) - (test-equal? "~>> (range 5 10) [0-1] ()" - (~>> () (range 5 10) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~> (range 5 10) [0-1] ()" - (~> () (range 5 10) (~>> (filter odd?) (map sqr))) - '(25 49 81)) - (test-equal? "~>> (range 5 10) [0-1] (3)" - (~>> (3) (range 5 10) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~> (range 10 3) [0-1] (5)" - (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) - '(25)) - (test-equal? "~>> (range 5 10 3) [0] ()" - (~>> () (range 5 10 3) (filter odd?) (map sqr)) - '(25)) + (test-equal? "~>> (range 5 10) [0-1] ()" + (~>> () (range 5 10) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 5 10) [0-1] ()" + (~> () (range 5 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 5 10) [0-1] (3)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 10 3) [0-1] (5)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + (test-equal? "~>> (range 5 10 3) [0] ()" + (~>> () (range 5 10 3) (filter odd?) (map sqr)) + '(25)) - (test-equal? "~>> (range _) [1] (10)" - (~>> (10) (range _) (filter odd?) (map sqr)) - '(1 9 25 49 81)) - (test-equal? "~>> (range _ _) [2] (5 10)" - (~>> (5 10) (range _ _) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~>> (range _ _ _) [3] (5 10 3)" - (~>> (5 10 3) (range _ _ _) (filter odd?) (map sqr)) - '(25)) + (test-equal? "~>> (range _) [1] (10)" + (~>> (10) (range _) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>> (range _ _) [2] (5 10)" + (~>> (5 10) (range _ _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ _ _) [3] (5 10 3)" + (~>> (5 10 3) (range _ _ _) (filter odd?) (map sqr)) + '(25)) - (test-equal? "~>> (range 5 _) [1] (10)" - (~>> (10) (range 5 _) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~>> (range _ 10) [1] (5)" - (~>> (5) (range _ 10) (filter odd?) (map sqr)) - '(25 49 81)) + (test-equal? "~>> (range 5 _) [1] (10)" + (~>> (10) (range 5 _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ 10) [1] (5)" + (~>> (5) (range _ 10) (filter odd?) (map sqr)) + '(25 49 81)) - (test-equal? "~>> (range 5 _ _) [2] (10 3)" - (~>> (10 3) (range 5 _ _) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range _ 10 _) [2] (5 3)" - (~>> (5 3) (range _ 10 _) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range _ _ 3) [2] (5 10)" - (~>> (5 10) (range _ _ 3) (filter odd?) (map sqr)) - '(25)) + (test-equal? "~>> (range 5 _ _) [2] (10 3)" + (~>> (10 3) (range 5 _ _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 _) [2] (5 3)" + (~>> (5 3) (range _ 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ _ 3) [2] (5 10)" + (~>> (5 10) (range _ _ 3) (filter odd?) (map sqr)) + '(25)) - (test-equal? "~>> (range 5 10 _) [1] (3)" - (~>> (3) (range 5 10 _) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range 5 _ 3) [1] (10)" - (~>> (10) (range 5 _ 3) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range _ 10 3) [1] (5)" - (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) - '(25)) - ))) + (test-equal? "~>> (range 5 10 _) [1] (3)" + (~>> (3) (range 5 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range 5 _ 3) [1] (10)" + (~>> (10) (range 5 _ 3) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 3) [1] (5)" + (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) + '(25)))))) (module+ main (void (run-tests tests))) From 6798a617d0c9cdb4d547ae82ed01e04a65da6385 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 30 Nov 2023 12:39:14 -0800 Subject: [PATCH 295/338] add a couple more tests for kwargs in a blanket template --- qi-test/tests/flow.rkt | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index cb9c92e23..9d9de7689 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -710,10 +710,18 @@ (check-equal? ((☯ (string-append __ "c")) "a" "b") "abc") + (check-equal? ((☯ (sort __ 1 2 #:key sqr)) + < 3) + (list 1 4 9) + "keyword arguments in a left chiral blanket template") + (check-equal? ((☯ (sort < 3 #:key sqr __)) + 1 2) + (list 1 4 9) + "keyword arguments in a right chiral blanket template") (check-equal? ((☯ (sort < __ #:key sqr)) 3 1 2) (list 1 4 9) - "keyword arguments in a blanket template")) + "keyword arguments in a vindaloo blanket template")) (test-suite "fine template with single argument" (check-false ((☯ (apply > _)) From 20da83762092352dd1e4ee901cf7841c59e4de32 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 30 Nov 2023 13:01:13 -0800 Subject: [PATCH 296/338] reorganize compiler tests into a dedicated folder (collection) --- qi-test/tests/compiler.rkt | 481 +------------------------- qi-test/tests/compiler/rules.rkt | 486 +++++++++++++++++++++++++++ qi-test/tests/compiler/semantics.rkt | 150 +++++++++ qi-test/tests/flow.rkt | 134 +------- qi-test/tests/qi.rkt | 2 +- 5 files changed, 645 insertions(+), 608 deletions(-) create mode 100644 qi-test/tests/compiler/rules.rkt create mode 100644 qi-test/tests/compiler/semantics.rkt diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 10d6d1451..1da8a0979 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -2,485 +2,18 @@ (provide tests) -(require (for-template qi/flow/core/deforest - qi/flow/core/compiler) - rackunit +(require rackunit rackunit/text-ui - (only-in math sqr) - racket/string - (only-in racket/function curryr)) - -(define-syntax-rule (test-normalize a b msg) - (check-equal? (syntax->datum - (normalize-pass a)) - (syntax->datum - (normalize-pass b)) - msg)) - -(define (deforested? exp) - (string-contains? (format "~a" exp) "cstream")) - + (prefix-in semantics: "compiler/semantics.rkt") + (prefix-in rules: "compiler/rules.rkt")) (define tests (test-suite "compiler tests" - (test-suite - "fixed point" - (check-equal? ((fix abs) -1) 1) - (check-equal? ((fix abs) -1) 1) - (let ([integer-div2 (compose floor (curryr / 2))]) - (check-equal? ((fix integer-div2) 10) - 0))) - (test-suite - "deforestation" - ;; Note that these test deforestation in isolation - ;; without necessarily taking normalization (a preceding - ;; step in compilation) into account - - (test-suite - "general" - (let ([stx #'(thread - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-false (deforested? (syntax->datum - (deforest-rewrite - stx))) - "does not deforest single stream component in isolation")) - (let ([stx #'(thread - #%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __) - ((#%host-expression filter) - (#%host-expression odd?) - __))]) - (check-false (deforested? (syntax->datum - (deforest-rewrite - stx))) - "does not deforest map in the head position")) - ;; (~>> values (filter odd?) (map sqr) values) - (let ([stx #'(thread - values - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __)) - values)]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "deforestation in arbitrary positions")) - (let ([stx #'(thread - values - (#%blanket-template - ((#%host-expression filter) - (#%host-expression string-upcase) - __)) - (#%blanket-template - ((#%host-expression foldl) - (#%host-expression string-append) - (#%host-expression "I") - __)) - values)]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "deforestation in arbitrary positions"))) - - (test-suite - "transformers" - (let ([stx #'(thread - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "filter")) - (let ([stx #'(thread - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (#%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "filter-map (two transformers)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression filter) - (#%host-expression odd?) - _)) - (#%fine-template - ((#%host-expression map) - (#%host-expression sqr) - _)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "fine-grained template forms"))) - - (test-suite - "producers" - (let ([stx #'(thread - (esc (#%host-expression range)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "range")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range _)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range _ _)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 _)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range _ 10)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range _ _ _)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range _ _ 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range _ 10 _)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range _ 10 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 _ _)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 _ 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 10 _)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range __)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 __)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range __ 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 10 __)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range __ 10 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 __ 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 10 1 __)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 10 __ 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range 0 __ 10 1)")) - (let ([stx #'(thread - (#%fine-template - ((#%host-expression range) - _ - _)) - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "(range __ 0 10 1)"))) - - (test-suite - "consumers" - (let ([stx #'(thread - (#%blanket-template - ((#%host-expression filter) - (#%host-expression odd?) - __)) - (esc (#%host-expression car)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "car")) - (let ([stx #'(thread - (#%blanket-template - ((#%host-expression filter) - (#%host-expression string-upcase) - __)) - (#%blanket-template - ((#%host-expression foldl) - (#%host-expression string-append) - (#%host-expression "I") - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "foldl")) - (let ([stx #'(thread - (#%blanket-template - ((#%host-expression filter) - (#%host-expression string-upcase) - __)) - (#%blanket-template - ((#%host-expression foldr) - (#%host-expression string-append) - (#%host-expression "I") - __)))]) - (check-true (deforested? (syntax->datum - (deforest-rewrite - stx))) - "foldr")))) - - (test-suite - "normalization" - (test-normalize #'(thread - (thread (filter odd?) - (map sqr))) - #'(thread (filter odd?) - (map sqr)) - "nested threads are collapsed") - (test-normalize #'(thread values - sqr) - #'(thread sqr) - "values inside threading is elided") - (test-normalize #'(thread sqr) - #'sqr - "trivial threading is collapsed")) - - (test-suite - "compilation sequences" - null))) + semantics:tests + rules:tests)) (module+ main - (void (run-tests tests))) + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt new file mode 100644 index 000000000..10d6d1451 --- /dev/null +++ b/qi-test/tests/compiler/rules.rkt @@ -0,0 +1,486 @@ +#lang racket/base + +(provide tests) + +(require (for-template qi/flow/core/deforest + qi/flow/core/compiler) + rackunit + rackunit/text-ui + (only-in math sqr) + racket/string + (only-in racket/function curryr)) + +(define-syntax-rule (test-normalize a b msg) + (check-equal? (syntax->datum + (normalize-pass a)) + (syntax->datum + (normalize-pass b)) + msg)) + +(define (deforested? exp) + (string-contains? (format "~a" exp) "cstream")) + + +(define tests + (test-suite + "compiler tests" + + (test-suite + "fixed point" + (check-equal? ((fix abs) -1) 1) + (check-equal? ((fix abs) -1) 1) + (let ([integer-div2 (compose floor (curryr / 2))]) + (check-equal? ((fix integer-div2) 10) + 0))) + (test-suite + "deforestation" + ;; Note that these test deforestation in isolation + ;; without necessarily taking normalization (a preceding + ;; step in compilation) into account + + (test-suite + "general" + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-false (deforested? (syntax->datum + (deforest-rewrite + stx))) + "does not deforest single stream component in isolation")) + (let ([stx #'(thread + #%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __) + ((#%host-expression filter) + (#%host-expression odd?) + __))]) + (check-false (deforested? (syntax->datum + (deforest-rewrite + stx))) + "does not deforest map in the head position")) + ;; (~>> values (filter odd?) (map sqr) values) + (let ([stx #'(thread + values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)) + values)]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "deforestation in arbitrary positions")) + (let ([stx #'(thread + values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __)) + values)]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "deforestation in arbitrary positions"))) + + (test-suite + "transformers" + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "filter")) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "filter-map (two transformers)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression filter) + (#%host-expression odd?) + _)) + (#%fine-template + ((#%host-expression map) + (#%host-expression sqr) + _)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "fine-grained template forms"))) + + (test-suite + "producers" + (let ([stx #'(thread + (esc (#%host-expression range)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "range")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ 10)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ _ _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ _ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ 10 _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ 10 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 _ _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 _ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __ 10 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 __ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 1 __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 __ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 __ 10 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __ 0 10 1)"))) + + (test-suite + "consumers" + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (esc (#%host-expression car)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "car")) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "foldl")) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldr) + (#%host-expression string-append) + (#%host-expression "I") + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "foldr")))) + + (test-suite + "normalization" + (test-normalize #'(thread + (thread (filter odd?) + (map sqr))) + #'(thread (filter odd?) + (map sqr)) + "nested threads are collapsed") + (test-normalize #'(thread values + sqr) + #'(thread sqr) + "values inside threading is elided") + (test-normalize #'(thread sqr) + #'sqr + "trivial threading is collapsed")) + + (test-suite + "compilation sequences" + null))) + +(module+ main + (void (run-tests tests))) diff --git a/qi-test/tests/compiler/semantics.rkt b/qi-test/tests/compiler/semantics.rkt new file mode 100644 index 000000000..1663bae6d --- /dev/null +++ b/qi-test/tests/compiler/semantics.rkt @@ -0,0 +1,150 @@ +#lang racket/base + +(provide tests) + +(require qi + rackunit + rackunit/text-ui + (only-in math sqr) + (only-in racket/list range) + racket/function) + +(define tests + (test-suite + "Compiler preserves semantics" + + (test-suite + "deforestation" + (check-equal? ((☯ (~>> (filter odd?) (map sqr))) + (list 1 2 3 4 5)) + (list 1 9 25)) + (check-exn exn:fail? + (thunk + ((☯ (~> (map sqr) (map sqr))) + (list 1 2 3 4 5))) + "(map) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~> (filter odd?) (filter odd?))) + (list 1 2 3 4 5))) + "(filter) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~>> (filter odd?) (~> (foldr + 0)))) + (list 1 2 3 4 5))) + "(foldr) doforestation should only be done for right threading") + (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) + (list 1 2 3 4 5)) + (list 1 9 25) + "optimizes subexpressions") + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldr + 0))) + (list 1 2 3 4 5)) + 35) + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldl + 0))) + (list 1 2 3 4 5)) + 35) + (check-equal? ((☯ (~>> (map string-upcase) (foldr string-append "I"))) + (list "a" "b" "c")) + "ABCI") + (check-equal? ((☯ (~>> (map string-upcase) (foldl string-append "I"))) + (list "a" "b" "c")) + "CBAI") + (check-equal? ((☯ (~>> (range 10) (map sqr) car))) + 0) + (test-suite + "range (stream producer)" + ;; Semantic tests of the range producer that cover all combinations: + (test-equal? "~>>range [1-3] (10)" + (~>> (10) range (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>range [1-3] (10)" + (~> (10) range (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> range [1-3] (5 10)" + (~>> (5 10) range (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> range [1-3] (5 10)" + (~> (5 10) range (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> range [1-3] (5 10 3)" + (~>> (5 10 3) range (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> range [1-3] (5 10 3)" + (~> (5 10 3) range (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 10) [0-2] ()" + (~>> () (range 10) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~> (range 10) [0-2] ()" + (~> () (range 10) (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> (range 5) [0-2] (10)" + (~>> (10) (range 5) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 10) [0-2] (5)" + (~> (5) (range 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 3) [0-2] (5 10)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 5) [0-2] (10 3)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 5 10) [0-1] ()" + (~>> () (range 5 10) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 5 10) [0-1] ()" + (~> () (range 5 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 5 10) [0-1] (3)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 10 3) [0-1] (5)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 5 10 3) [0] ()" + (~>> () (range 5 10 3) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range _) [1] (10)" + (~>> (10) (range _) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>> (range _ _) [2] (5 10)" + (~>> (5 10) (range _ _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ _ _) [3] (5 10 3)" + (~>> (5 10 3) (range _ _ _) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 _) [1] (10)" + (~>> (10) (range 5 _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ 10) [1] (5)" + (~>> (5) (range _ 10) (filter odd?) (map sqr)) + '(25 49 81)) + + (test-equal? "~>> (range 5 _ _) [2] (10 3)" + (~>> (10 3) (range 5 _ _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 _) [2] (5 3)" + (~>> (5 3) (range _ 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ _ 3) [2] (5 10)" + (~>> (5 10) (range _ _ 3) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 10 _) [1] (3)" + (~>> (3) (range 5 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range 5 _ 3) [1] (10)" + (~>> (10) (range 5 _ 3) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 3) [1] (5)" + (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) + '(25)))))) + +(module+ main + (void (run-tests tests))) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 9d9de7689..929c3b3ce 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1554,139 +1554,7 @@ (check-equal? ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") 2) (check-equal? ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") - (list #f 2 #f)))) - (test-suite - "deforestation" - (check-equal? ((☯ (~>> (filter odd?) (map sqr))) - (list 1 2 3 4 5)) - (list 1 9 25)) - (check-exn exn:fail? - (thunk - ((☯ (~> (map sqr) (map sqr))) - (list 1 2 3 4 5))) - "(map) doforestation should only be done for right threading") - (check-exn exn:fail? - (thunk - ((☯ (~> (filter odd?) (filter odd?))) - (list 1 2 3 4 5))) - "(filter) doforestation should only be done for right threading") - (check-exn exn:fail? - (thunk - ((☯ (~>> (filter odd?) (~> (foldr + 0)))) - (list 1 2 3 4 5))) - "(foldr) doforestation should only be done for right threading") - (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) - (list 1 2 3 4 5)) - (list 1 9 25) - "optimizes subexpressions") - (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldr + 0))) - (list 1 2 3 4 5)) - 35) - (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldl + 0))) - (list 1 2 3 4 5)) - 35) - (check-equal? ((☯ (~>> (map string-upcase) (foldr string-append "I"))) - (list "a" "b" "c")) - "ABCI") - (check-equal? ((☯ (~>> (map string-upcase) (foldl string-append "I"))) - (list "a" "b" "c")) - "CBAI") - (check-equal? ((☯ (~>> (range 10) (map sqr) car))) - 0) - ;; Semantic tests of the range producer that cover all combinations: - (test-equal? "~>>range [1-3] (10)" - (~>> (10) range (filter odd?) (map sqr)) - '(1 9 25 49 81)) - (test-equal? "~>range [1-3] (10)" - (~> (10) range (~>> (filter odd?) (map sqr))) - '(1 9 25 49 81)) - (test-equal? "~>> range [1-3] (5 10)" - (~>> (5 10) range (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~> range [1-3] (5 10)" - (~> (5 10) range (~>> (filter odd?) (map sqr))) - '(25 49 81)) - (test-equal? "~>> range [1-3] (5 10 3)" - (~>> (5 10 3) range (filter odd?) (map sqr)) - '(25)) - (test-equal? "~> range [1-3] (5 10 3)" - (~> (5 10 3) range (~>> (filter odd?) (map sqr))) - '(25)) - - (test-equal? "~>> (range 10) [0-2] ()" - (~>> () (range 10) (filter odd?) (map sqr)) - '(1 9 25 49 81)) - (test-equal? "~> (range 10) [0-2] ()" - (~> () (range 10) (~>> (filter odd?) (map sqr))) - '(1 9 25 49 81)) - (test-equal? "~>> (range 5) [0-2] (10)" - (~>> (10) (range 5) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~> (range 10) [0-2] (5)" - (~> (5) (range 10) (~>> (filter odd?) (map sqr))) - '(25 49 81)) - (test-equal? "~>> (range 3) [0-2] (5 10)" - (~>> (3) (range 5 10) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~> (range 5) [0-2] (10 3)" - (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) - '(25)) - - - (test-equal? "~>> (range 5 10) [0-1] ()" - (~>> () (range 5 10) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~> (range 5 10) [0-1] ()" - (~> () (range 5 10) (~>> (filter odd?) (map sqr))) - '(25 49 81)) - (test-equal? "~>> (range 5 10) [0-1] (3)" - (~>> (3) (range 5 10) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~> (range 10 3) [0-1] (5)" - (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) - '(25)) - - (test-equal? "~>> (range 5 10 3) [0] ()" - (~>> () (range 5 10 3) (filter odd?) (map sqr)) - '(25)) - - (test-equal? "~>> (range _) [1] (10)" - (~>> (10) (range _) (filter odd?) (map sqr)) - '(1 9 25 49 81)) - (test-equal? "~>> (range _ _) [2] (5 10)" - (~>> (5 10) (range _ _) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~>> (range _ _ _) [3] (5 10 3)" - (~>> (5 10 3) (range _ _ _) (filter odd?) (map sqr)) - '(25)) - - (test-equal? "~>> (range 5 _) [1] (10)" - (~>> (10) (range 5 _) (filter odd?) (map sqr)) - '(25 49 81)) - (test-equal? "~>> (range _ 10) [1] (5)" - (~>> (5) (range _ 10) (filter odd?) (map sqr)) - '(25 49 81)) - - - (test-equal? "~>> (range 5 _ _) [2] (10 3)" - (~>> (10 3) (range 5 _ _) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range _ 10 _) [2] (5 3)" - (~>> (5 3) (range _ 10 _) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range _ _ 3) [2] (5 10)" - (~>> (5 10) (range _ _ 3) (filter odd?) (map sqr)) - '(25)) - - (test-equal? "~>> (range 5 10 _) [1] (3)" - (~>> (3) (range 5 10 _) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range 5 _ 3) [1] (10)" - (~>> (10) (range 5 _ 3) (filter odd?) (map sqr)) - '(25)) - (test-equal? "~>> (range _ 10 3) [1] (5)" - (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) - '(25)))))) + (list #f 2 #f))))))) (module+ main (void (run-tests tests))) diff --git a/qi-test/tests/qi.rkt b/qi-test/tests/qi.rkt index 7bace1617..26b9c36af 100644 --- a/qi-test/tests/qi.rkt +++ b/qi-test/tests/qi.rkt @@ -24,6 +24,6 @@ util:tests compiler:tests)) -(module+ test +(module+ main (void (run-tests tests))) From 87251e617fc3064e79c7a65ef04f02530c7d9b74 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 30 Nov 2023 14:17:18 -0800 Subject: [PATCH 297/338] avoid division by zero in comparing benchmark results --- qi-sdk/profile/regression.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index 0e1e072b3..ebd4a7022 100644 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -39,7 +39,9 @@ (define-flow calculate-ratio (~> (-< (hash-ref after _) - (hash-ref before _)) + (~> (hash-ref before _) + ;; avoid division by zero + (if (= 0) 1 _))) / (if (< low _ high) 1 From d7a8085c42e9e0d6d0b63733e53cd7c700e2368d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 30 Nov 2023 14:18:18 -0800 Subject: [PATCH 298/338] Make higher benchmark threshold the same ratio as lower one I don't recall if there was a reason why these were different ratios. Maybe it was just what I observed to be useful in practice. But it seems more rigorous to have them be the same. --- qi-sdk/profile/regression.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt index ebd4a7022..20ec8b6c7 100644 --- a/qi-sdk/profile/regression.rkt +++ b/qi-sdk/profile/regression.rkt @@ -12,7 +12,7 @@ racket/pretty) (define LOWER-THRESHOLD 0.75) -(define HIGHER-THRESHOLD 1.5) +(define HIGHER-THRESHOLD 1.33) (define (parse-json-file filename) (call-with-input-file filename From 217c086c3a838f65a31018d0503cd1387ea31ca2 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 30 Nov 2023 18:39:07 -0800 Subject: [PATCH 299/338] Normalization tests and improvements --- qi-lib/flow/core/normalize.rkt | 7 ++- qi-test/tests/compiler/rules.rkt | 96 +++++++++++++++++++++++++------- 2 files changed, 82 insertions(+), 21 deletions(-) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index f55fbcc27..587154a5c 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -17,7 +17,7 @@ #'(thread _0 ... (amp (if f g ground)) _1 ...)] ;; merge amps in sequence [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) - #`(thread _0 ... #,(normalize-rewrite #'(amp (thread f g))) _1 ...)] + #'(thread _0 ... (amp (thread f g)) _1 ...)] ;; merge pass filters in sequence [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) #'(thread _0 ... (pass (and f g)) _1 ...)] @@ -45,9 +45,12 @@ ;; trivial tee junction [((~datum tee) f) #'f] - ;; merge adjacent gens + ;; merge adjacent gens in a tee junction [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) #'(tee _0 ... (gen a ... b ...) _1 ...)] + ;; dead gen elimination + [((~datum thread) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + #'(thread _0 ... (gen b ...) _1 ...)] ;; prism identities ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's ;; only valid if the input is in fact a list, and is an error otherwise, diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index 10d6d1451..ed60cbba9 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -8,14 +8,18 @@ rackunit/text-ui (only-in math sqr) racket/string + syntax/parse + syntax/parse/define (only-in racket/function curryr)) -(define-syntax-rule (test-normalize a b msg) - (check-equal? (syntax->datum - (normalize-pass a)) - (syntax->datum - (normalize-pass b)) - msg)) +(define-syntax-parse-rule (test-normalize msg a b ...+) + (begin + (check-equal? (syntax->datum + (normalize-pass a)) + (syntax->datum + (normalize-pass b)) + msg) + ...)) (define (deforested? exp) (string-contains? (format "~a" exp) "cstream")) @@ -464,19 +468,73 @@ (test-suite "normalization" - (test-normalize #'(thread - (thread (filter odd?) - (map sqr))) - #'(thread (filter odd?) - (map sqr)) - "nested threads are collapsed") - (test-normalize #'(thread values - sqr) - #'(thread sqr) - "values inside threading is elided") - (test-normalize #'(thread sqr) - #'sqr - "trivial threading is collapsed")) + (test-normalize "pass-amp deforestation" + #'(thread + (pass f) + (amp g)) + #'(amp (if f g ground))) + (test-normalize "merge amps in sequence" + #'(thread (amp f) (amp g)) + #'(amp (thread f g))) + (test-normalize "merge pass filters in sequence" + #'(thread (pass f) (pass g)) + #'(pass (and f g))) + (test-normalize "collapse deterministic conditionals" + #'(if #t f g) + #'f) + (test-normalize "collapse deterministic conditionals" + #'(if #f f g) + #'g) + (test-normalize "trivial threading is collapsed" + #'(thread f) + #'f) + (test-normalize "associative laws for ~>" + #'(thread f (thread g h) i) + #'(thread f g (thread h i)) + #'(thread (thread f g) h i) + #'(thread f g h i)) + (test-normalize "left and right identity for ~>" + #'(thread f _) + #'(thread _ f) + #'f) + + (test-normalize "line composition of identity flows" + #'(thread _ _ _) + #'(thread _ _) + #'(thread _) + #'_) + (test-normalize "relay composition of identity flows" + #'(relay _ _ _) + #'(relay _ _) + #'(relay _) + #'_) + (test-normalize "amp under identity" + #'(amp _) + #'_) + (test-normalize "trivial tee junction" + #'(tee f) + #'f) + (test-normalize "merge adjacent gens in a tee junction" + #'(tee (gen a b) (gen c d)) + #'(tee (gen a b c d))) + (test-normalize "remove dead gen in a line" + #'(thread (gen a b) (gen c d)) + #'(thread (gen c d))) + (test-normalize "prism identities" + #'(thread collect sep) + #'_) + (test-normalize "redundant blanket template" + #'(#%blanket-template (f __)) + #'f) + (test-normalize "values is collapsed inside ~>" + #'(thread values f values) + #'(thread f)) + (test-normalize "_ is collapsed inside ~>" + #'(thread _ f _) + #'(thread f)) + (test-normalize "consecutive amps are combined" + #'(thread (amp f) (amp g)) + #'(thread (amp (thread f g))))) (test-suite "compilation sequences" From e84b8dd7e5d910a7c579af27949406079711a99d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 30 Nov 2023 18:56:17 -0800 Subject: [PATCH 300/338] remove old comment which I think has been addressed --- qi-lib/flow/core/normalize.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index 587154a5c..ade9cd90f 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -9,7 +9,6 @@ ;; 0. "Qi-normal form" (define (normalize-rewrite stx) - ;; TODO: eliminate outdated rules here (syntax-parse stx ;; "deforestation" for values ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) From 6ed69a437ab98e25fd1659eb14fb07bf650811cc Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 6 Dec 2023 01:07:04 -0700 Subject: [PATCH 301/338] add a basic threading test --- qi-test/tests/flow.rkt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 929c3b3ce..7dcdf9fb6 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -436,6 +436,10 @@ "routing forms" (test-suite "~>" + (test-equal? "basic threading" + ((☯ (~> sqr add1)) + 3) + 10) (check-equal? ((☯ (~> add1 (* 2) number->string From c6c724f0f8835949248ac06d5ae63b25fc0a7002 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 6 Dec 2023 01:07:34 -0700 Subject: [PATCH 302/338] remove outdated todo (again?) --- qi-lib/flow/aux-syntax.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index c91512454..e5cf653a4 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -10,7 +10,6 @@ (define-syntax-class literal (pattern - ;; TODO: would be ideal to also match literal vectors, boxes and prefabs (~or* expr:boolean expr:char expr:string From a4051efbce7d23ef3c1beda4f4702de57156473a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 6 Dec 2023 01:47:03 -0700 Subject: [PATCH 303/338] move general and debugging-related functions into their own modules --- qi-lib/flow/core/compiler.rkt | 57 ++------------------------------ qi-lib/flow/core/debug.rkt | 22 ++++++++++++ qi-lib/flow/core/util.rkt | 41 +++++++++++++++++++++++ qi-test/tests/compiler.rkt | 6 ++-- qi-test/tests/compiler/rules.rkt | 13 ++------ qi-test/tests/compiler/util.rkt | 24 ++++++++++++++ 6 files changed, 96 insertions(+), 67 deletions(-) create mode 100644 qi-lib/flow/core/debug.rkt create mode 100644 qi-lib/flow/core/util.rkt create mode 100644 qi-test/tests/compiler/util.rkt diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index e60655f93..808479601 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -1,8 +1,7 @@ #lang racket/base (provide (for-syntax compile-flow - normalize-pass - fix)) + normalize-pass)) (require (for-syntax racket/base syntax/parse @@ -10,7 +9,8 @@ (only-in racket/list make-list) "syntax.rkt" "../aux-syntax.rkt" - macro-debugger/emit) + "util.rkt" + "debug.rkt") "impl.rkt" (only-in racket/list make-list) racket/function @@ -22,42 +22,11 @@ (begin-for-syntax - ;; currently does not distinguish substeps of a parent expansion step - (define-syntax-rule (qi-expansion-step name stx0 stx1) - (let () - (emit-local-step stx0 stx1 #:id #'name) - stx1)) - - ;; TODO: move this to a common utils module for use in all - ;; modules implementing optimization passes - ;; Also, resolve - ;; "syntax-local-expand-observer: not currently expanding" - ;; issue encountered in running compiler unit tests - (define-syntax-rule (define-qi-expansion-step (name stx0) - body ...) - (define (name stx0) - (let ([stx1 (let () body ...)]) - (qi-expansion-step name stx0 stx1)))) - ;; note: this does not return compiled code but instead, ;; syntax whose expansion compiles the code (define (compile-flow stx) (process-bindings (optimize-flow stx))) - ;; Applies f repeatedly to the init-val terminating the loop if the - ;; result of f is #f or the new syntax object is eq? to the previous - ;; (possibly initial) one. - ;; - ;; Caveats: - ;; * the syntax object is not inspected, only eq? is used - ;; * comparison is performed only between consecutive steps (does not handle cyclic occurences) - (define ((fix f) init-val) - (let ([new-val (f init-val)]) - (if (or (not new-val) - (eq? new-val init-val)) - init-val - ((fix f) new-val)))) - (define (deforest-pass stx) ;; Note: deforestation happens only for threading, ;; and the normalize pass strips the threading form @@ -103,26 +72,6 @@ (begin-for-syntax - (define (find-and-map f stx) - ;; f : syntax? -> (or/c syntax? #f) - (match stx - [(? syntax?) (let ([stx^ (f stx)]) - (or stx^ (datum->syntax stx - (find-and-map f (syntax-e stx)) - stx - stx)))] - [(cons a d) (cons (find-and-map f a) - (find-and-map f d))] - [_ stx])) - - (define (find-and-map/qi f stx) - ;; #%host-expression is a Racket macro defined by syntax-spec - ;; that resumes expansion of its sub-expression with an - ;; expander environment containing the original surface bindings - (find-and-map (syntax-parser [((~datum #%host-expression) e:expr) this-syntax] - [_ (f this-syntax)]) - stx)) - ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) ;; TODO: use a box instead of set! (define (rewrite-all-bindings stx) diff --git a/qi-lib/flow/core/debug.rkt b/qi-lib/flow/core/debug.rkt new file mode 100644 index 000000000..fd5b0e926 --- /dev/null +++ b/qi-lib/flow/core/debug.rkt @@ -0,0 +1,22 @@ +#lang racket/base + +(provide qi-expansion-step + define-qi-expansion-step) + +(require macro-debugger/emit) + +;; These macros emit expansion "events" that allow the macro +;; stepper to report stages in the expansion of an expression, +;; giving us visibility into this process for debugging purposes. +;; Note that this currently does not distinguish substeps +;; of a parent expansion step. +(define-syntax-rule (qi-expansion-step name stx0 stx1) + (let () + (emit-local-step stx0 stx1 #:id #'name) + stx1)) + +(define-syntax-rule (define-qi-expansion-step (name stx0) + body ...) + (define (name stx0) + (let ([stx1 (let () body ...)]) + (qi-expansion-step name stx0 stx1)))) diff --git a/qi-lib/flow/core/util.rkt b/qi-lib/flow/core/util.rkt new file mode 100644 index 000000000..2466c7e3d --- /dev/null +++ b/qi-lib/flow/core/util.rkt @@ -0,0 +1,41 @@ +#lang racket/base + +(provide find-and-map/qi + fix) + +(require racket/match + syntax/parse) + +(define (find-and-map f stx) + ;; f : syntax? -> (or/c syntax? #f) + (match stx + [(? syntax?) (let ([stx^ (f stx)]) + (or stx^ (datum->syntax stx + (find-and-map f (syntax-e stx)) + stx + stx)))] + [(cons a d) (cons (find-and-map f a) + (find-and-map f d))] + [_ stx])) + +(define (find-and-map/qi f stx) + ;; #%host-expression is a Racket macro defined by syntax-spec + ;; that resumes expansion of its sub-expression with an + ;; expander environment containing the original surface bindings + (find-and-map (syntax-parser [((~datum #%host-expression) e:expr) this-syntax] + [_ (f this-syntax)]) + stx)) + +;; Applies f repeatedly to the init-val terminating the loop if the +;; result of f is #f or the new syntax object is eq? to the previous +;; (possibly initial) one. +;; +;; Caveats: +;; * the syntax object is not inspected, only eq? is used +;; * comparison is performed only between consecutive steps (does not handle cyclic occurences) +(define ((fix f) init-val) + (let ([new-val (f init-val)]) + (if (or (not new-val) + (eq? new-val init-val)) + init-val + ((fix f) new-val)))) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt index 1da8a0979..99a400d65 100644 --- a/qi-test/tests/compiler.rkt +++ b/qi-test/tests/compiler.rkt @@ -5,14 +5,16 @@ (require rackunit rackunit/text-ui (prefix-in semantics: "compiler/semantics.rkt") - (prefix-in rules: "compiler/rules.rkt")) + (prefix-in rules: "compiler/rules.rkt") + (prefix-in util: "compiler/util.rkt")) (define tests (test-suite "compiler tests" semantics:tests - rules:tests)) + rules:tests + util:tests)) (module+ main (void diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index ed60cbba9..ecf4f262c 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -8,9 +8,7 @@ rackunit/text-ui (only-in math sqr) racket/string - syntax/parse - syntax/parse/define - (only-in racket/function curryr)) + syntax/parse/define) (define-syntax-parse-rule (test-normalize msg a b ...+) (begin @@ -27,15 +25,8 @@ (define tests (test-suite - "compiler tests" + "Compiler rule tests" - (test-suite - "fixed point" - (check-equal? ((fix abs) -1) 1) - (check-equal? ((fix abs) -1) 1) - (let ([integer-div2 (compose floor (curryr / 2))]) - (check-equal? ((fix integer-div2) 10) - 0))) (test-suite "deforestation" ;; Note that these test deforestation in isolation diff --git a/qi-test/tests/compiler/util.rkt b/qi-test/tests/compiler/util.rkt new file mode 100644 index 000000000..7977483c1 --- /dev/null +++ b/qi-test/tests/compiler/util.rkt @@ -0,0 +1,24 @@ +#lang racket/base + +(provide tests) + +(require qi/flow/core/util + rackunit + rackunit/text-ui + (only-in racket/function + curryr)) + +(define tests + (test-suite + "Compiler utilities tests" + + (test-suite + "fixed point" + (check-equal? ((fix abs) -1) 1) + (check-equal? ((fix abs) -1) 1) + (let ([integer-div2 (compose floor (curryr / 2))]) + (check-equal? ((fix integer-div2) 10) + 0))))) + +(module+ main + (void (run-tests tests))) From 0254fbfc29298436ecb9ef0de0a7f74731b65ca4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 6 Dec 2023 02:19:20 -0700 Subject: [PATCH 304/338] simplify definitions and imports across phases --- qi-lib/flow/core/compiler.rkt | 8 +- qi-lib/flow/core/deforest.rkt | 598 ++++++++++++++++----------------- qi-lib/flow/core/normalize.rkt | 123 ++++--- 3 files changed, 361 insertions(+), 368 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 808479601..223f5e909 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -10,15 +10,15 @@ "syntax.rkt" "../aux-syntax.rkt" "util.rkt" - "debug.rkt") + "debug.rkt" + "normalize.rkt" + "deforest.rkt") "impl.rkt" (only-in racket/list make-list) racket/function racket/undefined (prefix-in fancy: fancy-app) - racket/list - "deforest.rkt" - "normalize.rkt") + racket/list) (begin-for-syntax diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 1c4b5490b..ba43520a7 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -1,10 +1,10 @@ #lang racket/base -(provide (for-syntax deforest-rewrite)) +(provide deforest-rewrite) -(require (for-syntax racket/base - syntax/parse - racket/syntax-srcloc) +(require (for-syntax racket/base) + syntax/parse + racket/syntax-srcloc racket/performance-hint racket/match racket/list @@ -25,308 +25,304 @@ [(_ f) f] [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) -(begin-for-syntax - - ;; Partially reconstructs original flow expressions. The chirality - ;; is lost and the form is already normalized at this point though! - (define (prettify-flow-syntax stx) - (syntax-parse stx - #:datum-literals (#%host-expression esc #%blanket-template #%fine-template) - (((~literal thread) - expr ...) - #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))) - (((~or #%blanket-template #%fine-template) - (expr ...)) - (map prettify-flow-syntax (syntax->list #'(expr ...)))) - ((#%host-expression expr) #'expr) - ((esc expr) (prettify-flow-syntax #'expr)) - (expr #'expr))) - - ;; Special "curry"ing for #%fine-templates. All #%host-expressions - ;; are passed as they are and all (~datum _) are replaced by wrapper - ;; lambda arguments. - (define ((make-fine-curry argstx minargs maxargs form-stx) ctx name) - (define argstxlst (syntax->list argstx)) - (define numargs (length argstxlst)) - (cond ((< numargs minargs) - (raise-syntax-error (syntax->datum name) - (format "too few arguments - given ~a - accepts at least ~a" - numargs minargs) - (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx))) - ((> numargs maxargs) +;; Partially reconstructs original flow expressions. The chirality +;; is lost and the form is already normalized at this point though! +(define (prettify-flow-syntax stx) + (syntax-parse stx + #:datum-literals (#%host-expression esc #%blanket-template #%fine-template) + (((~literal thread) + expr ...) + #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))) + (((~or #%blanket-template #%fine-template) + (expr ...)) + (map prettify-flow-syntax (syntax->list #'(expr ...)))) + ((#%host-expression expr) #'expr) + ((esc expr) (prettify-flow-syntax #'expr)) + (expr #'expr))) + +;; Special "curry"ing for #%fine-templates. All #%host-expressions +;; are passed as they are and all (~datum _) are replaced by wrapper +;; lambda arguments. +(define ((make-fine-curry argstx minargs maxargs form-stx) ctx name) + (define argstxlst (syntax->list argstx)) + (define numargs (length argstxlst)) + (cond ((< numargs minargs) + (raise-syntax-error (syntax->datum name) + (format "too few arguments - given ~a - accepts at least ~a" + numargs minargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))) + ((> numargs maxargs) + (raise-syntax-error (syntax->datum name) + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx)))) + (define temporaries (generate-temporaries argstxlst)) + (define-values (allargs tmpargs) + (for/fold ((all '()) + (tmps '()) + #:result (values (reverse all) + (reverse tmps))) + ((tmp (in-list temporaries)) + (arg (in-list argstxlst))) + (syntax-parse arg + #:datum-literals (#%host-expression) + ((#%host-expression ex) + (values (cons #'ex all) + tmps)) + ((~datum _) + (values (cons tmp all) + (cons tmp tmps)))))) + (with-syntax (((carg ...) tmpargs) + ((aarg ...) allargs)) + #'(λ (proc) + (λ (carg ...) + (proc aarg ...))))) + +;; Special curry for #%blanket-template. Raises syntax error if +;; there are too many arguments. If the number of arguments is +;; exactly the maximum, wraps into lambda without any arguments. If +;; less than maximum, curries it from both left and right. +(define ((make-blanket-curry prestx poststx maxargs form-stx) ctx name) + (define prelst (syntax->list prestx)) + (define postlst (syntax->list poststx)) + (define numargs (+ (length prelst) (length postlst))) + (with-syntax (((pre-arg ...) prelst) + ((post-arg ...) postlst)) + (cond ((> numargs maxargs) (raise-syntax-error (syntax->datum name) (format "too many arguments - given ~a - accepts at most ~a" numargs maxargs) (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx)))) - (define temporaries (generate-temporaries argstxlst)) - (define-values (allargs tmpargs) - (for/fold ((all '()) - (tmps '()) - #:result (values (reverse all) - (reverse tmps))) - ((tmp (in-list temporaries)) - (arg (in-list argstxlst))) - (syntax-parse arg - #:datum-literals (#%host-expression) - ((#%host-expression ex) - (values (cons #'ex all) - tmps)) - ((~datum _) - (values (cons tmp all) - (cons tmp tmps)))))) - (with-syntax (((carg ...) tmpargs) - ((aarg ...) allargs)) - #'(λ (proc) - (λ (carg ...) - (proc aarg ...))))) - - ;; Special curry for #%blanket-template. Raises syntax error if - ;; there are too many arguments. If the number of arguments is - ;; exactly the maximum, wraps into lambda without any arguments. If - ;; less than maximum, curries it from both left and right. - (define ((make-blanket-curry prestx poststx maxargs form-stx) ctx name) - (define prelst (syntax->list prestx)) - (define postlst (syntax->list poststx)) - (define numargs (+ (length prelst) (length postlst))) - (with-syntax (((pre-arg ...) prelst) - ((post-arg ...) postlst)) - (cond ((> numargs maxargs) - (raise-syntax-error (syntax->datum name) - (format "too many arguments - given ~a - accepts at most ~a" - numargs maxargs) - (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx))) - ((= numargs maxargs) - #'(λ (v) - (λ () - (v pre-arg ... post-arg ...)))) - (else - #'(λ (v) - (λ rest - (apply v pre-arg ... - (append rest - (list post-arg ...))))))))) - - ;; Unifying producer curry makers. The ellipsis escaping allows for - ;; simple specification of pattern variable names as bound in the - ;; syntax pattern. - (define-syntax make-producer-curry - (syntax-rules () - ((_ min-args max-args - blanket? pre-arg post-arg - fine? arg - form-stx) - (cond - ((attribute blanket?) - (make-blanket-curry #'(pre-arg (... ...)) - #'(post-arg (... ...)) - max-args - #'form-stx - )) - ((attribute fine?) - (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)) - (else - (λ (ctx name) #'(λ (v) v))))))) - - ;; Used for producing the stream from particular - ;; expressions. Implicit producer is list->cstream-next and it is - ;; not created by using this class but rather explicitly used when - ;; no syntax class producer is matched. - (define-syntax-class fusable-stream-producer - #:attributes (next prepare contract name curry) - #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) - ;; Explicit range producers. - (pattern (~and (~or (esc (#%host-expression (~literal range))) - (~and (#%fine-template - ((#%host-expression (~literal range)) - arg ...)) - fine?) - (~and (#%blanket-template - ((#%host-expression (~literal range)) - (#%host-expression pre-arg) ... - __ - (#%host-expression post-arg) ...)) - blanket?)) - form-stx) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare - #:attr contract #'(->* (real?) (real? real?) any) - #:attr name #'range - #:attr curry (make-producer-curry 1 3 - blanket? pre-arg post-arg - fine? arg - form-stx)) - - ;; The implicit stream producer from plain list. - (pattern (~literal list->cstream) - #:attr next #'list->cstream-next - #:attr prepare #'list->cstream-prepare - #:attr contract #'(-> list? any) - #:attr name #''list->cstream - #:attr curry (λ (ctx name) #'(λ (v) v)))) - - ;; Matches any stream transformer that can be in the head position - ;; of the fused sequence even when there is no explicit - ;; producer. Procedures accepting variable number of arguments like - ;; `map` cannot be in this class. - (define-syntax-class fusable-stream-transformer0 - #:attributes (f next) - #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) - (pattern (~or (#%blanket-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - _))) - #:attr next #'filter-cstream-next)) - - ;; All implemented stream transformers - within the stream, only - ;; single value is being passed and therefore procedures like `map` - ;; can (and should) be matched. - (define-syntax-class fusable-stream-transformer - #:attributes (f next) - #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) - (pattern (~or (#%blanket-template - ((#%host-expression (~literal map)) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~literal map)) - (#%host-expression f) - _))) - #:attr next #'map-cstream-next) - - (pattern (~or (#%blanket-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - _))) - #:attr next #'filter-cstream-next)) - - ;; Terminates the fused sequence (consumes the stream) and produces - ;; an actual result value. - (define-syntax-class fusable-stream-consumer - #:attributes (end) - #:datum-literals (#%host-expression #%blanket-template _ __ #%fine-template esc) - (pattern (~or (#%blanket-template - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init) - __)) - (#%fine-template - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init) - _))) - #:attr end #'(foldr-cstream-next op init)) - - (pattern (~or (#%blanket-template - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init) - __)) - (#%fine-template - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init) - _))) - #:attr end #'(foldl-cstream-next op init)) - - (pattern (~or (esc (#%host-expression (~literal car))) - (#%fine-template - ((#%host-expression (~literal car)) - _)) - (#%blanket-template - ((#%host-expression (~literal car)) - __))) - #:attr end #'(car-cstream-next)) - - (pattern (~literal cstream->list) - #:attr end #'(cstream-next->list))) - - ;; Used only in deforest-rewrite to properly recognize the end of - ;; fusable sequence. - (define-syntax-class non-fusable - (pattern (~not (~or _:fusable-stream-transformer - _:fusable-stream-producer - _:fusable-stream-consumer)))) - - ;; Generates a syntax for the fused operation for given - ;; sequence. The syntax list must already be in the following form: - ;; (producer transformer ... consumer) - (define (generate-fused-operation ops ctx) - (syntax-parse (reverse ops) - [(c:fusable-stream-consumer - t:fusable-stream-transformer ... - p:fusable-stream-producer) - ;; A static runtime contract is placed at the beginning of the - ;; fused sequence. And runtime checks for consumers are in - ;; their respective implementation procedure. - #`(esc - (#,((attribute p.curry) ctx (attribute p.name)) - (contract p.contract - (p.prepare - (#,@#'c.end - (inline-compose1 [t.next t.f] ... - p.next) - '#,(prettify-flow-syntax ctx) - #,(syntax-srcloc ctx))) - p.name + (prettify-flow-syntax form-stx))) + ((= numargs maxargs) + #'(λ (v) + (λ () + (v pre-arg ... post-arg ...)))) + (else + #'(λ (v) + (λ rest + (apply v pre-arg ... + (append rest + (list post-arg ...))))))))) + +;; Unifying producer curry makers. The ellipsis escaping allows for +;; simple specification of pattern variable names as bound in the +;; syntax pattern. +(define-syntax make-producer-curry + (syntax-rules () + ((_ min-args max-args + blanket? pre-arg post-arg + fine? arg + form-stx) + (cond + ((attribute blanket?) + (make-blanket-curry #'(pre-arg (... ...)) + #'(post-arg (... ...)) + max-args + #'form-stx + )) + ((attribute fine?) + (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)) + (else + (λ (ctx name) #'(λ (v) v))))))) + +;; Used for producing the stream from particular +;; expressions. Implicit producer is list->cstream-next and it is +;; not created by using this class but rather explicitly used when +;; no syntax class producer is matched. +(define-syntax-class fusable-stream-producer + #:attributes (next prepare contract name curry) + #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) + ;; Explicit range producers. + (pattern (~and (~or (esc (#%host-expression (~literal range))) + (~and (#%fine-template + ((#%host-expression (~literal range)) + arg ...)) + fine?) + (~and (#%blanket-template + ((#%host-expression (~literal range)) + (#%host-expression pre-arg) ... + __ + (#%host-expression post-arg) ...)) + blanket?)) + form-stx) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-prepare + #:attr contract #'(->* (real?) (real? real?) any) + #:attr name #'range + #:attr curry (make-producer-curry 1 3 + blanket? pre-arg post-arg + fine? arg + form-stx)) + + ;; The implicit stream producer from plain list. + (pattern (~literal list->cstream) + #:attr next #'list->cstream-next + #:attr prepare #'list->cstream-prepare + #:attr contract #'(-> list? any) + #:attr name #''list->cstream + #:attr curry (λ (ctx name) #'(λ (v) v)))) + +;; Matches any stream transformer that can be in the head position +;; of the fused sequence even when there is no explicit +;; producer. Procedures accepting variable number of arguments like +;; `map` cannot be in this class. +(define-syntax-class fusable-stream-transformer0 + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + +;; All implemented stream transformers - within the stream, only +;; single value is being passed and therefore procedures like `map` +;; can (and should) be matched. +(define-syntax-class fusable-stream-transformer + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~literal map)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~literal map)) + (#%host-expression f) + _))) + #:attr next #'map-cstream-next) + + (pattern (~or (#%blanket-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~literal filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + +;; Terminates the fused sequence (consumes the stream) and produces +;; an actual result value. +(define-syntax-class fusable-stream-consumer + #:attributes (end) + #:datum-literals (#%host-expression #%blanket-template _ __ #%fine-template esc) + (pattern (~or (#%blanket-template + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~literal foldr)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldr-cstream-next op init)) + + (pattern (~or (#%blanket-template + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~literal foldl)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldl-cstream-next op init)) + + (pattern (~or (esc (#%host-expression (~literal car))) + (#%fine-template + ((#%host-expression (~literal car)) + _)) + (#%blanket-template + ((#%host-expression (~literal car)) + __))) + #:attr end #'(car-cstream-next)) + + (pattern (~literal cstream->list) + #:attr end #'(cstream-next->list))) + +;; Used only in deforest-rewrite to properly recognize the end of +;; fusable sequence. +(define-syntax-class non-fusable + (pattern (~not (~or _:fusable-stream-transformer + _:fusable-stream-producer + _:fusable-stream-consumer)))) + +;; Generates a syntax for the fused operation for given +;; sequence. The syntax list must already be in the following form: +;; (producer transformer ... consumer) +(define (generate-fused-operation ops ctx) + (syntax-parse (reverse ops) + [(c:fusable-stream-consumer + t:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; A static runtime contract is placed at the beginning of the + ;; fused sequence. And runtime checks for consumers are in + ;; their respective implementation procedure. + #`(esc + (#,((attribute p.curry) ctx (attribute p.name)) + (contract p.contract + (p.prepare + (#,@#'c.end + (inline-compose1 [t.next t.f] ... + p.next) '#,(prettify-flow-syntax ctx) - #f - #,(syntax-srcloc ctx))))])) - - ;; Performs one step of deforestation rewrite. Should be used as - ;; many times as needed - until it returns the source syntax - ;; unchanged. - (define (deforest-rewrite stx) - (syntax-parse stx - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - ;; There can be zero transformers here: - t:fusable-stream-transformer ... - c:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - t1:fusable-stream-transformer0 - t:fusable-stream-transformer ... - c:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream t1 t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - ;; Must be 1 or more transformers here: - t:fusable-stream-transformer ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - f1:fusable-stream-transformer0 - f:fusable-stream-transformer ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream f1 f ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - [_ this-syntax])) - - ) + #,(syntax-srcloc ctx))) + p.name + '#,(prettify-flow-syntax ctx) + #f + #,(syntax-srcloc ctx))))])) + +;; Performs one step of deforestation rewrite. Should be used as +;; many times as needed - until it returns the source syntax +;; unchanged. +(define (deforest-rewrite stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; There can be zero transformers here: + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fusable-stream-transformer0 + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; Must be 1 or more transformers here: + t:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [_ this-syntax])) (begin-encourage-inline diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index ade9cd90f..bda0ba15f 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -1,67 +1,64 @@ #lang racket/base -(provide (for-syntax normalize-rewrite)) +(provide normalize-rewrite) -(require (for-syntax racket/base - syntax/parse)) +(require syntax/parse) -(begin-for-syntax - - ;; 0. "Qi-normal form" - (define (normalize-rewrite stx) - (syntax-parse stx - ;; "deforestation" for values - ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) - [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) - #'(thread _0 ... (amp (if f g ground)) _1 ...)] - ;; merge amps in sequence - [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) - #'(thread _0 ... (amp (thread f g)) _1 ...)] - ;; merge pass filters in sequence - [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) - #'(thread _0 ... (pass (and f g)) _1 ...)] - ;; collapse deterministic conditionals - [((~datum if) (~datum #t) f g) #'f] - [((~datum if) (~datum #f) f g) #'g] - ;; trivial threading form - [((~datum thread) f) - #'f] - ;; associative laws for ~> - [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) ; note: greedy matching - #'(thread _0 ... f ... _1 ...)] - ;; left and right identity for ~> - [((~datum thread) _0 ... (~datum _) _1 ...) - #'(thread _0 ... _1 ...)] - ;; composition of identity flows is the identity flow - [((~datum thread) (~datum _) ...) - #'_] - ;; identity flows composed using a relay - [((~datum relay) (~datum _) ...) - #'_] - ;; amp and identity - [((~datum amp) (~datum _)) - #'_] - ;; trivial tee junction - [((~datum tee) f) - #'f] - ;; merge adjacent gens in a tee junction - [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) - #'(tee _0 ... (gen a ... b ...) _1 ...)] - ;; dead gen elimination - [((~datum thread) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) - #'(thread _0 ... (gen b ...) _1 ...)] - ;; prism identities - ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's - ;; only valid if the input is in fact a list, and is an error otherwise, - ;; and we can only know this at runtime. - [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) - #'(thread _0 ... _1 ...)] - ;; collapse `values` and `_` inside a threading form - [((~datum thread) _0 ... (~literal values) _1 ...) - #'(thread _0 ... _1 ...)] - [((~datum thread) _0 ... (~datum _) _1 ...) - #'(thread _0 ... _1 ...)] - [((~datum #%blanket-template) (hex (~datum __))) - #'hex] - ;; return syntax unchanged if there are no applicable normalizations - [_ stx]))) +;; 0. "Qi-normal form" +(define (normalize-rewrite stx) + (syntax-parse stx + ;; "deforestation" for values + ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) + [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) + #'(thread _0 ... (amp (if f g ground)) _1 ...)] + ;; merge amps in sequence + [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) + #'(thread _0 ... (amp (thread f g)) _1 ...)] + ;; merge pass filters in sequence + [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) + #'(thread _0 ... (pass (and f g)) _1 ...)] + ;; collapse deterministic conditionals + [((~datum if) (~datum #t) f g) #'f] + [((~datum if) (~datum #f) f g) #'g] + ;; trivial threading form + [((~datum thread) f) + #'f] + ;; associative laws for ~> + [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) ; note: greedy matching + #'(thread _0 ... f ... _1 ...)] + ;; left and right identity for ~> + [((~datum thread) _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] + ;; composition of identity flows is the identity flow + [((~datum thread) (~datum _) ...) + #'_] + ;; identity flows composed using a relay + [((~datum relay) (~datum _) ...) + #'_] + ;; amp and identity + [((~datum amp) (~datum _)) + #'_] + ;; trivial tee junction + [((~datum tee) f) + #'f] + ;; merge adjacent gens in a tee junction + [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + #'(tee _0 ... (gen a ... b ...) _1 ...)] + ;; dead gen elimination + [((~datum thread) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + #'(thread _0 ... (gen b ...) _1 ...)] + ;; prism identities + ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's + ;; only valid if the input is in fact a list, and is an error otherwise, + ;; and we can only know this at runtime. + [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) + #'(thread _0 ... _1 ...)] + ;; collapse `values` and `_` inside a threading form + [((~datum thread) _0 ... (~literal values) _1 ...) + #'(thread _0 ... _1 ...)] + [((~datum thread) _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] + [((~datum #%blanket-template) (hex (~datum __))) + #'hex] + ;; return syntax unchanged if there are no applicable normalizations + [_ stx])) From ccb756325517a720490641b46dd4b5972f4c689e Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 6 Dec 2023 02:20:07 -0700 Subject: [PATCH 305/338] fix literal `range` in tests --- qi-test/tests/compiler/rules.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index ecf4f262c..9f28e5ca8 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -2,12 +2,14 @@ (provide tests) -(require (for-template qi/flow/core/deforest - qi/flow/core/compiler) +(require (for-template qi/flow/core/compiler) + qi/flow/core/deforest rackunit rackunit/text-ui (only-in math sqr) racket/string + (only-in racket/list + range) syntax/parse/define) (define-syntax-parse-rule (test-normalize msg a b ...+) From d9082bdba3ded0d6f1d25bd05f5b617ec278d001 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 7 Dec 2023 02:50:46 -0700 Subject: [PATCH 306/338] declare macro-debugger dependency --- qi-lib/info.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index c72a9c099..a8b349bd6 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -4,7 +4,8 @@ (define collection "qi") (define deps '("base" ("fancy-app" #:version "1.1") - "syntax-spec-v1")) + "syntax-spec-v1" + "macro-debugger")) (define build-deps '()) (define clean '("compiled" "private/compiled")) (define pkg-authors '(countvajhula)) From 3900217a81e03fb873cc762a6e0694a3475347dc Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 11:52:45 -0700 Subject: [PATCH 307/338] use test-equal? in test-normalize --- qi-test/tests/compiler/rules.rkt | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index 9f28e5ca8..43f7ca101 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -12,13 +12,13 @@ range) syntax/parse/define) -(define-syntax-parse-rule (test-normalize msg a b ...+) +(define-syntax-parse-rule (test-normalize name a b ...+) (begin - (check-equal? (syntax->datum - (normalize-pass a)) - (syntax->datum - (normalize-pass b)) - msg) + (test-equal? name + (syntax->datum + (normalize-pass a)) + (syntax->datum + (normalize-pass b))) ...)) (define (deforested? exp) From 56d3a2e03f38d6fb899e548061942a8f00b96187 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 12:03:47 -0700 Subject: [PATCH 308/338] unit tests for `find-and-map/qi` --- qi-lib/flow/core/util.rkt | 8 +++++ qi-test/tests/compiler/util.rkt | 60 ++++++++++++++++++++++++++++++++- 2 files changed, 67 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/util.rkt b/qi-lib/flow/core/util.rkt index 2466c7e3d..92ee671d2 100644 --- a/qi-lib/flow/core/util.rkt +++ b/qi-lib/flow/core/util.rkt @@ -6,6 +6,12 @@ (require racket/match syntax/parse) +;; Walk the syntax tree in a "top down" manner, i.e. from the root down +;; to the leaves, applying a transformation to each node. The +;; transforming function is expected to either return the transformed +;; syntax or false. The traversal terminates in the former case (i.e. it +;; does not traverse the transformed expression to look for further +;; matches), and continues in the latter case. (define (find-and-map f stx) ;; f : syntax? -> (or/c syntax? #f) (match stx @@ -18,6 +24,8 @@ (find-and-map f d))] [_ stx])) +;; A thin wrapper around find-and-map that does not traverse subexpressions +;; that are tagged as host language (rather than Qi) expressions (define (find-and-map/qi f stx) ;; #%host-expression is a Racket macro defined by syntax-spec ;; that resumes expansion of its sub-expression with an diff --git a/qi-test/tests/compiler/util.rkt b/qi-test/tests/compiler/util.rkt index 7977483c1..645469835 100644 --- a/qi-test/tests/compiler/util.rkt +++ b/qi-test/tests/compiler/util.rkt @@ -5,9 +5,15 @@ (require qi/flow/core/util rackunit rackunit/text-ui + syntax/parse (only-in racket/function curryr)) +(define-syntax-rule (test-syntax-equal? name a b) + (test-equal? name + (syntax->datum a) + (syntax->datum b))) + (define tests (test-suite "Compiler utilities tests" @@ -18,7 +24,59 @@ (check-equal? ((fix abs) -1) 1) (let ([integer-div2 (compose floor (curryr / 2))]) (check-equal? ((fix integer-div2) 10) - 0))))) + 0))) + (test-suite + "find-and-map/qi" + (test-syntax-equal? "top level" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a b c)) + #'(a q c)) + (test-syntax-equal? "nested" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a (b c) d)) + #'(a (q c) d)) + (test-syntax-equal? "multiple matches" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a b c b d)) + #'(a q c q d)) + (test-syntax-equal? "multiple nested matches" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a (b c) (b d))) + #'(a (q c) (q d))) + (test-syntax-equal? "no match" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a c d)) + #'(a c d)) + ;; TODO: review this, it does not transform multi-level matches. + ;; Are there cases where we would need this? + (test-syntax-equal? "matches at muliple levels" + (find-and-map/qi + (syntax-parser [((~datum a) b ...) #'(b ...)] + [_ #f]) + #'(a c (a d e))) + #'(c (a d e))) + (test-syntax-equal? "does not enter host expressions" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a (#%host-expression (b c)) d)) + #'(a (#%host-expression (b c)) d)) + (test-syntax-equal? "toplevel host expression" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(#%host-expression (b c))) + #'(#%host-expression (b c)))))) (module+ main (void (run-tests tests))) From be03431c9012858ca6c9de78edc6de2a16c717c9 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 12:37:15 -0700 Subject: [PATCH 309/338] organize high level compilation sequence more clearly --- qi-lib/flow/core/compiler.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 223f5e909..c11160598 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -25,7 +25,9 @@ ;; note: this does not return compiled code but instead, ;; syntax whose expansion compiles the code (define (compile-flow stx) - (process-bindings (optimize-flow stx))) + (process-bindings + #`(qi0->racket + #,(optimize-flow stx)))) (define (deforest-pass stx) ;; Note: deforestation happens only for threading, @@ -101,7 +103,7 @@ ;; TODO: use syntax-parse and match ~> specifically. ;; Since macros are expanded "outside in," presumably ;; it will naturally wrap the outermost ~> - (wrap-with-scopes #`(qi0->racket #,(rewrite-all-bindings stx)) + (wrap-with-scopes (rewrite-all-bindings stx) (bound-identifiers stx)))) (define-syntax (qi0->racket stx) From cda184e662bccfb0d8dcb163316d8ba8d392fa47 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 13:37:45 -0700 Subject: [PATCH 310/338] "fix" bad test --- qi-test/tests/compiler/rules.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index 43f7ca101..ad9aa98f3 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -47,13 +47,13 @@ stx))) "does not deforest single stream component in isolation")) (let ([stx #'(thread - #%blanket-template - ((#%host-expression map) - (#%host-expression sqr) - __) - ((#%host-expression filter) - (#%host-expression odd?) - __))]) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __) + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) (check-false (deforested? (syntax->datum (deforest-rewrite stx))) From ee1de0a645f34ac148f56edd14c380114ed35b92 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 19:28:00 -0700 Subject: [PATCH 311/338] simplify some definitions --- qi-lib/flow/core/deforest.rkt | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index ba43520a7..cef0de411 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -2,8 +2,7 @@ (provide deforest-rewrite) -(require (for-syntax racket/base) - syntax/parse +(require syntax/parse racket/syntax-srcloc racket/performance-hint racket/match @@ -12,8 +11,8 @@ ;; These bindings are used for ~literal matching to introduce implicit ;; producer/consumer when none is explicitly given in the flow. -(define-syntax cstream->list #'-cstream->list) -(define-syntax list->cstream #'-list->cstream) +(define cstream->list #'-cstream->list) +(define list->cstream #'-list->cstream) ;; "Composes" higher-order functions inline by directly applying them ;; to the result of each subsequent application, with the last argument From a27bc75e6ffc617908873c135967523708b152a4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 20:18:18 -0700 Subject: [PATCH 312/338] Fix collapsing `values` in normalization 1. The matching rule was wrong. 2. We needed racket/base required "for template" to be able to match the literal `values`. --- qi-lib/flow/core/normalize.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index bda0ba15f..451b222b0 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -2,7 +2,8 @@ (provide normalize-rewrite) -(require syntax/parse) +(require syntax/parse + (for-template racket/base)) ;; 0. "Qi-normal form" (define (normalize-rewrite stx) @@ -54,7 +55,7 @@ [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) #'(thread _0 ... _1 ...)] ;; collapse `values` and `_` inside a threading form - [((~datum thread) _0 ... (~literal values) _1 ...) + [((~datum thread) _0 ... ((~datum esc) ((~datum #%host-expression) (~literal values))) _1 ...) #'(thread _0 ... _1 ...)] [((~datum thread) _0 ... (~datum _) _1 ...) #'(thread _0 ... _1 ...)] From fabfbf84e96872b031f10547aae8078dd3067432 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 20:39:03 -0700 Subject: [PATCH 313/338] clean up normalization rules by declaring datum literals --- qi-lib/flow/core/normalize.rkt | 51 ++++++++++++++++++++++------------ 1 file changed, 33 insertions(+), 18 deletions(-) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index 451b222b0..92ad3f2a2 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -8,58 +8,73 @@ ;; 0. "Qi-normal form" (define (normalize-rewrite stx) (syntax-parse stx + #:datum-literals (#%host-expression + #%blanket-template + #%fine-template + esc + gen + thread + pass + if + amp + relay + tee + sep + collect + __) + ;; "deforestation" for values ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) - [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...) + [(thread _0 ... (pass f) (amp g) _1 ...) #'(thread _0 ... (amp (if f g ground)) _1 ...)] ;; merge amps in sequence - [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...) + [(thread _0 ... (amp f) (amp g) _1 ...) #'(thread _0 ... (amp (thread f g)) _1 ...)] ;; merge pass filters in sequence - [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...) + [(thread _0 ... (pass f) (pass g) _1 ...) #'(thread _0 ... (pass (and f g)) _1 ...)] ;; collapse deterministic conditionals - [((~datum if) (~datum #t) f g) #'f] - [((~datum if) (~datum #f) f g) #'g] + [(if (~datum #t) f g) #'f] + [(if (~datum #f) f g) #'g] ;; trivial threading form - [((~datum thread) f) + [(thread f) #'f] ;; associative laws for ~> - [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) ; note: greedy matching + [(thread _0 ... (thread f ...) _1 ...) ; note: greedy matching #'(thread _0 ... f ... _1 ...)] ;; left and right identity for ~> - [((~datum thread) _0 ... (~datum _) _1 ...) + [(thread _0 ... (~datum _) _1 ...) #'(thread _0 ... _1 ...)] ;; composition of identity flows is the identity flow - [((~datum thread) (~datum _) ...) + [(thread (~datum _) ...) #'_] ;; identity flows composed using a relay - [((~datum relay) (~datum _) ...) + [(relay (~datum _) ...) #'_] ;; amp and identity - [((~datum amp) (~datum _)) + [(amp (~datum _)) #'_] ;; trivial tee junction - [((~datum tee) f) + [(tee f) #'f] ;; merge adjacent gens in a tee junction - [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + [(tee _0 ... (gen a ...) (gen b ...) _1 ...) #'(tee _0 ... (gen a ... b ...) _1 ...)] ;; dead gen elimination - [((~datum thread) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...) + [(thread _0 ... (gen a ...) (gen b ...) _1 ...) #'(thread _0 ... (gen b ...) _1 ...)] ;; prism identities ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's ;; only valid if the input is in fact a list, and is an error otherwise, ;; and we can only know this at runtime. - [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...) + [(thread _0 ... collect sep _1 ...) #'(thread _0 ... _1 ...)] ;; collapse `values` and `_` inside a threading form - [((~datum thread) _0 ... ((~datum esc) ((~datum #%host-expression) (~literal values))) _1 ...) + [(thread _0 ... (esc (#%host-expression (~literal values))) _1 ...) #'(thread _0 ... _1 ...)] - [((~datum thread) _0 ... (~datum _) _1 ...) + [(thread _0 ... (~datum _) _1 ...) #'(thread _0 ... _1 ...)] - [((~datum #%blanket-template) (hex (~datum __))) + [(#%blanket-template (hex __)) #'hex] ;; return syntax unchanged if there are no applicable normalizations [_ stx])) From 00f840d60108eb21da1a512590375c14f0b7ed4c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 23:49:31 -0700 Subject: [PATCH 314/338] revert phase changes to deforest.rkt for now --- qi-lib/flow/core/compiler.rkt | 4 +- qi-lib/flow/core/deforest.rkt | 594 ++++++++++++++++--------------- qi-test/tests/compiler/rules.rkt | 4 +- 3 files changed, 302 insertions(+), 300 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index c11160598..0cbc0cb92 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -11,8 +11,8 @@ "../aux-syntax.rkt" "util.rkt" "debug.rkt" - "normalize.rkt" - "deforest.rkt") + "normalize.rkt") + "deforest.rkt" "impl.rkt" (only-in racket/list make-list) racket/function diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index cef0de411..30f57bf7d 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -1,9 +1,10 @@ #lang racket/base -(provide deforest-rewrite) +(provide (for-syntax deforest-rewrite)) -(require syntax/parse - racket/syntax-srcloc +(require (for-syntax racket/base + syntax/parse + racket/syntax-srcloc) racket/performance-hint racket/match racket/list @@ -24,304 +25,305 @@ [(_ f) f] [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) -;; Partially reconstructs original flow expressions. The chirality -;; is lost and the form is already normalized at this point though! -(define (prettify-flow-syntax stx) - (syntax-parse stx - #:datum-literals (#%host-expression esc #%blanket-template #%fine-template) - (((~literal thread) - expr ...) - #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))) - (((~or #%blanket-template #%fine-template) - (expr ...)) - (map prettify-flow-syntax (syntax->list #'(expr ...)))) - ((#%host-expression expr) #'expr) - ((esc expr) (prettify-flow-syntax #'expr)) - (expr #'expr))) - -;; Special "curry"ing for #%fine-templates. All #%host-expressions -;; are passed as they are and all (~datum _) are replaced by wrapper -;; lambda arguments. -(define ((make-fine-curry argstx minargs maxargs form-stx) ctx name) - (define argstxlst (syntax->list argstx)) - (define numargs (length argstxlst)) - (cond ((< numargs minargs) - (raise-syntax-error (syntax->datum name) - (format "too few arguments - given ~a - accepts at least ~a" - numargs minargs) - (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx))) - ((> numargs maxargs) - (raise-syntax-error (syntax->datum name) - (format "too many arguments - given ~a - accepts at most ~a" - numargs maxargs) - (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx)))) - (define temporaries (generate-temporaries argstxlst)) - (define-values (allargs tmpargs) - (for/fold ((all '()) - (tmps '()) - #:result (values (reverse all) - (reverse tmps))) - ((tmp (in-list temporaries)) - (arg (in-list argstxlst))) - (syntax-parse arg - #:datum-literals (#%host-expression) - ((#%host-expression ex) - (values (cons #'ex all) - tmps)) - ((~datum _) - (values (cons tmp all) - (cons tmp tmps)))))) - (with-syntax (((carg ...) tmpargs) - ((aarg ...) allargs)) - #'(λ (proc) - (λ (carg ...) - (proc aarg ...))))) - -;; Special curry for #%blanket-template. Raises syntax error if -;; there are too many arguments. If the number of arguments is -;; exactly the maximum, wraps into lambda without any arguments. If -;; less than maximum, curries it from both left and right. -(define ((make-blanket-curry prestx poststx maxargs form-stx) ctx name) - (define prelst (syntax->list prestx)) - (define postlst (syntax->list poststx)) - (define numargs (+ (length prelst) (length postlst))) - (with-syntax (((pre-arg ...) prelst) - ((post-arg ...) postlst)) - (cond ((> numargs maxargs) +(begin-for-syntax + ;; Partially reconstructs original flow expressions. The chirality + ;; is lost and the form is already normalized at this point though! + (define (prettify-flow-syntax stx) + (syntax-parse stx + #:datum-literals (#%host-expression esc #%blanket-template #%fine-template) + (((~literal thread) + expr ...) + #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))) + (((~or #%blanket-template #%fine-template) + (expr ...)) + (map prettify-flow-syntax (syntax->list #'(expr ...)))) + ((#%host-expression expr) #'expr) + ((esc expr) (prettify-flow-syntax #'expr)) + (expr #'expr))) + + ;; Special "curry"ing for #%fine-templates. All #%host-expressions + ;; are passed as they are and all (~datum _) are replaced by wrapper + ;; lambda arguments. + (define ((make-fine-curry argstx minargs maxargs form-stx) ctx name) + (define argstxlst (syntax->list argstx)) + (define numargs (length argstxlst)) + (cond ((< numargs minargs) + (raise-syntax-error (syntax->datum name) + (format "too few arguments - given ~a - accepts at least ~a" + numargs minargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))) + ((> numargs maxargs) (raise-syntax-error (syntax->datum name) (format "too many arguments - given ~a - accepts at most ~a" numargs maxargs) (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx))) - ((= numargs maxargs) - #'(λ (v) - (λ () - (v pre-arg ... post-arg ...)))) - (else - #'(λ (v) - (λ rest - (apply v pre-arg ... - (append rest - (list post-arg ...))))))))) - -;; Unifying producer curry makers. The ellipsis escaping allows for -;; simple specification of pattern variable names as bound in the -;; syntax pattern. -(define-syntax make-producer-curry - (syntax-rules () - ((_ min-args max-args - blanket? pre-arg post-arg - fine? arg - form-stx) - (cond - ((attribute blanket?) - (make-blanket-curry #'(pre-arg (... ...)) - #'(post-arg (... ...)) - max-args - #'form-stx - )) - ((attribute fine?) - (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)) - (else - (λ (ctx name) #'(λ (v) v))))))) - -;; Used for producing the stream from particular -;; expressions. Implicit producer is list->cstream-next and it is -;; not created by using this class but rather explicitly used when -;; no syntax class producer is matched. -(define-syntax-class fusable-stream-producer - #:attributes (next prepare contract name curry) - #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) - ;; Explicit range producers. - (pattern (~and (~or (esc (#%host-expression (~literal range))) - (~and (#%fine-template - ((#%host-expression (~literal range)) - arg ...)) - fine?) - (~and (#%blanket-template - ((#%host-expression (~literal range)) - (#%host-expression pre-arg) ... - __ - (#%host-expression post-arg) ...)) - blanket?)) - form-stx) - #:attr next #'range->cstream-next - #:attr prepare #'range->cstream-prepare - #:attr contract #'(->* (real?) (real? real?) any) - #:attr name #'range - #:attr curry (make-producer-curry 1 3 - blanket? pre-arg post-arg - fine? arg - form-stx)) - - ;; The implicit stream producer from plain list. - (pattern (~literal list->cstream) - #:attr next #'list->cstream-next - #:attr prepare #'list->cstream-prepare - #:attr contract #'(-> list? any) - #:attr name #''list->cstream - #:attr curry (λ (ctx name) #'(λ (v) v)))) - -;; Matches any stream transformer that can be in the head position -;; of the fused sequence even when there is no explicit -;; producer. Procedures accepting variable number of arguments like -;; `map` cannot be in this class. -(define-syntax-class fusable-stream-transformer0 - #:attributes (f next) - #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) - (pattern (~or (#%blanket-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - _))) - #:attr next #'filter-cstream-next)) - -;; All implemented stream transformers - within the stream, only -;; single value is being passed and therefore procedures like `map` -;; can (and should) be matched. -(define-syntax-class fusable-stream-transformer - #:attributes (f next) - #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) - (pattern (~or (#%blanket-template - ((#%host-expression (~literal map)) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~literal map)) - (#%host-expression f) - _))) - #:attr next #'map-cstream-next) - - (pattern (~or (#%blanket-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~literal filter)) - (#%host-expression f) - _))) - #:attr next #'filter-cstream-next)) - -;; Terminates the fused sequence (consumes the stream) and produces -;; an actual result value. -(define-syntax-class fusable-stream-consumer - #:attributes (end) - #:datum-literals (#%host-expression #%blanket-template _ __ #%fine-template esc) - (pattern (~or (#%blanket-template - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init) - __)) - (#%fine-template - ((#%host-expression (~literal foldr)) - (#%host-expression op) - (#%host-expression init) - _))) - #:attr end #'(foldr-cstream-next op init)) - - (pattern (~or (#%blanket-template - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init) - __)) - (#%fine-template - ((#%host-expression (~literal foldl)) - (#%host-expression op) - (#%host-expression init) - _))) - #:attr end #'(foldl-cstream-next op init)) - - (pattern (~or (esc (#%host-expression (~literal car))) - (#%fine-template - ((#%host-expression (~literal car)) - _)) - (#%blanket-template - ((#%host-expression (~literal car)) - __))) - #:attr end #'(car-cstream-next)) - - (pattern (~literal cstream->list) - #:attr end #'(cstream-next->list))) - -;; Used only in deforest-rewrite to properly recognize the end of -;; fusable sequence. -(define-syntax-class non-fusable - (pattern (~not (~or _:fusable-stream-transformer - _:fusable-stream-producer - _:fusable-stream-consumer)))) - -;; Generates a syntax for the fused operation for given -;; sequence. The syntax list must already be in the following form: -;; (producer transformer ... consumer) -(define (generate-fused-operation ops ctx) - (syntax-parse (reverse ops) - [(c:fusable-stream-consumer - t:fusable-stream-transformer ... - p:fusable-stream-producer) - ;; A static runtime contract is placed at the beginning of the - ;; fused sequence. And runtime checks for consumers are in - ;; their respective implementation procedure. - #`(esc - (#,((attribute p.curry) ctx (attribute p.name)) - (contract p.contract - (p.prepare - (#,@#'c.end - (inline-compose1 [t.next t.f] ... - p.next) + (prettify-flow-syntax form-stx)))) + (define temporaries (generate-temporaries argstxlst)) + (define-values (allargs tmpargs) + (for/fold ((all '()) + (tmps '()) + #:result (values (reverse all) + (reverse tmps))) + ((tmp (in-list temporaries)) + (arg (in-list argstxlst))) + (syntax-parse arg + #:datum-literals (#%host-expression) + ((#%host-expression ex) + (values (cons #'ex all) + tmps)) + ((~datum _) + (values (cons tmp all) + (cons tmp tmps)))))) + (with-syntax (((carg ...) tmpargs) + ((aarg ...) allargs)) + #'(λ (proc) + (λ (carg ...) + (proc aarg ...))))) + + ;; Special curry for #%blanket-template. Raises syntax error if + ;; there are too many arguments. If the number of arguments is + ;; exactly the maximum, wraps into lambda without any arguments. If + ;; less than maximum, curries it from both left and right. + (define ((make-blanket-curry prestx poststx maxargs form-stx) ctx name) + (define prelst (syntax->list prestx)) + (define postlst (syntax->list poststx)) + (define numargs (+ (length prelst) (length postlst))) + (with-syntax (((pre-arg ...) prelst) + ((post-arg ...) postlst)) + (cond ((> numargs maxargs) + (raise-syntax-error (syntax->datum name) + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))) + ((= numargs maxargs) + #'(λ (v) + (λ () + (v pre-arg ... post-arg ...)))) + (else + #'(λ (v) + (λ rest + (apply v pre-arg ... + (append rest + (list post-arg ...))))))))) + + ;; Unifying producer curry makers. The ellipsis escaping allows for + ;; simple specification of pattern variable names as bound in the + ;; syntax pattern. + (define-syntax make-producer-curry + (syntax-rules () + ((_ min-args max-args + blanket? pre-arg post-arg + fine? arg + form-stx) + (cond + ((attribute blanket?) + (make-blanket-curry #'(pre-arg (... ...)) + #'(post-arg (... ...)) + max-args + #'form-stx + )) + ((attribute fine?) + (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)) + (else + (λ (ctx name) #'(λ (v) v))))))) + + ;; Used for producing the stream from particular + ;; expressions. Implicit producer is list->cstream-next and it is + ;; not created by using this class but rather explicitly used when + ;; no syntax class producer is matched. + (define-syntax-class fusable-stream-producer + #:attributes (next prepare contract name curry) + #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) + ;; Explicit range producers. + (pattern (~and (~or (esc (#%host-expression (~datum range))) + (~and (#%fine-template + ((#%host-expression (~datum range)) + arg ...)) + fine?) + (~and (#%blanket-template + ((#%host-expression (~datum range)) + (#%host-expression pre-arg) ... + __ + (#%host-expression post-arg) ...)) + blanket?)) + form-stx) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-prepare + #:attr contract #'(->* (real?) (real? real?) any) + #:attr name #'range + #:attr curry (make-producer-curry 1 3 + blanket? pre-arg post-arg + fine? arg + form-stx)) + + ;; The implicit stream producer from plain list. + (pattern (~literal list->cstream) + #:attr next #'list->cstream-next + #:attr prepare #'list->cstream-prepare + #:attr contract #'(-> list? any) + #:attr name #''list->cstream + #:attr curry (λ (ctx name) #'(λ (v) v)))) + + ;; Matches any stream transformer that can be in the head position + ;; of the fused sequence even when there is no explicit + ;; producer. Procedures accepting variable number of arguments like + ;; `map` cannot be in this class. + (define-syntax-class fusable-stream-transformer0 + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + + ;; All implemented stream transformers - within the stream, only + ;; single value is being passed and therefore procedures like `map` + ;; can (and should) be matched. + (define-syntax-class fusable-stream-transformer + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum map)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum map)) + (#%host-expression f) + _))) + #:attr next #'map-cstream-next) + + (pattern (~or (#%blanket-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + + ;; Terminates the fused sequence (consumes the stream) and produces + ;; an actual result value. + (define-syntax-class fusable-stream-consumer + #:attributes (end) + #:datum-literals (#%host-expression #%blanket-template _ __ #%fine-template esc) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum foldr)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~datum foldr)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldr-cstream-next op init)) + + (pattern (~or (#%blanket-template + ((#%host-expression (~datum foldl)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~datum foldl)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldl-cstream-next op init)) + + (pattern (~or (esc (#%host-expression (~datum car))) + (#%fine-template + ((#%host-expression (~datum car)) + _)) + (#%blanket-template + ((#%host-expression (~datum car)) + __))) + #:attr end #'(car-cstream-next)) + + (pattern (~literal cstream->list) + #:attr end #'(cstream-next->list))) + + ;; Used only in deforest-rewrite to properly recognize the end of + ;; fusable sequence. + (define-syntax-class non-fusable + (pattern (~not (~or _:fusable-stream-transformer + _:fusable-stream-producer + _:fusable-stream-consumer)))) + + ;; Generates a syntax for the fused operation for given + ;; sequence. The syntax list must already be in the following form: + ;; (producer transformer ... consumer) + (define (generate-fused-operation ops ctx) + (syntax-parse (reverse ops) + [(c:fusable-stream-consumer + t:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; A static runtime contract is placed at the beginning of the + ;; fused sequence. And runtime checks for consumers are in + ;; their respective implementation procedure. + #`(esc + (#,((attribute p.curry) ctx (attribute p.name)) + (contract p.contract + (p.prepare + (#,@#'c.end + (inline-compose1 [t.next t.f] ... + p.next) + '#,(prettify-flow-syntax ctx) + #,(syntax-srcloc ctx))) + p.name '#,(prettify-flow-syntax ctx) - #,(syntax-srcloc ctx))) - p.name - '#,(prettify-flow-syntax ctx) - #f - #,(syntax-srcloc ctx))))])) - -;; Performs one step of deforestation rewrite. Should be used as -;; many times as needed - until it returns the source syntax -;; unchanged. -(define (deforest-rewrite stx) - (syntax-parse stx - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - ;; There can be zero transformers here: - t:fusable-stream-transformer ... - c:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - t1:fusable-stream-transformer0 - t:fusable-stream-transformer ... - c:fusable-stream-consumer - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream t1 t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fusable-stream-producer - ;; Must be 1 or more transformers here: - t:fusable-stream-transformer ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - f1:fusable-stream-transformer0 - f:fusable-stream-transformer ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream f1 f ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - [_ this-syntax])) + #f + #,(syntax-srcloc ctx))))])) + + ;; Performs one step of deforestation rewrite. Should be used as + ;; many times as needed - until it returns the source syntax + ;; unchanged. + (define (deforest-rewrite stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; There can be zero transformers here: + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fusable-stream-transformer0 + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; Must be 1 or more transformers here: + t:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [_ this-syntax]))) (begin-encourage-inline diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index ad9aa98f3..3dfdf95e8 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -2,8 +2,8 @@ (provide tests) -(require (for-template qi/flow/core/compiler) - qi/flow/core/deforest +(require (for-template qi/flow/core/compiler + qi/flow/core/deforest) rackunit rackunit/text-ui (only-in math sqr) From d4df8b98d5ea181a354439908d3f7be650a3ffae Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sun, 10 Dec 2023 23:49:53 -0700 Subject: [PATCH 315/338] Comment out failing test The code it tests appears to be working correctly, so the question is, how to write a valid test here? Commenting it out for now. --- qi-test/tests/compiler/rules.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index 3dfdf95e8..fee9eb62f 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -519,9 +519,9 @@ (test-normalize "redundant blanket template" #'(#%blanket-template (f __)) #'f) - (test-normalize "values is collapsed inside ~>" - #'(thread values f values) - #'(thread f)) + ;; (test-normalize "values is collapsed inside ~>" + ;; #'(thread values f values) + ;; #'(thread f)) (test-normalize "_ is collapsed inside ~>" #'(thread _ f _) #'(thread f)) From e34f5ae45bd26be0f69d2ab54ba6449588044827 Mon Sep 17 00:00:00 2001 From: "D. Ben Knoble" Date: Tue, 12 Dec 2023 11:05:53 -0500 Subject: [PATCH 316/338] deforest: format some brackets --- qi-lib/flow/core/deforest.rkt | 110 +++++++++++++++++----------------- 1 file changed, 56 insertions(+), 54 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 30f57bf7d..e95c39327 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -31,15 +31,15 @@ (define (prettify-flow-syntax stx) (syntax-parse stx #:datum-literals (#%host-expression esc #%blanket-template #%fine-template) - (((~literal thread) + [((~literal thread) expr ...) - #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))) - (((~or #%blanket-template #%fine-template) + #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [((~or #%blanket-template #%fine-template) (expr ...)) - (map prettify-flow-syntax (syntax->list #'(expr ...)))) - ((#%host-expression expr) #'expr) - ((esc expr) (prettify-flow-syntax #'expr)) - (expr #'expr))) + (map prettify-flow-syntax (syntax->list #'(expr ...)))] + [(#%host-expression expr) #'expr] + [(esc expr) (prettify-flow-syntax #'expr)] + [expr #'expr])) ;; Special "curry"ing for #%fine-templates. All #%host-expressions ;; are passed as they are and all (~datum _) are replaced by wrapper @@ -47,36 +47,37 @@ (define ((make-fine-curry argstx minargs maxargs form-stx) ctx name) (define argstxlst (syntax->list argstx)) (define numargs (length argstxlst)) - (cond ((< numargs minargs) - (raise-syntax-error (syntax->datum name) - (format "too few arguments - given ~a - accepts at least ~a" - numargs minargs) - (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx))) - ((> numargs maxargs) - (raise-syntax-error (syntax->datum name) - (format "too many arguments - given ~a - accepts at most ~a" - numargs maxargs) - (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx)))) + (cond + [(< numargs minargs) + (raise-syntax-error (syntax->datum name) + (format "too few arguments - given ~a - accepts at least ~a" + numargs minargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))] + [(> numargs maxargs) + (raise-syntax-error (syntax->datum name) + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))]) (define temporaries (generate-temporaries argstxlst)) (define-values (allargs tmpargs) - (for/fold ((all '()) - (tmps '()) + (for/fold ([all '()] + [tmps '()] #:result (values (reverse all) (reverse tmps))) - ((tmp (in-list temporaries)) - (arg (in-list argstxlst))) + ([tmp (in-list temporaries)] + [arg (in-list argstxlst)]) (syntax-parse arg #:datum-literals (#%host-expression) - ((#%host-expression ex) + [(#%host-expression ex) (values (cons #'ex all) - tmps)) - ((~datum _) + tmps)] + [(~datum _) (values (cons tmp all) - (cons tmp tmps)))))) - (with-syntax (((carg ...) tmpargs) - ((aarg ...) allargs)) + (cons tmp tmps))]))) + (with-syntax ([(carg ...) tmpargs] + [(aarg ...) allargs]) #'(λ (proc) (λ (carg ...) (proc aarg ...))))) @@ -89,45 +90,46 @@ (define prelst (syntax->list prestx)) (define postlst (syntax->list poststx)) (define numargs (+ (length prelst) (length postlst))) - (with-syntax (((pre-arg ...) prelst) - ((post-arg ...) postlst)) - (cond ((> numargs maxargs) - (raise-syntax-error (syntax->datum name) - (format "too many arguments - given ~a - accepts at most ~a" - numargs maxargs) - (prettify-flow-syntax ctx) - (prettify-flow-syntax form-stx))) - ((= numargs maxargs) - #'(λ (v) - (λ () - (v pre-arg ... post-arg ...)))) - (else - #'(λ (v) - (λ rest - (apply v pre-arg ... - (append rest - (list post-arg ...))))))))) + (with-syntax ([(pre-arg ...) prelst] + [(post-arg ...) postlst]) + (cond + [(> numargs maxargs) + (raise-syntax-error (syntax->datum name) + (format "too many arguments - given ~a - accepts at most ~a" + numargs maxargs) + (prettify-flow-syntax ctx) + (prettify-flow-syntax form-stx))] + [(= numargs maxargs) + #'(λ (v) + (λ () + (v pre-arg ... post-arg ...)))] + [else + #'(λ (v) + (λ rest + (apply v pre-arg ... + (append rest + (list post-arg ...)))))]))) ;; Unifying producer curry makers. The ellipsis escaping allows for ;; simple specification of pattern variable names as bound in the ;; syntax pattern. (define-syntax make-producer-curry (syntax-rules () - ((_ min-args max-args + [(_ min-args max-args blanket? pre-arg post-arg fine? arg form-stx) (cond - ((attribute blanket?) + [(attribute blanket?) (make-blanket-curry #'(pre-arg (... ...)) #'(post-arg (... ...)) max-args #'form-stx - )) - ((attribute fine?) - (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)) - (else - (λ (ctx name) #'(λ (v) v))))))) + )] + [(attribute fine?) + (make-fine-curry #'(arg (... ...)) min-args max-args #'form-stx)] + [else + (λ (ctx name) #'(λ (v) v))])])) ;; Used for producing the stream from particular ;; expressions. Implicit producer is list->cstream-next and it is From f08ef3e387af4d07a25c57242a7553a28bd8361e Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 14 Dec 2023 14:01:37 -0700 Subject: [PATCH 317/338] fix tests not being run on `make test` --- qi-test/tests/qi.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-test/tests/qi.rkt b/qi-test/tests/qi.rkt index 26b9c36af..7bace1617 100644 --- a/qi-test/tests/qi.rkt +++ b/qi-test/tests/qi.rkt @@ -24,6 +24,6 @@ util:tests compiler:tests)) -(module+ main +(module+ test (void (run-tests tests))) From 6ccb0fcebe05f2b849a413c20d848d9389284b7a Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 13 Dec 2023 16:41:36 -0700 Subject: [PATCH 318/338] Add more counterexamples found by Ben --- qi-test/tests/flow.rkt | 52 ++++++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 15 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 7dcdf9fb6..efcc0d127 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1540,25 +1540,47 @@ ;; "equivalences" that are not really equivalences are formally checked (test-suite "counterexamples" - (let () - (define-flow g (-< add1 sub1)) - (define-flow f positive?) - (define (f* x y) (= (sub1 x) (add1 y))) - (define (amp-pass g f) (☯ (~> (>< g) (pass f) ▽))) - (define (amp-if g f) (☯ (~> (>< (~> g (if f _ ground))) ▽))) - (check-equal? (apply (amp-pass g f) (range -3 4)) + (test-suite + "(~> (>< g) (pass f)) ─/→ (>< (~> g (if f _ ⏚)))" + (let () + (define-flow g (-< add1 sub1)) + (define-flow f positive?) + (define (f* x y) (= (sub1 x) (add1 y))) + (define (amp-pass g f) (☯ (~> (>< g) (pass f) ▽))) + (define (amp-if g f) (☯ (~> (>< (~> g (if f _ ground))) ▽))) + (test-equal? "amp-pass" + (apply (amp-pass g f) (range -3 4)) (list 1 2 3 1 4 2)) - (check-exn exn:fail? - (thunk (apply (amp-if g f) (range -3 4)))) - (check-exn exn:fail? + (test-exn "amp-pass" + exn:fail? (thunk (apply (amp-pass g f*) (range -3 4)))) - (check-equal? (apply (amp-if g f*) (range -3 4)) + (test-exn "amp-if" + exn:fail? + (thunk (apply (amp-if g f) (range -3 4)))) + (test-equal? "amp-if" + (apply (amp-if g f*) (range -3 4)) (list -2 -4 -1 -3 0 -2 1 -1 2 0 3 1 4 2))) - (let () - (check-equal? ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") + (let () + (test-equal? "amp-pass" + ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") 2) - (check-equal? ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") - (list #f 2 #f))))))) + (test-equal? "amp-if" + ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") + (list #f 2 #f)))) + (test-suite + "(~> (>< f) (>< g)) ─/→ (>< (~> f g))" + (test-equal? "amp-amp" + ((☯ (~> (>< (-< add1 sub1)) + (>< (-< sub1 add1)) + ▽)) + 3) + (list 3 5 1 3)) + (test-exn "merged amp" + exn:fail? + (thunk + ((☯ (>< (~> (-< add1 sub1) + (-< sub1 add1)))) + 3)))))))) (module+ main (void (run-tests tests))) From 33629ce5aa28f98fd37e6ba0dce097d04811f6f1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 13 Dec 2023 18:11:40 -0700 Subject: [PATCH 319/338] counterexamples... --- qi-test/tests/flow.rkt | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index efcc0d127..eccfd7d04 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -1580,7 +1580,15 @@ (thunk ((☯ (>< (~> (-< add1 sub1) (-< sub1 add1)))) - 3)))))))) + 3)))) + (test-suite + "(~> (== _ ...)) ─/→ _" + (test-exn "relay-_" + exn:fail? + (thunk + ((☯ (== _ _ _)) + 3))) + (test-equal? "relay-_" ((☯ _) 3) 3)))))) (module+ main (void (run-tests tests))) From 95b224930ed994feab378083b84c2ae84d7e73b6 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 13 Dec 2023 18:13:36 -0700 Subject: [PATCH 320/338] don't duplicate left and right identity rule --- qi-lib/flow/core/normalize.rkt | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index 92ad3f2a2..4506214bf 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -69,11 +69,9 @@ ;; and we can only know this at runtime. [(thread _0 ... collect sep _1 ...) #'(thread _0 ... _1 ...)] - ;; collapse `values` and `_` inside a threading form + ;; collapse `values` inside a threading form [(thread _0 ... (esc (#%host-expression (~literal values))) _1 ...) #'(thread _0 ... _1 ...)] - [(thread _0 ... (~datum _) _1 ...) - #'(thread _0 ... _1 ...)] [(#%blanket-template (hex __)) #'hex] ;; return syntax unchanged if there are no applicable normalizations From 9d5290e70f7559fc081f2b4702cd7c7cc2880de4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Wed, 13 Dec 2023 18:28:12 -0700 Subject: [PATCH 321/338] remove unsound normalization rules --- qi-lib/flow/core/normalize.rkt | 6 ------ 1 file changed, 6 deletions(-) diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt index 4506214bf..3d92bc5a1 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/normalize.rkt @@ -27,9 +27,6 @@ ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) [(thread _0 ... (pass f) (amp g) _1 ...) #'(thread _0 ... (amp (if f g ground)) _1 ...)] - ;; merge amps in sequence - [(thread _0 ... (amp f) (amp g) _1 ...) - #'(thread _0 ... (amp (thread f g)) _1 ...)] ;; merge pass filters in sequence [(thread _0 ... (pass f) (pass g) _1 ...) #'(thread _0 ... (pass (and f g)) _1 ...)] @@ -48,9 +45,6 @@ ;; composition of identity flows is the identity flow [(thread (~datum _) ...) #'_] - ;; identity flows composed using a relay - [(relay (~datum _) ...) - #'_] ;; amp and identity [(amp (~datum _)) #'_] From 30f4236ff8de0499d99713f45e51bb3c58bbf01b Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 14 Dec 2023 14:35:26 -0700 Subject: [PATCH 322/338] remove failing compiler tests for the unsound rules --- qi-test/tests/compiler/rules.rkt | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt index fee9eb62f..f033a5696 100644 --- a/qi-test/tests/compiler/rules.rkt +++ b/qi-test/tests/compiler/rules.rkt @@ -466,9 +466,6 @@ (pass f) (amp g)) #'(amp (if f g ground))) - (test-normalize "merge amps in sequence" - #'(thread (amp f) (amp g)) - #'(amp (thread f g))) (test-normalize "merge pass filters in sequence" #'(thread (pass f) (pass g)) #'(pass (and f g))) @@ -496,11 +493,6 @@ #'(thread _ _) #'(thread _) #'_) - (test-normalize "relay composition of identity flows" - #'(relay _ _ _) - #'(relay _ _) - #'(relay _) - #'_) (test-normalize "amp under identity" #'(amp _) #'_) @@ -524,10 +516,7 @@ ;; #'(thread f)) (test-normalize "_ is collapsed inside ~>" #'(thread _ f _) - #'(thread f)) - (test-normalize "consecutive amps are combined" - #'(thread (amp f) (amp g)) - #'(thread (amp (thread f g))))) + #'(thread f))) (test-suite "compilation sequences" From 1688a437193cac37b7498c2f7b550fabd5badb48 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 23 Feb 2023 19:53:09 -0800 Subject: [PATCH 323/338] define qi functions in a uniform way (restored - got dropped in the rebase) --- qi-lib/flow/extended/forms.rkt | 6 ++---- qi-lib/flow/extended/impl.rkt | 10 +++++++++- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index 16c60f612..a1080b8fb 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -151,11 +151,9 @@ ;;; Common utilities -(define-for-qi (count . args) - (length args)) +(define-for-qi count ~count) -(define-for-qi (live? . args) - (not (null? args))) +(define-for-qi live? ~live?) (define-qi-syntax-rule (rectify v:expr ...) (if live? _ (gen v ...))) diff --git a/qi-lib/flow/extended/impl.rkt b/qi-lib/flow/extended/impl.rkt index 0ab872643..8ac1328e7 100644 --- a/qi-lib/flow/extended/impl.rkt +++ b/qi-lib/flow/extended/impl.rkt @@ -8,7 +8,9 @@ false. ~all? ~any? - ~none?) + ~none? + ~count + ~live?) (define (->boolean v) (and v #t)) @@ -31,3 +33,9 @@ (define (~none? . args) (not (~any?-helper args))) + +(define (~count . args) + (length args)) + +(define (~live? . args) + (not (null? args))) From 849d95d4908e7dfd1b36ea69b95cb770e2d8d1c7 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 14 Dec 2023 15:17:58 -0700 Subject: [PATCH 324/338] fix "not currently expanding" issue (restored - got dropped in the rebase) --- qi-lib/flow/core/compiler.rkt | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 0cbc0cb92..48d439c3e 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -36,13 +36,19 @@ (find-and-map/qi (fix deforest-rewrite) stx)) + (define-qi-expansion-step (~deforest-pass stx) + (deforest-rewrite stx)) + (define (normalize-pass stx) (find-and-map/qi (fix normalize-rewrite) stx)) + (define-qi-expansion-step (~normalize-pass stx) + (normalize-pass stx)) + (define (optimize-flow stx) - (deforest-pass - (normalize-pass stx)))) + (~deforest-pass + (~normalize-pass stx)))) ;; Transformation rules for the `as` binding form: ;; From e322e1e367ec09962618053d6fe5dba7ad4d0377 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 14 Dec 2023 19:11:08 -0700 Subject: [PATCH 325/338] Make error pattern in ~> more specific to avoid bad error message Fixes #135 --- qi-lib/threading.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 64ae273af..42ac361b0 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -16,7 +16,7 @@ "on.rkt") (define-syntax-parser %~> - [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) + [(_ (arg0:expr arg:expr ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error this-syntax "(~> (arg ...) flo ...)" @@ -27,7 +27,7 @@ #'(on ags (~> clause ...))]) (define-syntax-parser %~>> - [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) + [(_ (arg0:expr arg:expr ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error (report-syntax-error this-syntax "(~>> (arg ...) flo ...)" From 491b1078d5e98b77c58ae49ee2aaf0a69a2b3fe8 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Thu, 14 Dec 2023 19:22:55 -0700 Subject: [PATCH 326/338] Remove invalid (yet passing on main) test --- qi-test/tests/flow.rkt | 4 ---- 1 file changed, 4 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index eccfd7d04..cfec6b6ea 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -510,10 +510,6 @@ (list 2 1 3)) (list 1 4 9) "pre-supplied keyword arguments with right chirality") - (check-equal? ((☯ (~>> (sort <))) - #:key identity 2 1 3) - (list 1 2 3) - "right-threading with keyword arg at invocation time") ;; TODO: propagate threading side to nested clauses ;; (check-equal? (on ("p" "q") ;; (~>> (>< (string-append "a" "b")) From 5f1774d721c95016961cbd1b3687e69c758d27c1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 13:57:37 -0700 Subject: [PATCH 327/338] reorder some tests --- qi-test/tests/flow.rkt | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index cfec6b6ea..71bc3f577 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -354,10 +354,19 @@ (check-equal? ((☯ (~> (as v) (+ v))) 3) 3 "binds a single value") + (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) + 7 + "binds multiple values") + (check-false ((☯ (~> (as v) live?)) 3) + "binding does not propagate the value") (check-equal? ((☯ (~> (-< (as v) _) (+ 3 _ v))) 3) 9 "reference in a fine template") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 __ v))) 3) + 9 + "reference in a blanket template") (check-equal? ((☯ (~> (-< (as v) _) (+ 3 v))) 3) 9 @@ -366,15 +375,6 @@ _) (+ 3 v))) 3) 9 "reference in a right-chiral partial application") - (check-equal? ((☯ (~> (-< (as v) - _) (+ 3 __ v))) 3) - 9 - "reference in a blanket template") - (check-false ((☯ (~> (as v) live?)) 3) - "binding does not propagate the value") - (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) - 7 - "binds multiple values") (check-equal? ((☯ (~> (-< (~> list (as vs)) +) (~a "The sum of " vs " is " _))) From 41683bc20345d9fdda023b751dac982cc2092f09 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 14:49:33 -0700 Subject: [PATCH 328/338] failing unit tests for desired binding behavior with `switch` --- qi-test/tests/flow.rkt | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index 71bc3f577..dca0f75b7 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -419,6 +419,27 @@ (as v)))) 3))) "tee junction tines don't bind preceding peers") + (check-equal? ((☯ (switch [(~> sqr (ε (as v) #t)) + (gen v)])) + 3) + 9 + "switch conditions bind clauses") + (check-equal? ((☯ (switch + [(~> sqr (ε (as v) #f)) + (gen v)] + [(~> add1 (ε (as v) #t)) + (gen v)])) + 3) + 4 + "bindings in switch conditions shadow earlier conditions") + (check-exn exn:fail? + (thunk + (convert-compile-time-error + ((☯ (~> (switch [(~> sqr (ε (as v) #t)) + 0]) + (gen v))) + 3))) + "switch does not bind downstream") (check-exn exn:fail? (thunk (convert-compile-time-error ((☯ (~> (or (ε (as v)) 5) (+ v))) From 37533ae2f9acf55032c9b3fcec696c7d0751830c Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 14:53:56 -0700 Subject: [PATCH 329/338] add binding spec for `if` (inherited by `switch`) --- qi-lib/flow/extended/expander.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt index 0c152f195..fe6b01f2a 100644 --- a/qi-lib/flow/extended/expander.rkt +++ b/qi-lib/flow/extended/expander.rkt @@ -105,9 +105,10 @@ "(group )")) (if consequent:closed-floe alternative:closed-floe) - (if condition:closed-floe + (if condition:floe consequent:closed-floe alternative:closed-floe) + #:binding (nest-one condition [consequent alternative]) (sieve condition:closed-floe sonex:closed-floe ronex:closed-floe) From 45577c59f18998d2fec9200fc2921ec0aa963ab1 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 15:00:26 -0700 Subject: [PATCH 330/338] don't look for fixed point in deforestation as it's unnecessary --- qi-lib/flow/core/compiler.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 48d439c3e..84adc4e49 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -33,7 +33,7 @@ ;; Note: deforestation happens only for threading, ;; and the normalize pass strips the threading form ;; if it contains only one expression, so this would not be hit. - (find-and-map/qi (fix deforest-rewrite) + (find-and-map/qi deforest-rewrite stx)) (define-qi-expansion-step (~deforest-pass stx) From d20a5a6bd7fa69805b770df472eda372d487d91d Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 15:35:28 -0700 Subject: [PATCH 331/338] starter tests for the expander --- Makefile | 7 ++++++- qi-test/tests/expander.rkt | 37 +++++++++++++++++++++++++++++++++++++ qi-test/tests/qi.rkt | 2 ++ 3 files changed, 45 insertions(+), 1 deletion(-) create mode 100644 qi-test/tests/expander.rkt diff --git a/Makefile b/Makefile index 3ffd6e48e..8642cfe21 100644 --- a/Makefile +++ b/Makefile @@ -30,6 +30,8 @@ help: @echo " definitions" @echo " macro" @echo " util" + @echo " expander" + @echo " compiler" @echo " probe" @echo " Note: As probe is not in qi-lib, it isn't part of" @echo " the tests run in the 'test' target." @@ -124,6 +126,9 @@ test-macro: test-util: racket -y $(PACKAGE-NAME)-test/tests/util.rkt +test-expander: + racket -y $(PACKAGE-NAME)-test/tests/expander.rkt + test-compiler: racket -y $(PACKAGE-NAME)-test/tests/compiler.rkt @@ -196,4 +201,4 @@ performance-report: performance-regression-report: @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-compiler test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-expander test-compiler test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report diff --git a/qi-test/tests/expander.rkt b/qi-test/tests/expander.rkt new file mode 100644 index 000000000..54ebef3bb --- /dev/null +++ b/qi-test/tests/expander.rkt @@ -0,0 +1,37 @@ +#lang racket/base + +(provide tests) + +(require (for-syntax racket/base) + syntax/macro-testing + syntax-spec-v1 + racket/base + qi/flow/extended/expander + rackunit + rackunit/text-ui) + +(begin-for-syntax + (define (expand-flow stx) + ((nonterminal-expander closed-floe) stx))) + +;; TODO: these tests compare syntax as datums, but that's not sufficient +;; since the identifiers used may be bound differently which would affect +;; e.g. literal pattern matching. +;; To do it correctly, we need an alpha-equivalence predicate for Core Qi +;; that possibly delegates to a similar predicate for any Racket +;; subexpressions. This could be a predicate that syntax-spec could +;; infer, but it's unclear at this time. +(define tests + (test-suite + "expander tests" + + (check-true + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(~> sqr add1))) + '(thread (esc (#%host-expression sqr)) + (esc (#%host-expression add1)))))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/qi.rkt b/qi-test/tests/qi.rkt index 7bace1617..b471eb901 100644 --- a/qi-test/tests/qi.rkt +++ b/qi-test/tests/qi.rkt @@ -9,6 +9,7 @@ (prefix-in definitions: "definitions.rkt") (prefix-in macro: "macro.rkt") (prefix-in util: "util.rkt") + (prefix-in expander: "expander.rkt") (prefix-in compiler: "compiler.rkt")) (define tests @@ -22,6 +23,7 @@ definitions:tests macro:tests util:tests + expander:tests compiler:tests)) (module+ test From 2b23e171954e57cac953555b4920648c8be6fc14 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 16:20:16 -0700 Subject: [PATCH 332/338] a few more tests for the expander --- qi-lib/flow/extended/syntax.rkt | 4 +- qi-test/tests/expander.rkt | 80 ++++++++++++++++++++++++++++++--- 2 files changed, 76 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index a289c89ed..fe5bbdbc5 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -6,7 +6,9 @@ blanket-template-form fine-template-form partial-application-form - any-stx) + any-stx + ;; only used for unit tests + make-right-chiral) (require syntax/parse "../aux-syntax.rkt" diff --git a/qi-test/tests/expander.rkt b/qi-test/tests/expander.rkt index 54ebef3bb..272e81a5b 100644 --- a/qi-test/tests/expander.rkt +++ b/qi-test/tests/expander.rkt @@ -2,7 +2,8 @@ (provide tests) -(require (for-syntax racket/base) +(require (for-syntax racket/base + qi/flow/extended/syntax) syntax/macro-testing syntax-spec-v1 racket/base @@ -25,12 +26,77 @@ (test-suite "expander tests" - (check-true - (phase1-eval - (equal? (syntax->datum - (expand-flow #'(~> sqr add1))) - '(thread (esc (#%host-expression sqr)) - (esc (#%host-expression add1)))))))) + (test-true "basic expansion" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(~> sqr add1))) + '(thread (esc (#%host-expression sqr)) + (esc (#%host-expression add1)))))) + + (test-true "single core form (if)" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(if p c a))) + '(if (esc (#%host-expression p)) + (esc (#%host-expression c)) + (esc (#%host-expression a)))))) + + (test-true "mix of core forms" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(thread (amp a) + (relay b c) + (tee d e)))) + '(thread + (amp (esc (#%host-expression a))) + (relay (esc (#%host-expression b)) (esc (#%host-expression c))) + (tee (esc (#%host-expression d)) (esc (#%host-expression e))))))) + + (test-true "undecorated functions are escaped" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'f)) + '(esc (#%host-expression f))))) + + (test-true "literal is expanded to an explicit use of the gen core form" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'5)) + '(gen (#%host-expression 5))))) + + (test-true "fine template syntax expands to an explicit use of the #%fine-template core form" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(f _ a _ b))) + '(#%fine-template + ((#%host-expression f) + _ + (#%host-expression a) + _ + (#%host-expression b)))))) + + (test-true "blanket template syntax expands to an explicit use of the #%blanket-template core form" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(f a __ b))) + '(#%blanket-template + ((#%host-expression f) + (#%host-expression a) + __ + (#%host-expression b)))))) + + (test-true "expand chiral forms to a use of a blanket template" + (phase1-eval + (equal? (syntax->datum + (expand-flow + (datum->syntax #f + (map make-right-chiral + (syntax->list + #'(thread (f 1))))))) + '(thread (#%blanket-template + ((#%host-expression f) + (#%host-expression 1) + __)))))))) (module+ main (void From 58c360986e071e7a2545b20c83850c1a284a0da9 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 16:28:37 -0700 Subject: [PATCH 333/338] declare missing build dependency on syntax-spec --- qi-test/info.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/qi-test/info.rkt b/qi-test/info.rkt index 65d9a8e72..bd0a903de 100644 --- a/qi-test/info.rkt +++ b/qi-test/info.rkt @@ -6,5 +6,6 @@ (define build-deps '("rackunit-lib" "adjutor" "math-lib" - "qi-lib")) + "qi-lib" + "syntax-spec-v1")) (define clean '("compiled" "tests/compiled" "tests/private/compiled")) From 0503bb6f143ed6ffdda3f628cebb1fb392010765 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 15 Dec 2023 16:34:54 -0700 Subject: [PATCH 334/338] clarify a comment --- qi-lib/flow/extended/syntax.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt index fe5bbdbc5..1691380e9 100644 --- a/qi-lib/flow/extended/syntax.rkt +++ b/qi-lib/flow/extended/syntax.rkt @@ -7,7 +7,7 @@ fine-template-form partial-application-form any-stx - ;; only used for unit tests + ;; only provided for use in unit tests make-right-chiral) (require syntax/parse From ac5ba6d6d27414f9ca13d93c101a2c7a3ee4a5f4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 16 Dec 2023 11:20:56 -0700 Subject: [PATCH 335/338] Use de-expander to fix (in a temporary way) #134 Also expand the de-expander with a few more patterns --- qi-lib/flow.rkt | 5 ++++- qi-lib/flow/core/deforest.rkt | 18 ++---------------- 2 files changed, 6 insertions(+), 17 deletions(-) diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index 8a5639c1b..773d33328 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -13,6 +13,7 @@ "flow/extended/expander.rkt" "flow/core/compiler.rkt" "flow/extended/forms.rkt" + (for-syntax "flow/extended/util.rkt") (only-in "private/util.rkt" define-alias)) @@ -43,6 +44,8 @@ in the flow macro. [(expr0 expr ...+) (report-syntax-error (datum->syntax this-syntax - (cons 'flow (syntax->list this-syntax))) + (cons 'flow + (map prettify-flow-syntax + (syntax->list this-syntax)))) "(flow flo)" "flow expects a single flow specification, but it received many.")]))) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index e95c39327..26fdfb592 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -4,7 +4,8 @@ (require (for-syntax racket/base syntax/parse - racket/syntax-srcloc) + racket/syntax-srcloc + "../extended/util.rkt") racket/performance-hint racket/match racket/list @@ -26,21 +27,6 @@ [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) (begin-for-syntax - ;; Partially reconstructs original flow expressions. The chirality - ;; is lost and the form is already normalized at this point though! - (define (prettify-flow-syntax stx) - (syntax-parse stx - #:datum-literals (#%host-expression esc #%blanket-template #%fine-template) - [((~literal thread) - expr ...) - #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] - [((~or #%blanket-template #%fine-template) - (expr ...)) - (map prettify-flow-syntax (syntax->list #'(expr ...)))] - [(#%host-expression expr) #'expr] - [(esc expr) (prettify-flow-syntax #'expr)] - [expr #'expr])) - ;; Special "curry"ing for #%fine-templates. All #%host-expressions ;; are passed as they are and all (~datum _) are replaced by wrapper ;; lambda arguments. From 4b44be242e0fe9952a828e1782f61f3048797e68 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 16 Dec 2023 11:26:15 -0700 Subject: [PATCH 336/338] commit missing moved de-expander --- qi-lib/flow/extended/util.rkt | 36 +++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) create mode 100644 qi-lib/flow/extended/util.rkt diff --git a/qi-lib/flow/extended/util.rkt b/qi-lib/flow/extended/util.rkt new file mode 100644 index 000000000..4425e8f41 --- /dev/null +++ b/qi-lib/flow/extended/util.rkt @@ -0,0 +1,36 @@ +#lang racket/base + +(provide prettify-flow-syntax) + +(require syntax/parse) + +;; Partially reconstructs original flow expressions. The chirality +;; is lost and the form is already normalized at this point though! +(define (prettify-flow-syntax stx) + (syntax-parse stx + #:datum-literals (#%host-expression + esc + #%blanket-template + #%fine-template + thread + amp + tee + relay) + [(thread + expr ...) + #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [((~or #%blanket-template #%fine-template) + (expr ...)) + (map prettify-flow-syntax (syntax->list #'(expr ...)))] + [(#%host-expression expr) #'expr] + [((~datum amp) + expr ...) + #`(>< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [((~datum tee) + expr ...) + #`(-< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [((~datum relay) + expr ...) + #`(== #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(esc expr) (prettify-flow-syntax #'expr)] + [expr #'expr])) From bf581a4d73a4a8ff5e9443d671511f345aa49539 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Sat, 16 Dec 2023 12:15:24 -0700 Subject: [PATCH 337/338] expand de-expander to full core language (except feedback) --- qi-lib/flow/extended/util.rkt | 93 +++++++++++++++++++++++++++++++++-- 1 file changed, 89 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow/extended/util.rkt b/qi-lib/flow/extended/util.rkt index 4425e8f41..94cd46a08 100644 --- a/qi-lib/flow/extended/util.rkt +++ b/qi-lib/flow/extended/util.rkt @@ -15,7 +15,27 @@ thread amp tee - relay) + relay + gen + pass + sep + and + or + not + all + any + fanout + group + if + sieve + partition + try + >> + << + feedback + loop + loop2 + clos) [(thread expr ...) #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] @@ -23,14 +43,79 @@ (expr ...)) (map prettify-flow-syntax (syntax->list #'(expr ...)))] [(#%host-expression expr) #'expr] - [((~datum amp) + [(amp expr ...) #`(>< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] - [((~datum tee) + [(tee expr ...) #`(-< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] - [((~datum relay) + [(relay expr ...) #`(== #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(gen + expr ...) + #`(gen #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(pass + expr ...) + #`(pass #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(sep + expr ...) + #`(sep #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(and + expr ...) + #`(and #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(or + expr ...) + #`(or #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(not + expr ...) + #`(not #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(all + expr ...) + #`(all #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(any + expr ...) + #`(any #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(fanout + expr ...) + #`(fanout #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(group + expr ...) + #`(group #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(if + expr ...) + #`(if #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(sieve + expr ...) + #`(sieve #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(partition + [e1 e2] ...) + #:with e1-prettified (map prettify-flow-syntax (attribute e1)) + #:with e2-prettified (map prettify-flow-syntax (attribute e2)) + #`(partition [e1-prettified e2-prettified])] + [(try expr + [e1 e2] ...) + #:with expr-prettified (prettify-flow-syntax #'expr) + #:with e1-prettified (map prettify-flow-syntax (attribute e1)) + #:with e2-prettified (map prettify-flow-syntax (attribute e2)) + #`(try expr-prettified [e1-prettified e2-prettified])] + [(>> + expr ...) + #`(>> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(<< + expr ...) + #`(<< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(feedback + expr ...) + #`(feedback #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(loop + expr ...) + #`(loop #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(loop2 + expr ...) + #`(loop2 #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(clos + expr ...) + #`(clos #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] [(esc expr) (prettify-flow-syntax #'expr)] [expr #'expr])) From 1cef2c16d8eaf45df5e3e76628db87033a9d3f57 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 18 Dec 2023 13:26:03 -0700 Subject: [PATCH 338/338] local benchmark for the `as` binding form --- qi-sdk/profile/local/benchmarks.rkt | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/qi-sdk/profile/local/benchmarks.rkt b/qi-sdk/profile/local/benchmarks.rkt index 75c3d73be..3a4794c57 100755 --- a/qi-sdk/profile/local/benchmarks.rkt +++ b/qi-sdk/profile/local/benchmarks.rkt @@ -178,6 +178,18 @@ for the forms are run. check-values 300000))) +(module as "base.rkt" + (provide run) + + (define (~as v) + ((☯ (~> (as w))) + v)) + + (define (run) + (run-benchmark ~as + check-value + 500000))) + (module ground "base.rkt" (provide run) @@ -913,6 +925,7 @@ for the forms are run. (prefix-in relay: (submod ".." relay)) (prefix-in relay*: (submod ".." relay*)) (prefix-in amp: (submod ".." amp)) + (prefix-in as: (submod ".." as)) (prefix-in ground: (submod ".." ground)) (prefix-in thread: (submod ".." thread)) (prefix-in thread-right: (submod ".." thread-right)) @@ -983,6 +996,7 @@ for the forms are run. "relay" relay:run "relay*" relay*:run "amp" amp:run + "as" as:run "ground" ground:run "thread" thread:run "thread-right" thread-right:run