From 00d1ed7ef868da3605c5f2eeda8621275f23d647 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Mon, 11 Mar 2024 17:07:27 +0100 Subject: [PATCH 01/21] List-ref and cad*r deforestation Deforest all variants of cad*r: - car - cadr - caddr - cadddr - caddddr - cadddddr Deforest (using the same underlying implementation) list-ref as well. --- qi-lib/flow/core/deforest.rkt | 38 +++++++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 11 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 71e35896..bd45049d 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -129,6 +129,15 @@ [else (λ (ctx name) #'(λ (v) v))])])) + (define-syntax-class cad*r-datum + #:attributes (countdown) + (pattern (~datum car) #:attr countdown #'0) + (pattern (~datum cadr) #:attr countdown #'1) + (pattern (~datum caddr) #:attr countdown #'2) + (pattern (~datum cadddr) #:attr countdown #'3) + (pattern (~datum caddddr) #:attr countdown #'4) + (pattern (~datum cadddddr) #:attr countdown #'5)) + ;; 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 @@ -238,14 +247,18 @@ _))) #:attr end #'(foldl-cstream-next op init)) - (pattern (~or (esc (#%host-expression (~datum car))) + (pattern (~or (esc (#%host-expression cad*r:cad*r-datum)) (#%fine-template - ((#%host-expression (~datum car)) - _)) + ((#%host-expression cad*r:cad*r-datum) _)) + (#%blanket-template + ((#%host-expression cad*r:cad*r-datum) __))) + #:attr end #'(cad*r-cstream-next cad*r.countdown)) + + (pattern (~or (#%fine-template + ((#%host-expression (~datum list-ref)) _ idx)) (#%blanket-template - ((#%host-expression (~datum car)) - __))) - #:attr end #'(car-cstream-next)) + ((#%host-expression (~datum list-ref)) __ idx))) + #:attr end #'(cad*r-cstream-next idx)) (pattern (~literal cstream->list) #:attr end #'(cstream-next->list))) @@ -407,16 +420,19 @@ (loop (op value acc) state))) state)))) - (define-inline (car-cstream-next next ctx src) + (define-inline (cad*r-cstream-next init-countdown next ctx src) (λ (state) - (let loop ([state state]) + (let loop ([state state] + [countdown init-countdown]) ((next (λ () ((contract (-> pair? any) (λ (v) v) - 'car-cstream-next ctx #f + 'cad*r-cstream-next ctx #f src) '())) - (λ (state) (loop state)) + (λ (state) (loop state countdown)) (λ (value state) - value)) + (if (zero? countdown) + value + (loop state (sub1 countdown))))) state)))) ) From a4789120d8c88482eda1063ff63115ada7be1c8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 23 Mar 2024 15:50:42 +0100 Subject: [PATCH 02/21] Deforestation of length, empty?, and null?. --- qi-lib/flow/core/deforest.rkt | 37 +++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index bd45049d..038da687 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -260,6 +260,25 @@ ((#%host-expression (~datum list-ref)) __ idx))) #:attr end #'(cad*r-cstream-next idx)) + (pattern (~or (esc + (#%host-expression (~datum length))) + (#%fine-template + ((#%host-expression (~datum length)) _)) + (#%blanket-template + ((#%host-expression (~datum length)) __))) + #:attr end #'(length-cstream-next)) + + (pattern (~or (esc + (#%host-expression (~or (~datum empty?) + (~datum null?)))) + (#%fine-template + ((#%host-expression (~or (~datum empty?) + (~datum null?))) _)) + (#%blanket-template + ((#%host-expression (~or (~datum empty?) + (~datum null?))) __))) + #:attr end #'(empty?-cstream-next)) + (pattern (~literal cstream->list) #:attr end #'(cstream-next->list))) @@ -435,4 +454,22 @@ (loop state (sub1 countdown))))) state)))) + (define-inline (length-cstream-next next ctx src) + (λ (state) + (let loop ([state state] + [the-length 0]) + ((next (λ () the-length) + (λ (state) (loop state the-length)) + (λ (value state) + (loop state (add1 the-length)))) + state)))) + + (define-inline (empty?-cstream-next next ctx src) + (λ (state) + (let loop ([state state]) + ((next (λ () #t) + (λ (state) (loop state)) + (λ (value state) #f)) + state)))) + ) From 7a292bb8bc9eef069c48f7d0be03c6934a883076 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 23 Mar 2024 16:12:52 +0100 Subject: [PATCH 03/21] Deforest filter-map. --- qi-lib/flow/core/deforest.rkt | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index 038da687..d6f06c32 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -180,17 +180,17 @@ ;; 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 (~or (~datum filter) + (~datum filter-map))) (#%host-expression f) __)) (#%fine-template - ((#%host-expression (~datum filter)) + ((#%host-expression (~or (~datum filter) + (~datum filter-map))) (#%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` @@ -216,7 +216,17 @@ ((#%host-expression (~datum filter)) (#%host-expression f) _))) - #:attr next #'filter-cstream-next)) + #:attr next #'filter-cstream-next) + + (pattern (~or (#%blanket-template + ((#%host-expression (~datum filter-map)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum filter-map)) + (#%host-expression f) + _))) + #:attr next #'filter-map-cstream-next)) ;; Terminates the fused sequence (consumes the stream) and produces ;; an actual result value. @@ -410,6 +420,16 @@ (yield value state) (skip state)))))) + (define-inline (filter-map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (let ([fv (f value)]) + (if fv + (yield fv state) + (skip state))))))) + ;; Consumers (define-inline (cstream-next->list next ctx src) From f7b4b288b612a1f65a6605012b9ab7aac66325b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 6 Apr 2024 19:01:52 +0200 Subject: [PATCH 04/21] Pass deforested operation name in cad*r-cstream-next. --- qi-lib/flow/core/deforest.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt index d6f06c32..7ee98035 100644 --- a/qi-lib/flow/core/deforest.rkt +++ b/qi-lib/flow/core/deforest.rkt @@ -262,13 +262,13 @@ ((#%host-expression cad*r:cad*r-datum) _)) (#%blanket-template ((#%host-expression cad*r:cad*r-datum) __))) - #:attr end #'(cad*r-cstream-next cad*r.countdown)) + #:attr end #'(cad*r-cstream-next cad*r.countdown 'cad*r)) (pattern (~or (#%fine-template ((#%host-expression (~datum list-ref)) _ idx)) (#%blanket-template ((#%host-expression (~datum list-ref)) __ idx))) - #:attr end #'(cad*r-cstream-next idx)) + #:attr end #'(cad*r-cstream-next idx 'list-ref)) (pattern (~or (esc (#%host-expression (~datum length))) @@ -459,13 +459,13 @@ (loop (op value acc) state))) state)))) - (define-inline (cad*r-cstream-next init-countdown next ctx src) + (define-inline (cad*r-cstream-next init-countdown name next ctx src) (λ (state) (let loop ([state state] [countdown init-countdown]) ((next (λ () ((contract (-> pair? any) (λ (v) v) - 'cad*r-cstream-next ctx #f + name ctx #f src) '())) (λ (state) (loop state countdown)) (λ (value state) From c55afdf62dc0d569c87c99c3a3a3c0d3260a0979 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 28 Apr 2024 18:49:05 +0200 Subject: [PATCH 05/21] Fix failing car-deforested? test. --- qi-test/tests/compiler/rules/private/deforest-util.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qi-test/tests/compiler/rules/private/deforest-util.rkt b/qi-test/tests/compiler/rules/private/deforest-util.rkt index 193a986d..7746150e 100644 --- a/qi-test/tests/compiler/rules/private/deforest-util.rkt +++ b/qi-test/tests/compiler/rules/private/deforest-util.rkt @@ -20,4 +20,4 @@ (string-contains? (format "~a" exp) "filter-cstream")) (define (car-deforested? exp) - (string-contains? (format "~a" exp) "car-cstream")) + (string-contains? (format "~a" exp) "cad*r-cstream")) From 305d1f942765a444753060e7de5d29a406b2c388 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Tue, 30 Apr 2024 15:34:56 +0200 Subject: [PATCH 06/21] Cleaner syntax matching and production separation. - split syntax matching from syntax production - improve naming of syntax classes - remove unused template variables --- qi-lib/flow/core/deforest-cps.rkt | 323 ++++++++++++++++++ qi-lib/flow/core/deforest-syntax.rkt | 302 ++++++++++++++++ qi-lib/flow/core/deforest-templates.rkt | 10 + .../compiler/rules/private/deforest-util.rkt | 2 +- 4 files changed, 636 insertions(+), 1 deletion(-) create mode 100644 qi-lib/flow/core/deforest-cps.rkt create mode 100644 qi-lib/flow/core/deforest-syntax.rkt create mode 100644 qi-lib/flow/core/deforest-templates.rkt diff --git a/qi-lib/flow/core/deforest-cps.rkt b/qi-lib/flow/core/deforest-cps.rkt new file mode 100644 index 00000000..c834aafa --- /dev/null +++ b/qi-lib/flow/core/deforest-cps.rkt @@ -0,0 +1,323 @@ +#lang racket/base + +(provide (for-syntax deforest-pass)) + +(require (for-syntax racket/base + syntax/parse + "deforest-syntax.rkt" + "../extended/util.rkt" + syntax/srcloc + racket/syntax-srcloc) + "deforest-templates.rkt" + racket/performance-hint + racket/match + racket/contract/base) + +;; "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 + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Producers + + ;; 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]) + #'(lambda (proc) + (lambda (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) + #'(lambda (v) + (lambda () + (v pre-arg ... post-arg ...)))] + [else + #'(lambda (v) + (lambda 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 + (lambda (ctx name) #'(lambda (v) v))])])) + + (define-syntax-class fsp + #:attributes (curry name contract prepare next) + (pattern range:fsp-range + #:attr name #''range + #:attr contract #'(->* (real?) (real? real?) any) + #:attr prepare #'range->cstream-prepare + #:attr next #'range->cstream-next + #:attr curry (make-producer-curry 1 3 + range.blanket? #'range.pre-arg #'range.post-arg + range.fine? #'range.arg + range)) + (pattern default:fsp-default + #:attr name #''list->cstream + #:attr contract #'(-> list? any) + #:attr prepare #'list->cstream-prepare + #:attr next #'list->cstream-next + #:attr curry (lambda (ctx name) #'(lambda (v) v))) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Transformers + + (define-syntax-class fst + #:attributes (next f) + (pattern filter:fst-filter + #:attr f #'filter.f + #:attr next #'filter-cstream-next) + (pattern map:fst-map + #:attr f #'map.f + #:attr next #'map-cstream-next) + (pattern filter-map:fst-filter-map + #:attr f #'filter-map.f + #:attr next #'filter-map-cstream-next) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Consumers + + (define-syntax-class fsc + #:attributes (end) + (pattern foldr:fsc-foldr + #:attr end #'(foldr-cstream-next foldr.op foldr.init)) + (pattern foldl:fsc-foldl + #:attr end #'(foldl-cstream-next foldl.op foldl.init)) + (pattern list-ref:fsc-list-ref + #:attr end #'(list-ref-cstream-next list-ref.pos 'list-ref.name)) + (pattern length:fsc-length + #:attr end #'(length-cstream-next)) + (pattern empty?:fsc-empty? + #:attr end #'(empty?-cstream-next)) + (pattern default:fsc-default + #:attr end #'(cstream-next->list)) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; The pass + + ;; Performs deforestation rewrite on the whole syntax tree. + (define-and-register-deforest-pass (deforest-pass ops ctx) + (syntax-parse (reverse ops) + [(c:fsc + t:fst ... + p:fsp) + ;; 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) + '#,(build-source-location-vector + (syntax-srcloc ctx)))) + p.name + '#,(prettify-flow-syntax ctx) + #f + '#,(build-source-location-vector + (syntax-srcloc ctx)))))]))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Runtime + +(begin-encourage-inline + + ;; Producers + + (define-inline (list->cstream-next done skip yield) + (λ (state) + (cond [(null? state) (done)] + [else (yield (car state) (cdr state))]))) + + (define-inline (list->cstream-prepare next) + (case-lambda + [(lst) (next lst)] + [rest (void)])) + + (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 (range->cstream-prepare next) + (case-lambda + [(h) (next (list 0 h 1))] + [(l h) (next (list l h 1))] + [(l h s) (next (list l h s))] + [rest (void)])) + + ;; Transformers + + (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 (filter-map-cstream-next f next) + (λ (done skip yield) + (next done + skip + (λ (value state) + (let ([fv (f value)]) + (if fv + (yield fv state) + (skip state))))))) + + ;; Consumers + + (define-inline (cstream-next->list next ctx src) + (λ (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 ctx src) + (λ (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 ctx src) + (λ (state) + (let loop ([acc init] [state state]) + ((next (λ () acc) + (λ (state) (loop acc state)) + (λ (value state) + (loop (op value acc) state))) + state)))) + + (define-inline (list-ref-cstream-next init-countdown name next ctx src) + (λ (state) + (let loop ([state state] + [countdown init-countdown]) + ((next (λ () ((contract (-> pair? any) + (λ (v) v) + name ctx #f + src) '())) + (λ (state) (loop state countdown)) + (λ (value state) + (if (zero? countdown) + value + (loop state (sub1 countdown))))) + state)))) + + (define-inline (length-cstream-next next ctx src) + (λ (state) + (let loop ([state state] + [the-length 0]) + ((next (λ () the-length) + (λ (state) (loop state the-length)) + (λ (value state) + (loop state (add1 the-length)))) + state)))) + + (define-inline (empty?-cstream-next next ctx src) + (λ (state) + (let loop ([state state]) + ((next (λ () #t) + (λ (state) (loop state)) + (λ (value state) #f)) + state)))) + + ) diff --git a/qi-lib/flow/core/deforest-syntax.rkt b/qi-lib/flow/core/deforest-syntax.rkt new file mode 100644 index 00000000..790a771b --- /dev/null +++ b/qi-lib/flow/core/deforest-syntax.rkt @@ -0,0 +1,302 @@ +#lang racket/base + +(provide fsp-intf + fsp-range + fsp-default + + fst-intf + fst-filter + fst-map + fst-filter-map + fst-take + + fsc-intf + fsc-foldr + fsc-foldl + fsc-list-ref + fsc-length + fsc-empty? + fsc-default + + define-and-register-deforest-pass + ) + +(require syntax/parse + "passes.rkt" + "strategy.rkt" + (for-template racket/base + "passes.rkt" + "strategy.rkt" + "deforest-templates.rkt") + (for-syntax racket/base + syntax/parse)) + +(define-literal-set fs-literals + #:datum-literals (esc #%host-expression #%fine-template #%blanket-template _ __) + ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Producers + +(define-syntax-class fsp-range + #:attributes (blanket? fine? arg pre-arg post-arg) + #:literal-sets (fs-literals) + #:datum-literals (range) + (pattern (esc (#%host-expression range)) + #:attr arg #f + #:attr pre-arg #f + #:attr post-arg #f + #:attr blanket? #f + #:attr fine? #f) + (pattern (#%fine-template + ((#%host-expression range) + the-arg ...)) + #:attr arg #'(the-arg ...) + #:attr pre-arg #f + #:attr post-arg #f + #:attr blanket? #f + #:attr fine? #t) + (pattern (#%blanket-template + ((#%host-expression range) + (#%host-expression the-pre-arg) ... + __ + (#%host-expression the-post-arg) ...)) + #:attr arg #f + #:attr pre-arg #'(the-pre-arg ...) + #:attr post-arg #'(the-post-arg ...) + #:attr blanket? #t + #:attr fine? #f)) + +(define-syntax-class fsp-default + #:datum-literals (list->cstream) + (pattern list->cstream + #:attr contract #'(-> list? any) + #:attr name #''list->cstream)) + +(define-syntax-class fsp-intf + (pattern (~or _:fsp-range + _:fsp-default))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Transformers + +(define-syntax-class fst-filter + #:attributes (f) + #:literal-sets (fs-literals) + #:datum-literals (filter) + (pattern (#%blanket-template + ((#%host-expression filter) + (#%host-expression f) + __))) + (pattern (#%fine-template + ((#%host-expression filter) + (#%host-expression f) + _)))) + +(define-syntax-class fst-map + #:attributes (f) + #:literal-sets (fs-literals) + #:datum-literals (map) + (pattern (#%blanket-template + ((#%host-expression map) + (#%host-expression f) + __))) + (pattern (#%fine-template + ((#%host-expression map) + (#%host-expression f) + _)))) + +(define-syntax-class fst-filter-map + #:attributes (f) + #:literal-sets (fs-literals) + #:datum-literals (filter-map) + (pattern (#%blanket-template + ((#%host-expression filter-map) + (#%host-expression f) + __))) + (pattern (#%fine-template + ((#%host-expression filter-map) + (#%host-expression f) + _)))) + +(define-syntax-class fst-take + #:attributes (n) + #:literal-sets (fs-literals) + #:datum-literals (take) + (pattern (#%blanket-template + ((#%host-expression take) + __ + (#%host-expression n)))) + (pattern (#%fine-template + ((#%host-expression take) + _ + (#%host-expression n))))) + +(define-syntax-class fst-intf0 + (pattern (~or filter:fst-filter + filter-map:fst-filter-map))) + +(define-syntax-class fst-intf + (pattern (~or _:fst-filter + _:fst-map + _:fst-filter-map + _:fst-take))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Consumers + +(define-syntax-class fsc-foldr + #:attributes (op init) + #:literal-sets (fs-literals) + #:datum-literals (foldr) + (pattern (#%blanket-template + ((#%host-expression foldr) + (#%host-expression op) + (#%host-expression init) + __))) + (pattern (#%fine-template + ((#%host-expression foldr) + (#%host-expression op) + (#%host-expression init) + _)))) + +(define-syntax-class fsc-foldl + #:attributes (op init) + #:literal-sets (fs-literals) + #:datum-literals (foldl) + (pattern (#%blanket-template + ((#%host-expression foldl) + (#%host-expression op) + (#%host-expression init) + __))) + (pattern (#%fine-template + ((#%host-expression foldl) + (#%host-expression op) + (#%host-expression init) + _)))) + +(define-syntax-class cad*r-datum + #:attributes (countdown) + (pattern (~datum car) #:attr countdown #'0) + (pattern (~datum cadr) #:attr countdown #'1) + (pattern (~datum caddr) #:attr countdown #'2) + (pattern (~datum cadddr) #:attr countdown #'3) + (pattern (~datum caddddr) #:attr countdown #'4) + (pattern (~datum cadddddr) #:attr countdown #'5)) + +(define-syntax-class fsc-list-ref + #:attributes (pos name) + #:literal-sets (fs-literals) + #:datum-literals (list-ref) + (pattern (~or (#%fine-template + ((#%host-expression list-ref) _ idx)) + (#%blanket-template + ((#%host-expression list-ref) __ idx))) + #:attr pos #'idx + #:attr name #'list-ref) + (pattern (~or (esc (#%host-expression cad*r:cad*r-datum)) + (#%fine-template + ((#%host-expression cad*r:cad*r-datum) _)) + (#%blanket-template + ((#%host-expression cad*r:cad*r-datum) __))) + #:attr pos #'cad*r.countdown + #:attr name #'cad*r)) + +(define-syntax-class fsc-length + #:literal-sets (fs-literals) + #:datum-literals (length) + (pattern (esc + (#%host-expression length))) + (pattern (#%fine-template + ((#%host-expression length) _))) + (pattern (#%blanket-template + ((#%host-expression length) __)))) + +(define-syntax-class fsc-empty? + #:literal-sets (fs-literals) + #:datum-literals (empty? null?) + (pattern (esc + (#%host-expression (~or empty? + null?)))) + (pattern (#%fine-template + ((#%host-expression (~or empty? + null?)) _))) + (pattern (#%blanket-template + ((#%host-expression (~or empty? + null?)) __)))) + +(define-syntax-class fsc-default + #:datum-literals (cstream->list) + (pattern cstream->list)) + +(define-syntax-class fsc-intf + (pattern (~or _:fsc-foldr + _:fsc-foldl + _:fsc-list-ref + _:fsc-length + _:fsc-empty? + _:fsc-default + ))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The actual fusion generator implementation + +;; Used only in deforest-rewrite to properly recognize the end of +;; fusable sequence. +(define-syntax-class non-fusable + (pattern (~not (~or _:fst-intf + _:fsp-intf + _:fsc-intf)))) + +(define (make-deforest-rewrite generate-fused-operation) + (lambda (stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fsp-intf + ;; There can be zero transformers here: + t:fst-intf ... + c:fsc-intf + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fst-intf0 + t:fst-intf ... + c:fsc-intf + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fsp-intf + ;; Must be 1 or more transformers here: + t:fst-intf ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fst-intf0 + f:fst-intf ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + ;; return the input syntax unchanged if no rules + ;; are applicable + [_ stx]))) + +(define-syntax (define-and-register-deforest-pass stx) + (syntax-parse stx + ((_ (deforest-pass ops ctx) expr ...) + #'(define-and-register-pass 100 (deforest-pass stx) + (find-and-map/qi + (make-deforest-rewrite + (lambda (ops ctx) + expr ...)) + stx))))) diff --git a/qi-lib/flow/core/deforest-templates.rkt b/qi-lib/flow/core/deforest-templates.rkt new file mode 100644 index 00000000..9f9038bc --- /dev/null +++ b/qi-lib/flow/core/deforest-templates.rkt @@ -0,0 +1,10 @@ +#lang racket/base + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Special syntax for templates + +;; These bindings are used for ~literal matching to introduce implicit +;; producer/consumer when none is explicitly given in the flow. +(provide cstream->list list->cstream) +(define cstream->list #'-cstream->list) +(define list->cstream #'-list->cstream) diff --git a/qi-test/tests/compiler/rules/private/deforest-util.rkt b/qi-test/tests/compiler/rules/private/deforest-util.rkt index 7746150e..4ab71c7d 100644 --- a/qi-test/tests/compiler/rules/private/deforest-util.rkt +++ b/qi-test/tests/compiler/rules/private/deforest-util.rkt @@ -20,4 +20,4 @@ (string-contains? (format "~a" exp) "filter-cstream")) (define (car-deforested? exp) - (string-contains? (format "~a" exp) "cad*r-cstream")) + (string-contains? (format "~a" exp) "list-ref-cstream")) From 8383bcfe9f8e1136dac2bad3135974eb519ab635 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 May 2024 14:42:57 +0200 Subject: [PATCH 07/21] Split compiler passes into separate modules. - preliminary splitting of the compiler into separate modules for separate passes - update tests to reflect new paths --- .../pass-0010-normalize.rkt} | 6 +- qi-lib/flow/core/passes/pass-1000-qi0.rkt | 423 ++++++++++++++++++ .../flow/core/passes/pass-2000-bindings.rkt | 70 +++ qi-test/tests/compiler/rules/deforest.rkt | 2 +- qi-test/tests/compiler/rules/full-cycle.rkt | 2 +- 5 files changed, 498 insertions(+), 5 deletions(-) rename qi-lib/flow/core/{normalize.rkt => passes/pass-0010-normalize.rkt} (95%) create mode 100644 qi-lib/flow/core/passes/pass-1000-qi0.rkt create mode 100644 qi-lib/flow/core/passes/pass-2000-bindings.rkt diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/passes/pass-0010-normalize.rkt similarity index 95% rename from qi-lib/flow/core/normalize.rkt rename to qi-lib/flow/core/passes/pass-0010-normalize.rkt index 387aac0a..fce732c0 100644 --- a/qi-lib/flow/core/normalize.rkt +++ b/qi-lib/flow/core/passes/pass-0010-normalize.rkt @@ -4,9 +4,9 @@ (require (for-syntax racket/base syntax/parse - "strategy.rkt" - "private/form-property.rkt") - "passes.rkt") + "../strategy.rkt" + "../private/form-property.rkt") + "../passes.rkt") ;; 0. "Qi-normal form" (begin-for-syntax diff --git a/qi-lib/flow/core/passes/pass-1000-qi0.rkt b/qi-lib/flow/core/passes/pass-1000-qi0.rkt new file mode 100644 index 00000000..656b7358 --- /dev/null +++ b/qi-lib/flow/core/passes/pass-1000-qi0.rkt @@ -0,0 +1,423 @@ +#lang racket/base + +(require "../passes.rkt" + (prefix-in fancy: fancy-app) + "../impl.rkt" + racket/function + (only-in racket/list make-list) + (for-syntax racket/base + syntax/parse + "../syntax.rkt" + "../../aux-syntax.rkt" + (only-in racket/list make-list) + )) + +(begin-for-syntax + + (define-and-register-pass 1000 (qi0-wrapper stx) + (syntax-parse stx + (ex #'(qi0->racket ex)))) + + ) + +(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)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; 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 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 + #'(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)] + [e:group-form (group-parser #'e)] + ;; 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 + [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)] + [((~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 + ;; 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)] + + ;; 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 ...)] + + ;; 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: + +#| +A note on error handling: + +Some forms, in addition to handling legitimate syntax, also have +catch-all versions that exist purely to provide a helpful message +indicating a syntax error. We do this since a priori the qi0->racket macro +would ignore syntax that doesn't match any pattern. Yet, for all of +these named forms, we know that (or at least, it is prudent to assume +that) the user intended to employ that particular form of the DSL. So +instead of allowing it to fall through for interpretation as Racket +code, which would yield potentially inscrutable errors, the catch-all +forms allow us to provide appropriate error messages at the level of +the DSL. + +|# + +(begin-for-syntax + + (define (sep-parser stx) + (syntax-parse stx + [_:id + #'(qi0->racket (if (esc list?) + (#%fine-template (apply values _)) + (#%fine-template (raise-argument-error '△ + "list?" + _))))] + [(_ onex:clause) + #'(λ (v . vs) + ((qi0->racket (~> △ (>< (#%fine-template (apply (qi0->racket onex) _ vs))))) v))])) + + (define (select-parser stx) + (syntax-parse stx + [(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))])) + + (define (block-parser stx) + (syntax-parse stx + [(_ n:number ...) + #'(qi0->racket (~> (esc (except-args n ...)) + △))])) + + (define (group-parser stx) + (syntax-parse stx + [(_ n:expr + selection-onex:clause + remainder-onex:clause) + #'(loom-compose (qi0->racket selection-onex) + (qi0->racket remainder-onex) + n)] + [_:id + #'(λ (n selection-flo remainder-flo . vs) + (apply (qi0->racket (group n + (esc selection-flo) + (esc remainder-flo))) vs))])) + + (define (sieve-parser stx) + (syntax-parse stx + [(_ condition:clause + sonex:clause + ronex:clause) + #'(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 (esc condition)) (esc sonex)) + (~> (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 + [error-condition-flo error-handler-flo] + ...+) + #'(λ args + (with-handlers ([(qi0->racket error-condition-flo) + (λ (e) + ;; TODO: may be good to support reference to the + ;; error via a binding / syntax parameter + (apply (qi0->racket error-handler-flo) args))] + ...) + (apply (qi0->racket flo) args)))])) + + (define (if-parser stx) + (syntax-parse stx + [(_ consequent:clause + alternative:clause) + #'(λ (f . args) + (if (apply f args) + (apply (qi0->racket consequent) args) + (apply (qi0->racket alternative) args)))] + [(_ condition:clause + consequent:clause + alternative:clause) + #'(λ args + (if (apply (qi0->racket condition) args) + (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) + ((~datum then) thenex:clause) + onex:clause) + #'(feedback-while (qi0->racket onex) + (qi0->racket tilex) + (qi0->racket thenex))] + [(_ ((~datum while) tilex:clause) + ((~datum then) thenex:clause)) + #'(λ (f . args) + (apply (qi0->racket (feedback (while tilex) (then thenex) (esc f))) + args))] + [(_ ((~datum while) tilex:clause) onex:clause) + #'(qi0->racket (feedback (while tilex) (then _) onex))] + [(_ ((~datum while) tilex:clause)) + #'(qi0->racket (feedback (while tilex) (then _)))] + [(_ n:expr + ((~datum then) thenex:clause) + onex:clause) + #'(lambda args + (apply (feedback-times (qi0->racket onex) n (qi0->racket thenex)) + args))] + [(_ n:expr + ((~datum then) thenex:clause)) + #'(λ (f . args) + (apply (qi0->racket (feedback n (then thenex) (esc f))) args))] + [(_ n:expr onex:clause) + #'(qi0->racket (feedback n (then _) onex))] + [(_ onex:clause) + #'(λ (n . args) + (apply (qi0->racket (feedback n onex)) args))] + [_:id + #'(λ (n flo . args) + (apply (qi0->racket (feedback n (esc flo))) + args))])) + + (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 (relay-parser stx) + (syntax-parse stx + [((~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 ==)] + [(_ onex:clause) + #'(curry map-values (qi0->racket onex))])) + + (define (pass-parser stx) + (syntax-parse stx + [_:id + #'filter-values] + [(_ onex:clause) + #'(curry filter-values (qi0->racket onex))])) + + (define (fold-left-parser stx) + (syntax-parse stx + [_:id + #'foldl-values] + [(_ fn init) + #'(qi0->racket (~> (-< (gen (qi0->racket fn) + (qi0->racket init)) + _) + >>))] + [(_ fn) + #'(qi0->racket (>> fn (gen ((qi0->racket fn)))))])) + + (define (fold-right-parser stx) + (syntax-parse stx + [_:id + #'foldr-values] + [(_ fn init) + #'(qi0->racket (~> (-< (gen (qi0->racket fn) + (qi0->racket init)) + _) + <<))] + [(_ fn) + #'(qi0->racket (<< fn (gen ((qi0->racket fn)))))])) + + (define (loop-parser stx) + (syntax-parse stx + [(_ pred:clause mapex:clause combex:clause retex:clause) + #'(letrec ([loop (qi0->racket (if pred + (~> (group 1 mapex (esc loop)) + combex) + retex))]) + loop)] + [(_ pred:clause mapex:clause combex:clause) + #'(qi0->racket (loop pred mapex combex ⏚))] + [(_ pred:clause mapex:clause) + #'(qi0->racket (loop pred mapex _ ⏚))] + [(_ mapex:clause) + #'(qi0->racket (loop (gen #t) mapex _ ⏚))] + [_:id #'(λ (predf mapf combf retf . args) + (apply (qi0->racket (loop (esc predf) + (esc mapf) + (esc combf) + (esc retf))) + args))])) + + (define (clos-parser stx) + (syntax-parse stx + [_:id + #:do [(define chirality (syntax-property stx 'chirality))] + (if (and chirality (eq? chirality 'right)) + #'(λ (f . args) (apply curryr f args)) + #'(λ (f . args) (apply curry f args)))] + [(_ onex:clause) + #:do [(define chirality (syntax-property stx 'chirality))] + (if (and chirality (eq? chirality 'right)) + #'(λ args + (qi0->racket (~> (-< _ (~> (gen args) △)) + onex))) + #'(λ args + (qi0->racket (~> (-< (~> (gen args) △) _) + onex))))])) + + (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. + ;; 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 ...) ...)" + #'(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 ...))]))) diff --git a/qi-lib/flow/core/passes/pass-2000-bindings.rkt b/qi-lib/flow/core/passes/pass-2000-bindings.rkt new file mode 100644 index 00000000..bd15a483 --- /dev/null +++ b/qi-lib/flow/core/passes/pass-2000-bindings.rkt @@ -0,0 +1,70 @@ +#lang racket/base + +(require (for-syntax racket/base + syntax/parse + "../strategy.rkt") + racket/undefined + "../passes.rkt") + +;; 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))) ⏚) ...))))) + +(begin-for-syntax + + ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) + ;; TODO: use a box instead of set! + (define (rewrite-all-bindings 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)] + [_ this-syntax]) + stx)) + + (define (bound-identifiers stx) + (let ([ids null]) + (find-and-map/qi (syntax-parser + [((~datum as) x ...) + (set! ids + (append (attribute x) ids))] + [_ this-syntax]) + stx) + ids)) + + ;; wrap stx with (let ([v undefined] ...) stx) for v ∈ ids + (define (wrap-with-scopes stx ids) + (with-syntax ([(v ...) ids]) + #`(let ([v undefined] ...) #,stx))) + + (define-and-register-pass 2000 (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) + (bound-identifiers stx)))) + diff --git a/qi-test/tests/compiler/rules/deforest.rkt b/qi-test/tests/compiler/rules/deforest.rkt index 5d2f0670..9e80ea73 100644 --- a/qi-test/tests/compiler/rules/deforest.rkt +++ b/qi-test/tests/compiler/rules/deforest.rkt @@ -9,7 +9,7 @@ ;; necessary to correctly expand the right-threading form qi/flow/extended/forms qi/flow/core/compiler - qi/flow/core/deforest + qi/flow/core/passes/pass-0100-deforest syntax/macro-testing (submod qi/flow/extended/expander invoke) rackunit diff --git a/qi-test/tests/compiler/rules/full-cycle.rkt b/qi-test/tests/compiler/rules/full-cycle.rkt index 52d21a9a..5b16f09c 100644 --- a/qi-test/tests/compiler/rules/full-cycle.rkt +++ b/qi-test/tests/compiler/rules/full-cycle.rkt @@ -10,7 +10,7 @@ rackunit rackunit/text-ui syntax/macro-testing - qi/flow/core/deforest + qi/flow/core/passes/pass-0100-deforest "private/deforest-util.rkt" (submod qi/flow/extended/expander invoke)) From 141de0fae1fc57c140d60f59347bc34fdca80959 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 May 2024 14:47:59 +0200 Subject: [PATCH 08/21] Move deforestation infrastructure into passes subdirectory. --- .../core/{deforest-cps.rkt => passes/deforest/cps.rkt} | 6 +++--- .../deforest/syntax.rkt} | 10 +++++----- .../deforest/templates.rkt} | 0 .../{deforest.rkt => passes/pass-0100-deforest.rkt} | 0 qi-lib/list.rkt | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) rename qi-lib/flow/core/{deforest-cps.rkt => passes/deforest/cps.rkt} (98%) rename qi-lib/flow/core/{deforest-syntax.rkt => passes/deforest/syntax.rkt} (98%) rename qi-lib/flow/core/{deforest-templates.rkt => passes/deforest/templates.rkt} (100%) rename qi-lib/flow/core/{deforest.rkt => passes/pass-0100-deforest.rkt} (100%) diff --git a/qi-lib/flow/core/deforest-cps.rkt b/qi-lib/flow/core/passes/deforest/cps.rkt similarity index 98% rename from qi-lib/flow/core/deforest-cps.rkt rename to qi-lib/flow/core/passes/deforest/cps.rkt index c834aafa..029df5dd 100644 --- a/qi-lib/flow/core/deforest-cps.rkt +++ b/qi-lib/flow/core/passes/deforest/cps.rkt @@ -4,11 +4,11 @@ (require (for-syntax racket/base syntax/parse - "deforest-syntax.rkt" - "../extended/util.rkt" + "syntax.rkt" + "../../../extended/util.rkt" syntax/srcloc racket/syntax-srcloc) - "deforest-templates.rkt" + "templates.rkt" racket/performance-hint racket/match racket/contract/base) diff --git a/qi-lib/flow/core/deforest-syntax.rkt b/qi-lib/flow/core/passes/deforest/syntax.rkt similarity index 98% rename from qi-lib/flow/core/deforest-syntax.rkt rename to qi-lib/flow/core/passes/deforest/syntax.rkt index 790a771b..f83f53b0 100644 --- a/qi-lib/flow/core/deforest-syntax.rkt +++ b/qi-lib/flow/core/passes/deforest/syntax.rkt @@ -22,12 +22,12 @@ ) (require syntax/parse - "passes.rkt" - "strategy.rkt" + "../../passes.rkt" + "../../strategy.rkt" (for-template racket/base - "passes.rkt" - "strategy.rkt" - "deforest-templates.rkt") + "../../passes.rkt" + "../../strategy.rkt" + "templates.rkt") (for-syntax racket/base syntax/parse)) diff --git a/qi-lib/flow/core/deforest-templates.rkt b/qi-lib/flow/core/passes/deforest/templates.rkt similarity index 100% rename from qi-lib/flow/core/deforest-templates.rkt rename to qi-lib/flow/core/passes/deforest/templates.rkt diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/passes/pass-0100-deforest.rkt similarity index 100% rename from qi-lib/flow/core/deforest.rkt rename to qi-lib/flow/core/passes/pass-0100-deforest.rkt diff --git a/qi-lib/list.rkt b/qi-lib/list.rkt index dd3e56b3..de2f14d4 100644 --- a/qi-lib/list.rkt +++ b/qi-lib/list.rkt @@ -3,6 +3,6 @@ ;; Upon instantiation of the module it define-and-register-pass for ;; deforestation (require racket/list - "flow/core/deforest.rkt") + "flow/core/passes/pass-0100-deforest.rkt") (provide (all-from-out racket/list)) From c73d4cb98c1eff9c525a8ce7b6cbdc123dac5592 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sun, 5 May 2024 15:11:01 +0200 Subject: [PATCH 09/21] Finish fixing all the things broken by the rebase. --- qi-lib/flow/core/compiler.rkt | 494 +----------------- .../flow/core/passes/pass-0100-deforest.rkt | 492 +---------------- .../flow/core/passes/pass-2000-bindings.rkt | 7 +- 3 files changed, 12 insertions(+), 981 deletions(-) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 85edd46c..81301116 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -3,497 +3,15 @@ (provide (for-syntax compile-flow normalize-pass)) (require (for-syntax racket/base - syntax/parse - racket/match - (only-in racket/list make-list) - "syntax.rkt" - "../aux-syntax.rkt" - "strategy.rkt" - "private/form-property.rkt") - "impl.rkt" - "passes.rkt" - "normalize.rkt" - (only-in racket/list make-list) - racket/function - racket/undefined - (prefix-in fancy: fancy-app) - racket/list) + syntax/parse) + "passes/pass-1000-qi0.rkt" + "passes/pass-2000-bindings.rkt" + "passes/pass-0010-normalize.rkt" + "passes.rkt") (begin-for-syntax ;; note: this does not return compiled code but instead, ;; syntax whose expansion compiles the code (define (compile-flow stx) - (run-passes stx)) - - (define-and-register-pass 1000 (qi0-wrapper stx) - (syntax-parse stx - (ex #'(qi0->racket ex)))) - - ) - -;; 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))) ⏚) ...))))) - -(begin-for-syntax - - ;; (as name) → (~> (esc (λ (x) (set! name x))) ⏚) - ;; TODO: use a box instead of set! - (define (rewrite-all-bindings 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)] - [_ this-syntax]) - stx)) - - (define (bound-identifiers stx) - (let ([ids null]) - (find-and-map/qi (syntax-parser - [((~datum as) x ...) - (begin - (set! ids (append (attribute x) ids)) - ;; we don't need to traverse further - #f)] - [_ this-syntax]) - stx) - ids)) - - ;; wrap stx with (let ([v undefined] ...) stx) for v ∈ ids - (define (wrap-with-scopes stx ids) - (with-syntax ([(v ...) ids]) - #`(let ([v undefined] ...) #,stx))) - - (define-and-register-pass 2000 (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) - (bound-identifiers stx)))) - -(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)) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;; 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 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 - #'(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)] - [e:group-form (group-parser #'e)] - ;; 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 - [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)] - [((~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 - ;; 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)] - - ;; 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 ...)] - - ;; 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: - -#| -A note on error handling: - -Some forms, in addition to handling legitimate syntax, also have -catch-all versions that exist purely to provide a helpful message -indicating a syntax error. We do this since a priori the qi0->racket macro -would ignore syntax that doesn't match any pattern. Yet, for all of -these named forms, we know that (or at least, it is prudent to assume -that) the user intended to employ that particular form of the DSL. So -instead of allowing it to fall through for interpretation as Racket -code, which would yield potentially inscrutable errors, the catch-all -forms allow us to provide appropriate error messages at the level of -the DSL. - -|# - -(begin-for-syntax - - (define (sep-parser stx) - (syntax-parse stx - [_:id - #'(qi0->racket (if (esc list?) - (#%fine-template (apply values _)) - (#%fine-template (raise-argument-error '△ - "list?" - _))))] - [(_ onex:clause) - #'(λ (v . vs) - ((qi0->racket (~> △ (>< (#%fine-template (apply (qi0->racket onex) _ vs))))) v))])) - - (define (select-parser stx) - (syntax-parse stx - [(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))])) - - (define (block-parser stx) - (syntax-parse stx - [(_ n:number ...) - #'(qi0->racket (~> (esc (except-args n ...)) - △))])) - - (define (group-parser stx) - (syntax-parse stx - [(_ n:expr - selection-onex:clause - remainder-onex:clause) - #'(loom-compose (qi0->racket selection-onex) - (qi0->racket remainder-onex) - n)] - [_:id - #'(λ (n selection-flo remainder-flo . vs) - (apply (qi0->racket (group n - (esc selection-flo) - (esc remainder-flo))) vs))])) - - (define (sieve-parser stx) - (syntax-parse stx - [(_ condition:clause - sonex:clause - ronex:clause) - #'(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 (esc condition)) (esc sonex)) - (~> (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 - [error-condition-flo error-handler-flo] - ...+) - #'(λ args - (with-handlers ([(qi0->racket error-condition-flo) - (λ (e) - ;; TODO: may be good to support reference to the - ;; error via a binding / syntax parameter - (apply (qi0->racket error-handler-flo) args))] - ...) - (apply (qi0->racket flo) args)))])) - - (define (if-parser stx) - (syntax-parse stx - [(_ consequent:clause - alternative:clause) - #'(λ (f . args) - (if (apply f args) - (apply (qi0->racket consequent) args) - (apply (qi0->racket alternative) args)))] - [(_ condition:clause - consequent:clause - alternative:clause) - #'(λ args - (if (apply (qi0->racket condition) args) - (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) - ((~datum then) thenex:clause) - onex:clause) - #'(feedback-while (qi0->racket onex) - (qi0->racket tilex) - (qi0->racket thenex))] - [(_ ((~datum while) tilex:clause) - ((~datum then) thenex:clause)) - #'(λ (f . args) - (apply (qi0->racket (feedback (while tilex) (then thenex) (esc f))) - args))] - [(_ ((~datum while) tilex:clause) onex:clause) - #'(qi0->racket (feedback (while tilex) (then _) onex))] - [(_ ((~datum while) tilex:clause)) - #'(qi0->racket (feedback (while tilex) (then _)))] - [(_ n:expr - ((~datum then) thenex:clause) - onex:clause) - #'(lambda args - (apply (feedback-times (qi0->racket onex) n (qi0->racket thenex)) - args))] - [(_ n:expr - ((~datum then) thenex:clause)) - #'(λ (f . args) - (apply (qi0->racket (feedback n (then thenex) (esc f))) args))] - [(_ n:expr onex:clause) - #'(qi0->racket (feedback n (then _) onex))] - [(_ onex:clause) - #'(λ (n . args) - (apply (qi0->racket (feedback n onex)) args))] - [_:id - #'(λ (n flo . args) - (apply (qi0->racket (feedback n (esc flo))) - args))])) - - (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 (relay-parser stx) - (syntax-parse stx - [((~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 ==)] - [(_ onex:clause) - #'(curry map-values (qi0->racket onex))])) - - (define (pass-parser stx) - (syntax-parse stx - [_:id - #'filter-values] - [(_ onex:clause) - #'(curry filter-values (qi0->racket onex))])) - - (define (fold-left-parser stx) - (syntax-parse stx - [_:id - #'foldl-values] - [(_ fn init) - #'(qi0->racket (~> (-< (gen (qi0->racket fn) - (qi0->racket init)) - _) - >>))] - [(_ fn) - #'(qi0->racket (>> fn (gen ((qi0->racket fn)))))])) - - (define (fold-right-parser stx) - (syntax-parse stx - [_:id - #'foldr-values] - [(_ fn init) - #'(qi0->racket (~> (-< (gen (qi0->racket fn) - (qi0->racket init)) - _) - <<))] - [(_ fn) - #'(qi0->racket (<< fn (gen ((qi0->racket fn)))))])) - - (define (loop-parser stx) - (syntax-parse stx - [(_ pred:clause mapex:clause combex:clause retex:clause) - #'(letrec ([loop (qi0->racket (if pred - (~> (group 1 mapex (esc loop)) - combex) - retex))]) - loop)] - [(_ pred:clause mapex:clause combex:clause) - #'(qi0->racket (loop pred mapex combex ⏚))] - [(_ pred:clause mapex:clause) - #'(qi0->racket (loop pred mapex _ ⏚))] - [(_ mapex:clause) - #'(qi0->racket (loop (gen #t) mapex _ ⏚))] - [_:id #'(λ (predf mapf combf retf . args) - (apply (qi0->racket (loop (esc predf) - (esc mapf) - (esc combf) - (esc retf))) - args))])) - - (define (clos-parser stx) - (syntax-parse stx - [_:id - #:do [(define chirality (syntax-property stx 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(λ (f . args) (apply curryr f args)) - #'(λ (f . args) (apply curry f args)))] - [(_ onex:clause) - #:do [(define chirality (syntax-property stx 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(λ args - (qi0->racket (~> (-< _ (~> (gen args) △)) - onex))) - #'(λ args - (qi0->racket (~> (-< (~> (gen args) △) _) - onex))))])) - - (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. - ;; 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 ...) ...)" - #'(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 ...))]))) + (run-passes stx))) diff --git a/qi-lib/flow/core/passes/pass-0100-deforest.rkt b/qi-lib/flow/core/passes/pass-0100-deforest.rkt index 7ee98035..6ab99823 100644 --- a/qi-lib/flow/core/passes/pass-0100-deforest.rkt +++ b/qi-lib/flow/core/passes/pass-0100-deforest.rkt @@ -1,495 +1,5 @@ #lang racket/base -;; This module implements the stream fusion optimization to "deforest" -;; sequences of functional transformations (e.g. map, filter, fold, etc.) -;; so that they avoid constructing intermediate representations on the -;; way to producing the final result. -;; -;; See the wiki -;; https://github.com/drym-org/qi/wiki/The-Compiler#stream-fusion -;; for an overview and some details of this implementation. - (provide (for-syntax deforest-pass)) -(require (for-syntax racket/base - syntax/parse - racket/syntax-srcloc - syntax/srcloc - "../extended/util.rkt" - "strategy.rkt") - "passes.rkt" - racket/performance-hint - racket/match - 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. -(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 -;; 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 - ;; 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))] - [(= 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))])])) - - (define-syntax-class cad*r-datum - #:attributes (countdown) - (pattern (~datum car) #:attr countdown #'0) - (pattern (~datum cadr) #:attr countdown #'1) - (pattern (~datum caddr) #:attr countdown #'2) - (pattern (~datum cadddr) #:attr countdown #'3) - (pattern (~datum caddddr) #:attr countdown #'4) - (pattern (~datum cadddddr) #:attr countdown #'5)) - - ;; 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 - #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) - (pattern (~or (#%blanket-template - ((#%host-expression (~or (~datum filter) - (~datum filter-map))) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~or (~datum filter) - (~datum filter-map))) - (#%host-expression f) - _))))) - - ;; 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) - - (pattern (~or (#%blanket-template - ((#%host-expression (~datum filter-map)) - (#%host-expression f) - __)) - (#%fine-template - ((#%host-expression (~datum filter-map)) - (#%host-expression f) - _))) - #:attr next #'filter-map-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 cad*r:cad*r-datum)) - (#%fine-template - ((#%host-expression cad*r:cad*r-datum) _)) - (#%blanket-template - ((#%host-expression cad*r:cad*r-datum) __))) - #:attr end #'(cad*r-cstream-next cad*r.countdown 'cad*r)) - - (pattern (~or (#%fine-template - ((#%host-expression (~datum list-ref)) _ idx)) - (#%blanket-template - ((#%host-expression (~datum list-ref)) __ idx))) - #:attr end #'(cad*r-cstream-next idx 'list-ref)) - - (pattern (~or (esc - (#%host-expression (~datum length))) - (#%fine-template - ((#%host-expression (~datum length)) _)) - (#%blanket-template - ((#%host-expression (~datum length)) __))) - #:attr end #'(length-cstream-next)) - - (pattern (~or (esc - (#%host-expression (~or (~datum empty?) - (~datum null?)))) - (#%fine-template - ((#%host-expression (~or (~datum empty?) - (~datum null?))) _)) - (#%blanket-template - ((#%host-expression (~or (~datum empty?) - (~datum null?))) __))) - #:attr end #'(empty?-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) - '#,(build-source-location-vector - (syntax-srcloc ctx)))) - p.name - '#,(prettify-flow-syntax ctx) - #f - '#,(build-source-location-vector - (syntax-srcloc ctx)))))])) - - (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 ...)] - ;; return the input syntax unchanged if no rules - ;; are applicable - [_ stx])) - - ;; Performs deforestation rewrite on the whole syntax tree. - (define-and-register-pass 100 (deforest-pass stx) - (find-and-map/qi - (fix deforest-rewrite) - stx))) - -(begin-encourage-inline - - ;; Producers - - (define-inline (list->cstream-next done skip yield) - (λ (state) - (cond [(null? state) (done)] - [else (yield (car state) (cdr state))]))) - - (define-inline (list->cstream-prepare next) - (case-lambda - [(lst) (next lst)] - [rest (void)])) - - (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 (range->cstream-prepare next) - (case-lambda - [(h) (next (list 0 h 1))] - [(l h) (next (list l h 1))] - [(l h s) (next (list l h s))] - [rest (void)])) - - ;; Transformers - - (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 (filter-map-cstream-next f next) - (λ (done skip yield) - (next done - skip - (λ (value state) - (let ([fv (f value)]) - (if fv - (yield fv state) - (skip state))))))) - - ;; Consumers - - (define-inline (cstream-next->list next ctx src) - (λ (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 ctx src) - (λ (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 ctx src) - (λ (state) - (let loop ([acc init] [state state]) - ((next (λ () acc) - (λ (state) (loop acc state)) - (λ (value state) - (loop (op value acc) state))) - state)))) - - (define-inline (cad*r-cstream-next init-countdown name next ctx src) - (λ (state) - (let loop ([state state] - [countdown init-countdown]) - ((next (λ () ((contract (-> pair? any) - (λ (v) v) - name ctx #f - src) '())) - (λ (state) (loop state countdown)) - (λ (value state) - (if (zero? countdown) - value - (loop state (sub1 countdown))))) - state)))) - - (define-inline (length-cstream-next next ctx src) - (λ (state) - (let loop ([state state] - [the-length 0]) - ((next (λ () the-length) - (λ (state) (loop state the-length)) - (λ (value state) - (loop state (add1 the-length)))) - state)))) - - (define-inline (empty?-cstream-next next ctx src) - (λ (state) - (let loop ([state state]) - ((next (λ () #t) - (λ (state) (loop state)) - (λ (value state) #f)) - state)))) - - ) +(require "deforest/cps.rkt") diff --git a/qi-lib/flow/core/passes/pass-2000-bindings.rkt b/qi-lib/flow/core/passes/pass-2000-bindings.rkt index bd15a483..7c51a53b 100644 --- a/qi-lib/flow/core/passes/pass-2000-bindings.rkt +++ b/qi-lib/flow/core/passes/pass-2000-bindings.rkt @@ -50,8 +50,11 @@ (let ([ids null]) (find-and-map/qi (syntax-parser [((~datum as) x ...) - (set! ids - (append (attribute x) ids))] + (begin + (set! ids + (append (attribute x) ids)) + ;; we don't need to traverse further + #f)] [_ this-syntax]) stx) ids)) From ed369272df6ed08d4e56195b721f126137095dfa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 24 May 2024 18:59:29 +0200 Subject: [PATCH 10/21] Improve directory and module naming - rename compiler "passes" subdirectory to "compiler" - strip the passes modules file name pass- prefix --- qi-lib/flow/core/compiler.rkt | 6 +++--- .../pass-0010-normalize.rkt => compiler/0010-normalize.rkt} | 0 .../pass-0100-deforest.rkt => compiler/0100-deforest.rkt} | 0 .../{passes/pass-1000-qi0.rkt => compiler/1000-qi0.rkt} | 0 .../pass-2000-bindings.rkt => compiler/2000-bindings.rkt} | 0 qi-lib/flow/core/{passes => compiler}/deforest/cps.rkt | 0 qi-lib/flow/core/{passes => compiler}/deforest/syntax.rkt | 0 .../flow/core/{passes => compiler}/deforest/templates.rkt | 0 qi-lib/list.rkt | 2 +- qi-test/tests/compiler/rules/deforest.rkt | 2 +- qi-test/tests/compiler/rules/full-cycle.rkt | 2 +- 11 files changed, 6 insertions(+), 6 deletions(-) rename qi-lib/flow/core/{passes/pass-0010-normalize.rkt => compiler/0010-normalize.rkt} (100%) rename qi-lib/flow/core/{passes/pass-0100-deforest.rkt => compiler/0100-deforest.rkt} (100%) rename qi-lib/flow/core/{passes/pass-1000-qi0.rkt => compiler/1000-qi0.rkt} (100%) rename qi-lib/flow/core/{passes/pass-2000-bindings.rkt => compiler/2000-bindings.rkt} (100%) rename qi-lib/flow/core/{passes => compiler}/deforest/cps.rkt (100%) rename qi-lib/flow/core/{passes => compiler}/deforest/syntax.rkt (100%) rename qi-lib/flow/core/{passes => compiler}/deforest/templates.rkt (100%) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt index 81301116..27ab3799 100644 --- a/qi-lib/flow/core/compiler.rkt +++ b/qi-lib/flow/core/compiler.rkt @@ -4,9 +4,9 @@ (require (for-syntax racket/base syntax/parse) - "passes/pass-1000-qi0.rkt" - "passes/pass-2000-bindings.rkt" - "passes/pass-0010-normalize.rkt" + "compiler/1000-qi0.rkt" + "compiler/2000-bindings.rkt" + "compiler/0010-normalize.rkt" "passes.rkt") (begin-for-syntax diff --git a/qi-lib/flow/core/passes/pass-0010-normalize.rkt b/qi-lib/flow/core/compiler/0010-normalize.rkt similarity index 100% rename from qi-lib/flow/core/passes/pass-0010-normalize.rkt rename to qi-lib/flow/core/compiler/0010-normalize.rkt diff --git a/qi-lib/flow/core/passes/pass-0100-deforest.rkt b/qi-lib/flow/core/compiler/0100-deforest.rkt similarity index 100% rename from qi-lib/flow/core/passes/pass-0100-deforest.rkt rename to qi-lib/flow/core/compiler/0100-deforest.rkt diff --git a/qi-lib/flow/core/passes/pass-1000-qi0.rkt b/qi-lib/flow/core/compiler/1000-qi0.rkt similarity index 100% rename from qi-lib/flow/core/passes/pass-1000-qi0.rkt rename to qi-lib/flow/core/compiler/1000-qi0.rkt diff --git a/qi-lib/flow/core/passes/pass-2000-bindings.rkt b/qi-lib/flow/core/compiler/2000-bindings.rkt similarity index 100% rename from qi-lib/flow/core/passes/pass-2000-bindings.rkt rename to qi-lib/flow/core/compiler/2000-bindings.rkt diff --git a/qi-lib/flow/core/passes/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt similarity index 100% rename from qi-lib/flow/core/passes/deforest/cps.rkt rename to qi-lib/flow/core/compiler/deforest/cps.rkt diff --git a/qi-lib/flow/core/passes/deforest/syntax.rkt b/qi-lib/flow/core/compiler/deforest/syntax.rkt similarity index 100% rename from qi-lib/flow/core/passes/deforest/syntax.rkt rename to qi-lib/flow/core/compiler/deforest/syntax.rkt diff --git a/qi-lib/flow/core/passes/deforest/templates.rkt b/qi-lib/flow/core/compiler/deforest/templates.rkt similarity index 100% rename from qi-lib/flow/core/passes/deforest/templates.rkt rename to qi-lib/flow/core/compiler/deforest/templates.rkt diff --git a/qi-lib/list.rkt b/qi-lib/list.rkt index de2f14d4..3d075788 100644 --- a/qi-lib/list.rkt +++ b/qi-lib/list.rkt @@ -3,6 +3,6 @@ ;; Upon instantiation of the module it define-and-register-pass for ;; deforestation (require racket/list - "flow/core/passes/pass-0100-deforest.rkt") + "flow/core/compiler/0100-deforest.rkt") (provide (all-from-out racket/list)) diff --git a/qi-test/tests/compiler/rules/deforest.rkt b/qi-test/tests/compiler/rules/deforest.rkt index 9e80ea73..b68f1090 100644 --- a/qi-test/tests/compiler/rules/deforest.rkt +++ b/qi-test/tests/compiler/rules/deforest.rkt @@ -9,7 +9,7 @@ ;; necessary to correctly expand the right-threading form qi/flow/extended/forms qi/flow/core/compiler - qi/flow/core/passes/pass-0100-deforest + qi/flow/core/compiler/0100-deforest syntax/macro-testing (submod qi/flow/extended/expander invoke) rackunit diff --git a/qi-test/tests/compiler/rules/full-cycle.rkt b/qi-test/tests/compiler/rules/full-cycle.rkt index 5b16f09c..3b4535b1 100644 --- a/qi-test/tests/compiler/rules/full-cycle.rkt +++ b/qi-test/tests/compiler/rules/full-cycle.rkt @@ -10,7 +10,7 @@ rackunit rackunit/text-ui syntax/macro-testing - qi/flow/core/passes/pass-0100-deforest + qi/flow/core/compiler/0100-deforest "private/deforest-util.rkt" (submod qi/flow/extended/expander invoke)) From b1ffbd1549d38382f8318b2e95b34648403e42b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 31 May 2024 22:39:34 +0200 Subject: [PATCH 11/21] Deforest take with boxes. --- qi-lib/flow/core/compiler/deforest/cps.rkt | 25 ++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/qi-lib/flow/core/compiler/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt index 029df5dd..09ad07ea 100644 --- a/qi-lib/flow/core/compiler/deforest/cps.rkt +++ b/qi-lib/flow/core/compiler/deforest/cps.rkt @@ -21,7 +21,7 @@ (define-syntax inline-compose1 (syntax-rules () [(_ f) f] - [(_ [op f] rest ...) (op f (inline-compose1 rest ...))])) + [(_ [op (f ...)] rest ...) (op f ... (inline-compose1 rest ...))])) (begin-for-syntax @@ -142,14 +142,17 @@ (define-syntax-class fst #:attributes (next f) (pattern filter:fst-filter - #:attr f #'filter.f + #:attr f #'(filter.f) #:attr next #'filter-cstream-next) (pattern map:fst-map - #:attr f #'map.f + #:attr f #'(map.f) #:attr next #'map-cstream-next) (pattern filter-map:fst-filter-map - #:attr f #'filter-map.f + #:attr f #'(filter-map.f) #:attr next #'filter-map-cstream-next) + (pattern take:fst-take + #:attr f #'((box take.n)) + #:attr next #'take-cstream-next) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -258,6 +261,20 @@ (yield fv state) (skip state))))))) + (define-inline (take-cstream-next bn next) + (λ (done skip yield) + (λ (state) + (define n (unbox bn)) + (if (zero? n) + (done) + ((next (λ () + (error 'take-cstream-next "not enough")) + skip + (λ (value state) + (set-box! bn (sub1 n)) + (yield value state))) + state))))) + ;; Consumers (define-inline (cstream-next->list next ctx src) From ace1580d755761fdd42dfb5b9974944748463cf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 31 May 2024 23:01:11 +0200 Subject: [PATCH 12/21] Implement proper state cons-ing for take. --- qi-lib/flow/core/compiler/deforest/cps.rkt | 68 ++++++++++++++-------- 1 file changed, 43 insertions(+), 25 deletions(-) diff --git a/qi-lib/flow/core/compiler/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt index 09ad07ea..6560ca5f 100644 --- a/qi-lib/flow/core/compiler/deforest/cps.rkt +++ b/qi-lib/flow/core/compiler/deforest/cps.rkt @@ -23,6 +23,13 @@ [(_ f) f] [(_ [op (f ...)] rest ...) (op f ... (inline-compose1 rest ...))])) +(define-syntax inline-consing + (syntax-rules () + [(_ state () rest ...) (inline-consing state rest ...)] + [(_ state (arg) rest ...) (inline-consing (cons arg state) rest ...)] + [(_ state) state] + )) + (begin-for-syntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -140,19 +147,23 @@ ;; Transformers (define-syntax-class fst - #:attributes (next f) + #:attributes (next f state) (pattern filter:fst-filter #:attr f #'(filter.f) - #:attr next #'filter-cstream-next) + #:attr next #'filter-cstream-next + #:attr state #'()) (pattern map:fst-map #:attr f #'(map.f) - #:attr next #'map-cstream-next) + #:attr next #'map-cstream-next + #:attr state #'()) (pattern filter-map:fst-filter-map #:attr f #'(filter-map.f) - #:attr next #'filter-map-cstream-next) + #:attr next #'filter-map-cstream-next + #:attr state #'()) (pattern take:fst-take - #:attr f #'((box take.n)) - #:attr next #'take-cstream-next) + #:attr f #'() + #:attr next #'take-cstream-next + #:attr state #'(take.n)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -190,6 +201,9 @@ (#,((attribute p.curry) ctx (attribute p.name)) (contract p.contract (p.prepare + (lambda (state) + (define cstate (inline-consing state t.state ...)) + cstate) (#,@#'c.end (inline-compose1 [t.next t.f] ... p.next) @@ -200,7 +214,9 @@ '#,(prettify-flow-syntax ctx) #f '#,(build-source-location-vector - (syntax-srcloc ctx)))))]))) + (syntax-srcloc ctx)))))])) + + ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Runtime @@ -214,9 +230,9 @@ (cond [(null? state) (done)] [else (yield (car state) (cdr state))]))) - (define-inline (list->cstream-prepare next) + (define-inline (list->cstream-prepare consing next) (case-lambda - [(lst) (next lst)] + [(lst) (next (consing lst))] [rest (void)])) (define-inline (range->cstream-next done skip yield) @@ -226,11 +242,11 @@ (yield l (cons (+ l s) (cdr state)))] [else (done)]))) - (define-inline (range->cstream-prepare next) + (define-inline (range->cstream-prepare consing next) (case-lambda - [(h) (next (list 0 h 1))] - [(l h) (next (list l h 1))] - [(l h s) (next (list l h s))] + [(h) (next (consing (list 0 h 1)))] + [(l h) (next (consing (list l h 1)))] + [(l h s) (next (consing (list l h s)))] [rest (void)])) ;; Transformers @@ -261,19 +277,21 @@ (yield fv state) (skip state))))))) - (define-inline (take-cstream-next bn next) + (define-inline (take-cstream-next next) (λ (done skip yield) - (λ (state) - (define n (unbox bn)) - (if (zero? n) - (done) - ((next (λ () - (error 'take-cstream-next "not enough")) - skip - (λ (value state) - (set-box! bn (sub1 n)) - (yield value state))) - state))))) + (λ (take-state) + (define n (car take-state)) + (define state (cdr take-state)) + (cond ((zero? n) + (done)) + (else + ((next (λ () + (error 'take-cstream-next "not enough")) + skip + (λ (value state) + (define new-state (cons (sub1 n) state)) + (yield value new-state))) + state)))))) ;; Consumers From 9685d10eefa98e17629d349eb7d6be75f657401a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 31 May 2024 23:23:40 +0200 Subject: [PATCH 13/21] Add source syntax context to transformer composition. --- qi-lib/flow/core/compiler/deforest/cps.rkt | 27 +++++++++++++++------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/qi-lib/flow/core/compiler/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt index 6560ca5f..406b7770 100644 --- a/qi-lib/flow/core/compiler/deforest/cps.rkt +++ b/qi-lib/flow/core/compiler/deforest/cps.rkt @@ -21,7 +21,8 @@ (define-syntax inline-compose1 (syntax-rules () [(_ f) f] - [(_ [op (f ...)] rest ...) (op f ... (inline-compose1 rest ...))])) + [(_ [op (f ...) g ...] rest ...) (op f ... (inline-compose1 rest ...) g ...)] + )) (define-syntax inline-consing (syntax-rules () @@ -205,8 +206,13 @@ (define cstate (inline-consing state t.state ...)) cstate) (#,@#'c.end - (inline-compose1 [t.next t.f] ... - p.next) + (inline-compose1 [t.next t.f + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)) + ] ... + p.next + ) '#,(prettify-flow-syntax ctx) '#,(build-source-location-vector (syntax-srcloc ctx)))) @@ -251,14 +257,14 @@ ;; Transformers - (define-inline (map-cstream-next f next) + (define-inline (map-cstream-next f next ctx src) (λ (done skip yield) (next done skip (λ (value state) (yield (f value) state))))) - (define-inline (filter-cstream-next f next) + (define-inline (filter-cstream-next f next ctx src) (λ (done skip yield) (next done skip @@ -267,7 +273,7 @@ (yield value state) (skip state)))))) - (define-inline (filter-map-cstream-next f next) + (define-inline (filter-map-cstream-next f next ctx src) (λ (done skip yield) (next done skip @@ -277,7 +283,7 @@ (yield fv state) (skip state))))))) - (define-inline (take-cstream-next next) + (define-inline (take-cstream-next next ctx src) (λ (done skip yield) (λ (take-state) (define n (car take-state)) @@ -286,7 +292,12 @@ (done)) (else ((next (λ () - (error 'take-cstream-next "not enough")) + ((contract (-> pair? any) + (λ (v) v) + 'take ctx + #f + src + ) '())) skip (λ (value state) (define new-state (cons (sub1 n) state)) From ade291f392e215e42bdddd30c0625c539f42f4e4 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Mon, 6 May 2024 12:08:47 -0700 Subject: [PATCH 14/21] =?UTF-8?q?doc:=20link=20to=20ways=20to=20enter=20th?= =?UTF-8?q?e=20=E2=98=AF=20symbol?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Towards addressing feedback on discord from @dented42 --- qi-doc/scribblings/interface.scrbl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/qi-doc/scribblings/interface.scrbl b/qi-doc/scribblings/interface.scrbl index 59a6d863..be044a18 100644 --- a/qi-doc/scribblings/interface.scrbl +++ b/qi-doc/scribblings/interface.scrbl @@ -163,6 +163,8 @@ This produces a value that is an ordinary function. When invoked with arguments, See also @racket[on] and @racket[~>], which are shorthands to invoke the flow with arguments immediately. +See @secref["Flowing_with_the_Flow"] for ways to enter the @racket[☯] symbol in your editor. + @examples[ #:eval eval-for-docs ((☯ (* 5)) 3) From b54102ad6eaea56abadc24a39e392596ccc4da55 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 14 Jun 2024 09:58:40 +0200 Subject: [PATCH 15/21] New qi/list bindings and their literal matching, stateful transformers fixes and tests for them. --- qi-doc/scribblings/qi.scrbl | 1 + qi-lib/flow/core/compiler/deforest/cps.rkt | 46 +++++----- qi-lib/flow/core/compiler/deforest/syntax.rkt | 85 +++++++++---------- qi-lib/list.rkt | 6 +- qi-test/tests/compiler/semantics.rkt | 14 ++- 5 files changed, 83 insertions(+), 69 deletions(-) diff --git a/qi-doc/scribblings/qi.scrbl b/qi-doc/scribblings/qi.scrbl index dc7384f3..c76c7f85 100644 --- a/qi-doc/scribblings/qi.scrbl +++ b/qi-doc/scribblings/qi.scrbl @@ -40,6 +40,7 @@ This site hosts @emph{user} documentation. If you are interested in contributing @include-section["tutorial.scrbl"] @include-section["interface.scrbl"] @include-section["forms.scrbl"] +@include-section["list-operations.scrbl"] @include-section["macros.scrbl"] @include-section["field-guide.scrbl"] @include-section["principles.scrbl"] diff --git a/qi-lib/flow/core/compiler/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt index 406b7770..918a684a 100644 --- a/qi-lib/flow/core/compiler/deforest/cps.rkt +++ b/qi-lib/flow/core/compiler/deforest/cps.rkt @@ -198,29 +198,30 @@ ;; 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 - (lambda (state) - (define cstate (inline-consing state t.state ...)) - cstate) - (#,@#'c.end - (inline-compose1 [t.next t.f - '#,(prettify-flow-syntax ctx) - '#,(build-source-location-vector - (syntax-srcloc ctx)) - ] ... - p.next - ) + (with-syntax (((rt ...) (reverse (attribute t.state)))) + #`(esc + (#,((attribute p.curry) ctx (attribute p.name)) + (contract p.contract + (p.prepare + (lambda (state) + (define cstate (inline-consing state rt ...)) + cstate) + (#,@#'c.end + (inline-compose1 [t.next t.f + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)) + ] ... + p.next + ) + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)))) + p.name '#,(prettify-flow-syntax ctx) + #f '#,(build-source-location-vector - (syntax-srcloc ctx)))) - p.name - '#,(prettify-flow-syntax ctx) - #f - '#,(build-source-location-vector - (syntax-srcloc ctx)))))])) + (syntax-srcloc ctx))))))])) ) @@ -298,7 +299,8 @@ #f src ) '())) - skip + (λ (state) + (skip (cons n state))) (λ (value state) (define new-state (cons (sub1 n) state)) (yield value new-state))) diff --git a/qi-lib/flow/core/compiler/deforest/syntax.rkt b/qi-lib/flow/core/compiler/deforest/syntax.rkt index f83f53b0..53527a32 100644 --- a/qi-lib/flow/core/compiler/deforest/syntax.rkt +++ b/qi-lib/flow/core/compiler/deforest/syntax.rkt @@ -27,7 +27,8 @@ (for-template racket/base "../../passes.rkt" "../../strategy.rkt" - "templates.rkt") + "templates.rkt" + (prefix-in qi: "bindings.rkt")) (for-syntax racket/base syntax/parse)) @@ -41,15 +42,15 @@ (define-syntax-class fsp-range #:attributes (blanket? fine? arg pre-arg post-arg) #:literal-sets (fs-literals) - #:datum-literals (range) - (pattern (esc (#%host-expression range)) + #:literals (qi:range) + (pattern (esc (#%host-expression qi:range)) #:attr arg #f #:attr pre-arg #f #:attr post-arg #f #:attr blanket? #f #:attr fine? #f) (pattern (#%fine-template - ((#%host-expression range) + ((#%host-expression qi:range) the-arg ...)) #:attr arg #'(the-arg ...) #:attr pre-arg #f @@ -57,7 +58,7 @@ #:attr blanket? #f #:attr fine? #t) (pattern (#%blanket-template - ((#%host-expression range) + ((#%host-expression qi:range) (#%host-expression the-pre-arg) ... __ (#%host-expression the-post-arg) ...)) @@ -83,52 +84,52 @@ (define-syntax-class fst-filter #:attributes (f) #:literal-sets (fs-literals) - #:datum-literals (filter) + #:literals (qi:filter) (pattern (#%blanket-template - ((#%host-expression filter) + ((#%host-expression qi:filter) (#%host-expression f) __))) (pattern (#%fine-template - ((#%host-expression filter) + ((#%host-expression qi:filter) (#%host-expression f) _)))) (define-syntax-class fst-map #:attributes (f) #:literal-sets (fs-literals) - #:datum-literals (map) + #:literals (qi:map) (pattern (#%blanket-template - ((#%host-expression map) + ((#%host-expression qi:map) (#%host-expression f) __))) (pattern (#%fine-template - ((#%host-expression map) + ((#%host-expression qi:map) (#%host-expression f) _)))) (define-syntax-class fst-filter-map #:attributes (f) #:literal-sets (fs-literals) - #:datum-literals (filter-map) + #:literals (qi:filter-map) (pattern (#%blanket-template - ((#%host-expression filter-map) + ((#%host-expression qi:filter-map) (#%host-expression f) __))) (pattern (#%fine-template - ((#%host-expression filter-map) + ((#%host-expression qi:filter-map) (#%host-expression f) _)))) (define-syntax-class fst-take #:attributes (n) #:literal-sets (fs-literals) - #:datum-literals (take) + #:literals (qi:take) (pattern (#%blanket-template - ((#%host-expression take) + ((#%host-expression qi:take) __ (#%host-expression n)))) (pattern (#%fine-template - ((#%host-expression take) + ((#%host-expression qi:take) _ (#%host-expression n))))) @@ -148,14 +149,14 @@ (define-syntax-class fsc-foldr #:attributes (op init) #:literal-sets (fs-literals) - #:datum-literals (foldr) + #:literals (qi:foldr) (pattern (#%blanket-template - ((#%host-expression foldr) + ((#%host-expression qi:foldr) (#%host-expression op) (#%host-expression init) __))) (pattern (#%fine-template - ((#%host-expression foldr) + ((#%host-expression qi:foldr) (#%host-expression op) (#%host-expression init) _)))) @@ -163,35 +164,33 @@ (define-syntax-class fsc-foldl #:attributes (op init) #:literal-sets (fs-literals) - #:datum-literals (foldl) + #:literals (qi:foldl) (pattern (#%blanket-template - ((#%host-expression foldl) + ((#%host-expression qi:foldl) (#%host-expression op) (#%host-expression init) __))) (pattern (#%fine-template - ((#%host-expression foldl) + ((#%host-expression qi:foldl) (#%host-expression op) (#%host-expression init) _)))) (define-syntax-class cad*r-datum #:attributes (countdown) - (pattern (~datum car) #:attr countdown #'0) - (pattern (~datum cadr) #:attr countdown #'1) - (pattern (~datum caddr) #:attr countdown #'2) - (pattern (~datum cadddr) #:attr countdown #'3) - (pattern (~datum caddddr) #:attr countdown #'4) - (pattern (~datum cadddddr) #:attr countdown #'5)) + (pattern (~literal qi:car) #:attr countdown #'0) + (pattern (~literal qi:cadr) #:attr countdown #'1) + (pattern (~literal qi:caddr) #:attr countdown #'2) + (pattern (~literal qi:cadddr) #:attr countdown #'3)) (define-syntax-class fsc-list-ref #:attributes (pos name) #:literal-sets (fs-literals) - #:datum-literals (list-ref) + #:literals (qi:list-ref) (pattern (~or (#%fine-template - ((#%host-expression list-ref) _ idx)) + ((#%host-expression qi:list-ref) _ idx)) (#%blanket-template - ((#%host-expression list-ref) __ idx))) + ((#%host-expression qi:list-ref) __ idx))) #:attr pos #'idx #:attr name #'list-ref) (pattern (~or (esc (#%host-expression cad*r:cad*r-datum)) @@ -204,26 +203,26 @@ (define-syntax-class fsc-length #:literal-sets (fs-literals) - #:datum-literals (length) + #:literals (qi:length) (pattern (esc - (#%host-expression length))) + (#%host-expression qi:length))) (pattern (#%fine-template - ((#%host-expression length) _))) + ((#%host-expression qi:length) _))) (pattern (#%blanket-template - ((#%host-expression length) __)))) + ((#%host-expression qi:length) __)))) (define-syntax-class fsc-empty? #:literal-sets (fs-literals) - #:datum-literals (empty? null?) + #:literals (qi:null? qi:empty?) (pattern (esc - (#%host-expression (~or empty? - null?)))) + (#%host-expression (~or qi:empty? + qi:null?)))) (pattern (#%fine-template - ((#%host-expression (~or empty? - null?)) _))) + ((#%host-expression (~or qi:empty? + qi:null?)) _))) (pattern (#%blanket-template - ((#%host-expression (~or empty? - null?)) __)))) + ((#%host-expression (~or qi:empty? + qi:null?)) __)))) (define-syntax-class fsc-default #:datum-literals (cstream->list) diff --git a/qi-lib/list.rkt b/qi-lib/list.rkt index 3d075788..2558d68a 100644 --- a/qi-lib/list.rkt +++ b/qi-lib/list.rkt @@ -2,7 +2,7 @@ ;; Upon instantiation of the module it define-and-register-pass for ;; deforestation -(require racket/list - "flow/core/compiler/0100-deforest.rkt") +(require "flow/core/compiler/0100-deforest.rkt" + "flow/core/compiler/deforest/binding.rkt") -(provide (all-from-out racket/list)) +(provide (all-from-out "flow/core/compiler/deforest/binding.rkt")) diff --git a/qi-test/tests/compiler/semantics.rkt b/qi-test/tests/compiler/semantics.rkt index 2ffcad81..5453f38b 100644 --- a/qi-test/tests/compiler/semantics.rkt +++ b/qi-test/tests/compiler/semantics.rkt @@ -183,7 +183,19 @@ '(25)) (test-equal? "~>> (range _ 10 3) [1] (5)" (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) - '(25)))))) + '(25))) + + (test-suite + "take (stateful transformer)" + (test-equal? "take after filter" + (~>> (20) range (filter odd?) (take _ 5) (map sqr)) + '(1 9 25 49 81)) + + (test-equal? "two takes after filter" + (~>> (20) range (filter odd?) (take _ 5) (take _ 3) (map sqr)) + '(1 9 25)) + + )))) (module+ main (void (run-tests tests))) From 9feeb581578468f8b81647a8a97d7e518fbb6dd0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 15 Jun 2024 10:53:26 +0200 Subject: [PATCH 16/21] Deforestation: rename all fusable stream syntax classes to fs[PTC]-syntax and do not provide them. --- qi-lib/flow/core/compiler/deforest/syntax.rkt | 33 +++++++++---------- 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/qi-lib/flow/core/compiler/deforest/syntax.rkt b/qi-lib/flow/core/compiler/deforest/syntax.rkt index 53527a32..dfab0e9c 100644 --- a/qi-lib/flow/core/compiler/deforest/syntax.rkt +++ b/qi-lib/flow/core/compiler/deforest/syntax.rkt @@ -1,16 +1,13 @@ #lang racket/base -(provide fsp-intf - fsp-range +(provide fsp-range fsp-default - fst-intf fst-filter fst-map fst-filter-map fst-take - fsc-intf fsc-foldr fsc-foldl fsc-list-ref @@ -74,7 +71,7 @@ #:attr contract #'(-> list? any) #:attr name #''list->cstream)) -(define-syntax-class fsp-intf +(define-syntax-class fsp-syntax (pattern (~or _:fsp-range _:fsp-default))) @@ -137,7 +134,7 @@ (pattern (~or filter:fst-filter filter-map:fst-filter-map))) -(define-syntax-class fst-intf +(define-syntax-class fst-syntax (pattern (~or _:fst-filter _:fst-map _:fst-filter-map @@ -228,7 +225,7 @@ #:datum-literals (cstream->list) (pattern cstream->list)) -(define-syntax-class fsc-intf +(define-syntax-class fsc-syntax (pattern (~or _:fsc-foldr _:fsc-foldl _:fsc-list-ref @@ -243,18 +240,18 @@ ;; Used only in deforest-rewrite to properly recognize the end of ;; fusable sequence. (define-syntax-class non-fusable - (pattern (~not (~or _:fst-intf - _:fsp-intf - _:fsc-intf)))) + (pattern (~not (~or _:fst-syntax + _:fsp-syntax + _:fsc-syntax)))) (define (make-deforest-rewrite generate-fused-operation) (lambda (stx) (syntax-parse stx [((~datum thread) _0:non-fusable ... - p:fsp-intf + p:fsp-syntax ;; There can be zero transformers here: - t:fst-intf ... - c:fsc-intf + t:fst-syntax ... + c:fsc-syntax _1 ...) #:with fused (generate-fused-operation (syntax->list #'(p t ... c)) @@ -262,17 +259,17 @@ #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... t1:fst-intf0 - t:fst-intf ... - c:fsc-intf + t:fst-syntax ... + c:fsc-syntax _1 ...) #:with fused (generate-fused-operation (syntax->list #'(list->cstream t1 t ... c)) stx) #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... - p:fsp-intf + p:fsp-syntax ;; Must be 1 or more transformers here: - t:fst-intf ...+ + t:fst-syntax ...+ _1 ...) #:with fused (generate-fused-operation (syntax->list #'(p t ... cstream->list)) @@ -280,7 +277,7 @@ #'(thread _0 ... fused _1 ...)] [((~datum thread) _0:non-fusable ... f1:fst-intf0 - f:fst-intf ...+ + f:fst-syntax ...+ _1 ...) #:with fused (generate-fused-operation (syntax->list #'(list->cstream f1 f ... cstream->list)) From 06644b964f06dd54041e5d33fd98c39232cdc581 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Sat, 15 Jun 2024 11:14:22 +0200 Subject: [PATCH 17/21] Fix tests of qi/list - use the new bindings. --- qi-test/tests/compiler/rules/deforest.rkt | 1 + qi-test/tests/compiler/rules/full-cycle.rkt | 1 + 2 files changed, 2 insertions(+) diff --git a/qi-test/tests/compiler/rules/deforest.rkt b/qi-test/tests/compiler/rules/deforest.rkt index b68f1090..1023475d 100644 --- a/qi-test/tests/compiler/rules/deforest.rkt +++ b/qi-test/tests/compiler/rules/deforest.rkt @@ -10,6 +10,7 @@ qi/flow/extended/forms qi/flow/core/compiler qi/flow/core/compiler/0100-deforest + qi/list syntax/macro-testing (submod qi/flow/extended/expander invoke) rackunit diff --git a/qi-test/tests/compiler/rules/full-cycle.rkt b/qi-test/tests/compiler/rules/full-cycle.rkt index 3b4535b1..5aaca6b9 100644 --- a/qi-test/tests/compiler/rules/full-cycle.rkt +++ b/qi-test/tests/compiler/rules/full-cycle.rkt @@ -11,6 +11,7 @@ rackunit/text-ui syntax/macro-testing qi/flow/core/compiler/0100-deforest + qi/list "private/deforest-util.rkt" (submod qi/flow/extended/expander invoke)) From 5038ae5a48218b478130e077490fe5462a5998e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 14 Jun 2024 10:57:34 +0200 Subject: [PATCH 18/21] Split bindings module and add appropriate scribblings. - scribblings for qi/list module - scribble the new literals for matching in deforestation pass - ensure for-label bindings in the generated documentation - new bindings.rkt module --- qi-doc/scribblings/list-operations.scrbl | 118 ++++++++++++++++++ .../flow/core/compiler/deforest/bindings.rkt | 35 ++++++ qi-lib/list.rkt | 4 +- 3 files changed, 155 insertions(+), 2 deletions(-) create mode 100644 qi-doc/scribblings/list-operations.scrbl create mode 100644 qi-lib/flow/core/compiler/deforest/bindings.rkt diff --git a/qi-doc/scribblings/list-operations.scrbl b/qi-doc/scribblings/list-operations.scrbl new file mode 100644 index 00000000..2b70c118 --- /dev/null +++ b/qi-doc/scribblings/list-operations.scrbl @@ -0,0 +1,118 @@ +#lang scribble/doc +@require[scribble/manual + (for-label racket/list + racket/base)] + +@title{List Operations} + +@defmodule[qi/list] + +This module defines bindings that can leverage stream fusion / +deforestation optimization when found in succession within a +flow. When not part of optimized flow, their behavior is identical to +the bindings of the same name from @racketmodname[racket/base] and +@racketmodname[racket/list]. + +The bindings are categorized based on their intended usage inside the +deforested pipeline. + +@section{Producers} + +@defproc*[(((range (end real?)) list?) + ((range (start real?) (end real?) (step real? 1)) list?))]{ + +Deforestable version of @racket[range] from @racketmodname[racket/list]. + +} + +@section{Transformers} + +@defproc[(filter (pred procedure?) (lst list?)) list?]{ + +Deforestable version of @racket[filter] from @racketmodname[racket/base]. + +} + +@defproc[(map (proc procedure?) (lst list?) ...+) list?]{ + +Deforestable version of @racket[map] from @racketmodname[racket/base]. + +} + +@defproc[(filter-map (proc procedure?) (lst list?) ...+) list?]{ + +Deforestable version of @racket[filter-map] from @racketmodname[racket/list]. + +} + +@defproc*[(((take (lst list?) (pos exact-nonnegative-integer?)) list?) + ((take (lst any/c) (pos exact-nonnegative-integer?)) list?))]{ + +Deforestable version of @racket[take] from @racketmodname[racket/list]. + +} + +@section{Consumers} + +@defproc[(foldl (proc procedure?) (init any/c) (lst list?) ...+) any/c]{ + +Deforestable version of @racket[foldl] from @racketmodname[racket/base]. + +} + +@defproc[(foldr (proc procedure?) (init any/c) (lst list?) ...+) any/c]{ + +Deforestable version of @racket[foldr] from @racketmodname[racket/base]. + +} + +@defproc[(car (p pair?)) any/c]{ + +Deforestable version of @racket[car] from @racketmodname[racket/base]. + +} + +@defproc[(cadr (v (cons/c any/c pair?))) any/c]{ + +Deforestable version of @racket[cadr] from @racketmodname[racket/base]. + +} + +@defproc[(caddr (v (cons/c any/c (cons/c any/c pair?)))) any/c]{ + +Deforestable version of @racket[caddr] from @racketmodname[racket/base]. + +} + +@defproc[(cadddr (v (cons/c any/c (cons/c any/c (cons/c any/c pair?))))) any/c]{ + +Deforestable version of @racket[cadddr] from @racketmodname[racket/base]. + +} + +@defproc*[(((list-ref (lst list?) (pos exact-nonnegative-integer?)) any/c) + ((list-ref (lst pair?) (pos exact-nonnegative-integer?)) any/c))]{ + +Deforestable version of @racket[list-ref] from @racketmodname[racket/base]. + +} + +@defproc[(length (lst list?)) exact-nonnegative-integer?]{ + +Deforestable version of @racket[length] from @racketmodname[racket/base]. + +} + +@defproc[(empty? (v any/c)) boolean?]{ + +Deforestable version of @racket[empty?] from @racketmodname[racket/list]. + +} + +@defproc[(null? (v any/c)) boolean?]{ + +Deforestable version of @racket[null?] from @racketmodname[racket/base]. + +} + + diff --git a/qi-lib/flow/core/compiler/deforest/bindings.rkt b/qi-lib/flow/core/compiler/deforest/bindings.rkt new file mode 100644 index 00000000..22eccb9a --- /dev/null +++ b/qi-lib/flow/core/compiler/deforest/bindings.rkt @@ -0,0 +1,35 @@ +#lang racket/base + +(require (prefix-in r: racket/base) + (prefix-in r: racket/list) + syntax/parse/define + (for-syntax racket/syntax + syntax/parse + racket/base)) + +(define-syntax-parser define-and-provide-deforestable-bindings + ((_ ids ...) + (with-syntax (((rids ...) (for/list ((s (attribute ids))) + (format-id s "r:~a" s)))) + #'(begin + (define ids rids) ... + (provide ids ...))))) + +(define-and-provide-deforestable-bindings + range + + filter + map + filter-map + take + + foldr + foldl + car + cadr + caddr + cadddr + list-ref + length + empty? + null?) diff --git a/qi-lib/list.rkt b/qi-lib/list.rkt index 2558d68a..0e8ca781 100644 --- a/qi-lib/list.rkt +++ b/qi-lib/list.rkt @@ -3,6 +3,6 @@ ;; Upon instantiation of the module it define-and-register-pass for ;; deforestation (require "flow/core/compiler/0100-deforest.rkt" - "flow/core/compiler/deforest/binding.rkt") + "flow/core/compiler/deforest/bindings.rkt") -(provide (all-from-out "flow/core/compiler/deforest/binding.rkt")) +(provide (all-from-out "flow/core/compiler/deforest/bindings.rkt")) From b9d402cca2569d39ace9eacfb39b479ed4016815 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Thu, 27 Jun 2024 11:50:01 +0200 Subject: [PATCH 19/21] Update PR#175 with all the changes agreed upon at the weekly Qi compiler meeting on 2024-06-21. - add detailed explanation for inline-consing syntax - use Racket's conventions for parentheses - add description of fsp-, fst-, and fsc- prefixes - move define-and-register-deforest-pass and related to separate module, add comments --- qi-lib/flow/core/compiler/deforest/cps.rkt | 44 +++++---- qi-lib/flow/core/compiler/deforest/fusion.rkt | 76 +++++++++++++++ qi-lib/flow/core/compiler/deforest/syntax.rkt | 96 ++++++------------- 3 files changed, 129 insertions(+), 87 deletions(-) create mode 100644 qi-lib/flow/core/compiler/deforest/fusion.rkt diff --git a/qi-lib/flow/core/compiler/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt index 918a684a..65072bcd 100644 --- a/qi-lib/flow/core/compiler/deforest/cps.rkt +++ b/qi-lib/flow/core/compiler/deforest/cps.rkt @@ -7,7 +7,8 @@ "syntax.rkt" "../../../extended/util.rkt" syntax/srcloc - racket/syntax-srcloc) + racket/syntax-srcloc + "fusion.rkt") "templates.rkt" racket/performance-hint racket/match @@ -24,6 +25,13 @@ [(_ [op (f ...) g ...] rest ...) (op f ... (inline-compose1 rest ...) g ...)] )) +;; Adds the initial states of all stateful transformers in the +;; required order to the initial producer state. Uses (cons Tx S) +;; where Tx is the transformer's initial state and S is the producer's +;; initial state with all preceding transformer states already +;; added. Nothing is added for stateless transformers which pass () as +;; their initial state expression. For example: (inline-consing (T1) +;; () (T2) P) -> (cons T2 (cons T1 P)) (define-syntax inline-consing (syntax-rules () [(_ state () rest ...) (inline-consing state rest ...)] @@ -289,22 +297,21 @@ (λ (take-state) (define n (car take-state)) (define state (cdr take-state)) - (cond ((zero? n) - (done)) - (else - ((next (λ () - ((contract (-> pair? any) - (λ (v) v) - 'take ctx - #f - src - ) '())) - (λ (state) - (skip (cons n state))) - (λ (value state) - (define new-state (cons (sub1 n) state)) - (yield value new-state))) - state)))))) + (if (zero? n) + (done) + ((next (λ () + ((contract (-> pair? any) + (λ (v) v) + 'take ctx + #f + src) + '())) + (λ (state) + (skip (cons n state))) + (λ (value state) + (define new-state (cons (sub1 n) state)) + (yield value new-state))) + state))))) ;; Consumers @@ -342,7 +349,8 @@ ((next (λ () ((contract (-> pair? any) (λ (v) v) name ctx #f - src) '())) + src) + '())) (λ (state) (loop state countdown)) (λ (value state) (if (zero? countdown) diff --git a/qi-lib/flow/core/compiler/deforest/fusion.rkt b/qi-lib/flow/core/compiler/deforest/fusion.rkt new file mode 100644 index 00000000..9049c377 --- /dev/null +++ b/qi-lib/flow/core/compiler/deforest/fusion.rkt @@ -0,0 +1,76 @@ +#lang racket/base + +(provide define-and-register-deforest-pass) + +(require (for-syntax racket/base + syntax/parse) + syntax/parse + "syntax.rkt" + "../../passes.rkt" + "../../strategy.rkt") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The actual fusion generator implementation + +;; Used only in deforest-rewrite to properly recognize the end of +;; fusable sequence. +(define-syntax-class non-fusable + (pattern (~not (~or _:fst-syntax + _:fsp-syntax + _:fsc-syntax)))) + +(define (make-deforest-rewrite generate-fused-operation) + (lambda (stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fsp-syntax + ;; There can be zero transformers here: + t:fst-syntax ... + c:fsc-syntax + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fst-syntax0 + t:fst-syntax ... + c:fsc-syntax + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fsp-syntax + ;; Must be 1 or more transformers here: + t:fst-syntax ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fst-syntax0 + f:fst-syntax ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + ;; return the input syntax unchanged if no rules + ;; are applicable + [_ stx]))) + +;; This syntax is actively used only once as it is intended to be used +;; by alternative implementations. Currently only the CPS +;; implementation uses it, however in the near future the named-let +;; implementation will use it as well. +(define-syntax (define-and-register-deforest-pass stx) + (syntax-parse stx + ((_ (deforest-pass ops ctx) expr ...) + #'(define-and-register-pass 100 (deforest-pass stx) + (find-and-map/qi + (make-deforest-rewrite + (lambda (ops ctx) + expr ...)) + stx))))) diff --git a/qi-lib/flow/core/compiler/deforest/syntax.rkt b/qi-lib/flow/core/compiler/deforest/syntax.rkt index dfab0e9c..ebe2f6e9 100644 --- a/qi-lib/flow/core/compiler/deforest/syntax.rkt +++ b/qi-lib/flow/core/compiler/deforest/syntax.rkt @@ -1,6 +1,11 @@ #lang racket/base -(provide fsp-range +(provide fsp-syntax + fst-syntax0 + fst-syntax + fsc-syntax + + fsp-range fsp-default fst-filter @@ -15,7 +20,6 @@ fsc-empty? fsc-default - define-and-register-deforest-pass ) (require syntax/parse @@ -29,12 +33,19 @@ (for-syntax racket/base syntax/parse)) +;; Literals set used for matching Fusable Stream Literals (define-literal-set fs-literals #:datum-literals (esc #%host-expression #%fine-template #%blanket-template _ __) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Producers +;; Fusable Stream Producers +;; +;; Syntax classes used for matching functions that produce a sequence +;; of values and they annotate the syntax with attributes that will be +;; used in the compiler to apply optimizations. +;; +;; All are prefixed with fsp- for clarity. (define-syntax-class fsp-range #:attributes (blanket? fine? arg pre-arg post-arg) @@ -76,7 +87,12 @@ _:fsp-default))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Transformers +;; Fusable Stream Transformers +;; +;; Syntax classes matching functions acting as transformers of the +;; sequence of values passing through. +;; +;; All are prefixed with fst- for clarity. (define-syntax-class fst-filter #:attributes (f) @@ -130,7 +146,7 @@ _ (#%host-expression n))))) -(define-syntax-class fst-intf0 +(define-syntax-class fst-syntax0 (pattern (~or filter:fst-filter filter-map:fst-filter-map))) @@ -141,7 +157,12 @@ _:fst-take))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Consumers +;; Fusable Stream Consumers +;; +;; Syntax classes used for matching functions that can consume all +;; values from a sequence and create a single value from those. +;; +;; Prefixed with fsc- for clarity. (define-syntax-class fsc-foldr #:attributes (op init) @@ -233,66 +254,3 @@ _:fsc-empty? _:fsc-default ))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The actual fusion generator implementation - -;; Used only in deforest-rewrite to properly recognize the end of -;; fusable sequence. -(define-syntax-class non-fusable - (pattern (~not (~or _:fst-syntax - _:fsp-syntax - _:fsc-syntax)))) - -(define (make-deforest-rewrite generate-fused-operation) - (lambda (stx) - (syntax-parse stx - [((~datum thread) _0:non-fusable ... - p:fsp-syntax - ;; There can be zero transformers here: - t:fst-syntax ... - c:fsc-syntax - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - t1:fst-intf0 - t:fst-syntax ... - c:fsc-syntax - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream t1 t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fsp-syntax - ;; Must be 1 or more transformers here: - t:fst-syntax ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - f1:fst-intf0 - f:fst-syntax ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream f1 f ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - ;; return the input syntax unchanged if no rules - ;; are applicable - [_ stx]))) - -(define-syntax (define-and-register-deforest-pass stx) - (syntax-parse stx - ((_ (deforest-pass ops ctx) expr ...) - #'(define-and-register-pass 100 (deforest-pass stx) - (find-and-map/qi - (make-deforest-rewrite - (lambda (ops ctx) - expr ...)) - stx))))) From b5a94444cd2fdea12a347a4232ccc68b0756c35f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 28 Jun 2024 19:45:26 +0200 Subject: [PATCH 20/21] Fix phase shifting for fusion.rkt module. --- qi-lib/flow/core/compiler/deforest/fusion.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/qi-lib/flow/core/compiler/deforest/fusion.rkt b/qi-lib/flow/core/compiler/deforest/fusion.rkt index 9049c377..6f2ccf43 100644 --- a/qi-lib/flow/core/compiler/deforest/fusion.rkt +++ b/qi-lib/flow/core/compiler/deforest/fusion.rkt @@ -7,7 +7,9 @@ syntax/parse "syntax.rkt" "../../passes.rkt" - "../../strategy.rkt") + "../../strategy.rkt" + (for-template "../../passes.rkt")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The actual fusion generator implementation From 016ab4148b7213686bbb7a17562db17237b11cc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dominik=20Pant=C5=AF=C4=8Dek?= Date: Fri, 28 Jun 2024 19:52:14 +0200 Subject: [PATCH 21/21] Add attach-form-property to both places needed by current deforestation (CPS) implementation. --- qi-lib/flow/core/compiler/deforest/cps.rkt | 50 +++++------ qi-lib/flow/core/compiler/deforest/fusion.rkt | 84 ++++++++++--------- 2 files changed, 69 insertions(+), 65 deletions(-) diff --git a/qi-lib/flow/core/compiler/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt index 65072bcd..59ccc7d9 100644 --- a/qi-lib/flow/core/compiler/deforest/cps.rkt +++ b/qi-lib/flow/core/compiler/deforest/cps.rkt @@ -8,7 +8,8 @@ "../../../extended/util.rkt" syntax/srcloc racket/syntax-srcloc - "fusion.rkt") + "fusion.rkt" + "../../private/form-property.rkt") "templates.rkt" racket/performance-hint racket/match @@ -207,29 +208,30 @@ ;; fused sequence. And runtime checks for consumers are in ;; their respective implementation procedure. (with-syntax (((rt ...) (reverse (attribute t.state)))) - #`(esc - (#,((attribute p.curry) ctx (attribute p.name)) - (contract p.contract - (p.prepare - (lambda (state) - (define cstate (inline-consing state rt ...)) - cstate) - (#,@#'c.end - (inline-compose1 [t.next t.f - '#,(prettify-flow-syntax ctx) - '#,(build-source-location-vector - (syntax-srcloc ctx)) - ] ... - p.next - ) - '#,(prettify-flow-syntax ctx) - '#,(build-source-location-vector - (syntax-srcloc ctx)))) - p.name - '#,(prettify-flow-syntax ctx) - #f - '#,(build-source-location-vector - (syntax-srcloc ctx))))))])) + (attach-form-property + #`(esc + (#,((attribute p.curry) ctx (attribute p.name)) + (contract p.contract + (p.prepare + (lambda (state) + (define cstate (inline-consing state rt ...)) + cstate) + (#,@#'c.end + (inline-compose1 [t.next t.f + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)) + ] ... + p.next + ) + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)))) + p.name + '#,(prettify-flow-syntax ctx) + #f + '#,(build-source-location-vector + (syntax-srcloc ctx)))))))])) ) diff --git a/qi-lib/flow/core/compiler/deforest/fusion.rkt b/qi-lib/flow/core/compiler/deforest/fusion.rkt index 6f2ccf43..46448995 100644 --- a/qi-lib/flow/core/compiler/deforest/fusion.rkt +++ b/qi-lib/flow/core/compiler/deforest/fusion.rkt @@ -8,7 +8,8 @@ "syntax.rkt" "../../passes.rkt" "../../strategy.rkt" - (for-template "../../passes.rkt")) + (for-template "../../passes.rkt") + "../../private/form-property.rkt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The actual fusion generator implementation @@ -22,46 +23,47 @@ (define (make-deforest-rewrite generate-fused-operation) (lambda (stx) - (syntax-parse stx - [((~datum thread) _0:non-fusable ... - p:fsp-syntax - ;; There can be zero transformers here: - t:fst-syntax ... - c:fsc-syntax - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - t1:fst-syntax0 - t:fst-syntax ... - c:fsc-syntax - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream t1 t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fsp-syntax - ;; Must be 1 or more transformers here: - t:fst-syntax ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - f1:fst-syntax0 - f:fst-syntax ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream f1 f ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - ;; return the input syntax unchanged if no rules - ;; are applicable - [_ stx]))) + (attach-form-property + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fsp-syntax + ;; There can be zero transformers here: + t:fst-syntax ... + c:fsc-syntax + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fst-syntax0 + t:fst-syntax ... + c:fsc-syntax + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fsp-syntax + ;; Must be 1 or more transformers here: + t:fst-syntax ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fst-syntax0 + f:fst-syntax ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + ;; return the input syntax unchanged if no rules + ;; are applicable + [_ stx])))) ;; This syntax is actively used only once as it is intended to be used ;; by alternative implementations. Currently only the CPS