diff --git a/.github/workflows/benchmarks.yml b/.github/workflows/benchmarks.yml index d3db3cd7c..a8645f324 100644 --- a/.github/workflows/benchmarks.yml +++ b/.github/workflows/benchmarks.yml @@ -25,7 +25,7 @@ jobs: run: make install-sdk - name: Run benchmark shell: 'bash --noprofile --norc -eo pipefail {0}' - run: make report-benchmarks | tee benchmarks.txt + run: make performance-report | tee benchmarks.txt - name: Store benchmark result uses: benchmark-action/github-action-benchmark@v1 with: diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 321a10169..d844ca173 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -14,7 +14,7 @@ jobs: fail-fast: true matrix: racket-variant: ['BC', 'CS'] - racket-version: ['8.3', 'stable'] + racket-version: ['8.5', 'stable'] experimental: [false] include: - racket-version: 'current' diff --git a/Makefile b/Makefile index 6f620b06a..8642cfe21 100644 --- a/Makefile +++ b/Makefile @@ -7,12 +7,15 @@ DEPS-FLAGS=--check-pkg-deps --unused-pkg-deps help: @echo "install - install package along with dependencies" + @echo "install-sdk - install the SDK which includes developer tools" @echo "remove - remove package" + @echo "remove-sdk - remove SDK; this will not remove SDK dependencies" @echo "build - Compile libraries" @echo "build-docs - Build docs" @echo "build-standalone-docs - Build self-contained docs that could be hosted somewhere" @echo "build-all - Compile libraries, build docs, and check dependencies" @echo "clean - remove all build artifacts" + @echo "clean-sdk - remove all build artifacts in SDK paths" @echo "check-deps - check dependencies" @echo "test - run tests" @echo "test-with-errortrace - run tests with error tracing" @@ -27,6 +30,8 @@ help: @echo " definitions" @echo " macro" @echo " util" + @echo " expander" + @echo " compiler" @echo " probe" @echo " Note: As probe is not in qi-lib, it isn't part of" @echo " the tests run in the 'test' target." @@ -37,9 +42,14 @@ help: @echo "docs - view docs in a browser" @echo "profile - Run comprehensive performance benchmarks" @echo "profile-competitive - Run competitive benchmarks" - @echo "profile-forms - Run benchmarks for individual Qi forms" + @echo "profile-local - Run benchmarks for individual Qi forms" + @echo "profile-nonlocal - Run nonlocal benchmarks exercising many components at once" @echo "profile-selected-forms - Run benchmarks for Qi forms by name (command only)" - @echo "report-benchmarks - Run benchmarks for Qi forms and produce results for use in CI" + @echo "performance-report - Run benchmarks for Qi forms and produce results for use in CI and for measuring regression" + @echo " For use in regression: make performance-report > /path/to/before.json" + @echo "performance-regression-report - Run benchmarks for Qi forms against a reference report." + @echo " make performance-regression-report REF=/path/to/before.json" + # Primarily for use by CI. # Installs dependencies as well as linking this as a package. @@ -82,6 +92,9 @@ build-standalone-docs: clean: raco setup --fast-clean --pkgs $(PACKAGE-NAME)-{lib,test,doc,probe} +clean-sdk: + raco setup --fast-clean --pkgs $(PACKAGE-NAME)-sdk + # Primarily for use by CI, after make install -- since that already # does the equivalent of make setup, this tries to do as little as # possible except checking deps. @@ -93,25 +106,31 @@ test: raco test -exp $(PACKAGE-NAME)-{lib,test,doc,probe} test-flow: - racket $(PACKAGE-NAME)-test/tests/flow.rkt + racket -y $(PACKAGE-NAME)-test/tests/flow.rkt test-on: - racket $(PACKAGE-NAME)-test/tests/on.rkt + racket -y $(PACKAGE-NAME)-test/tests/on.rkt test-threading: - racket $(PACKAGE-NAME)-test/tests/threading.rkt + racket -y $(PACKAGE-NAME)-test/tests/threading.rkt test-switch: - racket $(PACKAGE-NAME)-test/tests/switch.rkt + racket -y $(PACKAGE-NAME)-test/tests/switch.rkt test-definitions: - racket $(PACKAGE-NAME)-test/tests/definitions.rkt + racket -y $(PACKAGE-NAME)-test/tests/definitions.rkt test-macro: - racket $(PACKAGE-NAME)-test/tests/macro.rkt + racket -y $(PACKAGE-NAME)-test/tests/macro.rkt test-util: - racket $(PACKAGE-NAME)-test/tests/util.rkt + racket -y $(PACKAGE-NAME)-test/tests/util.rkt + +test-expander: + racket -y $(PACKAGE-NAME)-test/tests/expander.rkt + +test-compiler: + racket -y $(PACKAGE-NAME)-test/tests/compiler.rkt test-probe: raco test -exp $(PACKAGE-NAME)-probe @@ -159,20 +178,27 @@ cover: coverage-check coverage-report cover-coveralls: raco cover -b -f coveralls -p $(PACKAGE-NAME)-{lib,test} -profile-forms: - echo "Profiling forms..." - racket $(PACKAGE-NAME)-sdk/profile/forms.rkt +profile-local: + racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt + +profile-loading: + racket $(PACKAGE-NAME)-sdk/profile/loading/report.rkt profile-selected-forms: - @echo "Use 'racket profile/forms.rkt' directly, with -f form-name for each form." + @echo "Use 'racket $(PACKAGE-NAME)-sdk/profile/local/report.rkt' directly, with -s form-name for each form." profile-competitive: - echo "Running competitive benchmarks..." - racket $(PACKAGE-NAME)-sdk/profile/competitive.rkt + cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-competitive.rkt + +profile-nonlocal: + cd $(PACKAGE-NAME)-sdk/profile/nonlocal; racket report-intrinsic.rkt -l qi + +profile: profile-local profile-nonlocal profile-loading -profile: profile-competitive profile-forms +performance-report: + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -f json -report-benchmarks: - @racket $(PACKAGE-NAME)-sdk/profile/report.rkt +performance-regression-report: + @racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF) -.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-forms profile-selected-forms profile-competitive profile report-benchmarks +.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-expander test-compiler test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report diff --git a/qi-doc/scribblings/field-guide.scrbl b/qi-doc/scribblings/field-guide.scrbl index 853093cd3..5843ba519 100644 --- a/qi-doc/scribblings/field-guide.scrbl +++ b/qi-doc/scribblings/field-guide.scrbl @@ -8,18 +8,24 @@ racket]] @(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - qi/probe - (only-in racket/list range) - racket/string - (for-syntax syntax/parse - racket/base)) - '(define (sqr x) - (* x x))))) + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + qi/probe + (only-in racket/list range) + racket/string + (for-syntax syntax/parse + racket/base)) + '(define (sqr x) + (* x x))))))) @title{Field Guide} @@ -336,6 +342,7 @@ Another way to do it is to simply promote the expression out of the nest: (~> (3) (get-f 1)) ] +@;{TODO: Update this to reflect new partial application behavior} Now, you might, once again, expect this to be treated as a partial application template, so that this would be equivalent to @racket[(get-f 3 1)] and would raise an error. But in fact, since the expression @racket[(get-f 1)] happens to be fully qualified with all the arguments it needs, the currying employed under the hood to implement partial application in this case @seclink["Using_Racket_to_Define_Flows"]{evaluates to a function result right away}. This then receives the value @racket[3], and consequently, this expression produces the correct result. So in sum, it's perhaps best to rely on @racket[esc] in such cases to be as explicit as possible about what you mean, rather than rely on quirks of the implementation that are revealed at this boundary between two languages. diff --git a/qi-doc/scribblings/forms.scrbl b/qi-doc/scribblings/forms.scrbl index d59a9968a..7e5644cf5 100644 --- a/qi-doc/scribblings/forms.scrbl +++ b/qi-doc/scribblings/forms.scrbl @@ -7,15 +7,21 @@ racket]] @(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range first rest) - racket/string) - '(define (sqr x) - (* x x))))) + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range first rest) + racket/string) + '(define (sqr x) + (* x x))))))) @(define diagram-eval (make-base-eval)) @(diagram-eval '(require metapict)) @@ -346,11 +352,15 @@ Note that the symbol form uses Unicode @code{0x2225} corresponding to LaTeX's @c @deftogether[( @defform[(== flo ...)] @defform[(relay flo ...)] +@defidform[#:link-target? #f ==] +@defidform[#:link-target? #f relay] )]{ Compose flows in parallel, so that inputs are passed through the corresponding @racket[flo]'s individually. The number of @racket[flo]s must be the same as the number of runtime inputs. In the common case of @code{1 × 1} @racket[flo]s (i.e. where the flows each accept one input and produce one output), the number of outputs will be the same as the number of inputs, but as @seclink["What_is_a_Flow_"]{flows can be nonlinear}, this is not necessarily the case in general. + When used in identifier form simply as @racket[==], it behaves identically to @racket[><]. + See also the field guide entry on the @seclink["Bindings_are_an_Alternative_to_Nonlinearity"]{relationship between bindings and nonlinearity}. @examples[ @@ -568,11 +578,14 @@ A form of generalized @racket[sieve], passing all the inputs that satisfy each (loop condition-flo map-flo)] @defform[#:link-target? #f (loop map-flo)] + @defidform[#:link-target? #f loop] )]{ A simple loop for structural recursion on the input values, this applies @racket[map-flo] to the first input on each successive iteration and recurses on the remaining inputs, combining these using @racket[combine-flo] to yield the result as long as the inputs satisfy @racket[condition-flo]. When the inputs do not satisfy @racket[condition-flo], @racket[return-flo] is applied to the inputs to yield the result at that terminating step. If the condition is satisfied and there are no further values, the loop terminates naturally. If unspecified, @racket[condition-flo] defaults to @racket[#t], @racket[combine-flo] defaults to @racket[_], and @racket[return-flo] defaults to @racket[⏚]. + When used in identifier form simply as @racket[loop], this behaves the same as the fully qualified version, except that the flows parametrizing the loop are expected as the initial four inputs (in the same order), and the data inputs being acted upon are expected to follow. + @examples[ #:eval eval-for-docs ((☯ (loop (* 2))) 1 2 3) diff --git a/qi-doc/scribblings/interface.scrbl b/qi-doc/scribblings/interface.scrbl index 70cdcbaf6..6a085e5fc 100644 --- a/qi-doc/scribblings/interface.scrbl +++ b/qi-doc/scribblings/interface.scrbl @@ -8,16 +8,22 @@ syntax/parse/define]] @(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - racket/string) - '(define ->string number->string) - '(define (sqr x) - (* x x))))) + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range) + racket/string) + '(define ->string number->string) + '(define (sqr x) + (* x x))))))) @title{Language Interface} @@ -354,19 +360,6 @@ The second way is if you want to describe a flow using the host language instead (~> (3 5) add-two) ] -Finally, note that the following case works: - -@examples[ - #:eval eval-for-docs - (define (get-flow v) - (☯ (~> sqr (+ v)))) - (~> (5) (get-flow 3)) - ] - -You might expect here that the expression @racket[(get-flow 3)] would be treated as a @seclink["Templates_and_Partial_Application"]{partial application template}, so that the value @racket[5] would be provided to it as @racket[(get-flow 5 3)], resulting in an error. The reason this isn't what happens is that the partial application behavior in Qi when no argument positions have been indicated is implemented using currying rather than as a template application, and Racket's @racket[curry] and @racket[curryr] functions happen to evaluate to a result immediately if the maximum expected arguments have been provided. Thus, in this case, the @racket[(get-flow 3)] expression is first evaluated to produce a resulting flow which then receives the value @racket[5]. - -So, function applications where all of the arguments are provided syntactically, and which produce functions as their result, may be used as if they were simple function identifiers, and @racket[esc] may be left out. - @subsection{Using Racket Macros as Flows} Flows are expected to be @seclink["What_is_a_Flow_"]{functions}, and so you cannot naively use a macro as a flow. But there are many ways in which you can. If you'd just like to use such a macro in a one-off manner, see @secref["Converting_a_Macro_to_a_Flow"] for an ad hoc way to do this. But a simpler and more complete way in many cases is to first register the macro (or any number of such macros) using @racket[define-qi-foreign-syntaxes] prior to use. diff --git a/qi-doc/scribblings/intro.scrbl b/qi-doc/scribblings/intro.scrbl index a8968f8cd..47428f66c 100644 --- a/qi-doc/scribblings/intro.scrbl +++ b/qi-doc/scribblings/intro.scrbl @@ -7,15 +7,21 @@ racket]] @(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - racket/string) - '(define (sqr x) - (* x x))))) + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range) + racket/string) + '(define (sqr x) + (* x x))))))) @title{Introduction and Usage} diff --git a/qi-doc/scribblings/macros.scrbl b/qi-doc/scribblings/macros.scrbl index 3c33dedf1..d3da331aa 100644 --- a/qi-doc/scribblings/macros.scrbl +++ b/qi-doc/scribblings/macros.scrbl @@ -9,16 +9,22 @@ syntax/parse/define]] @(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range first rest) - (for-syntax syntax/parse racket/base) - racket/string) - '(define (sqr x) - (* x x))))) + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range first rest) + (for-syntax syntax/parse racket/base) + racket/string) + '(define (sqr x) + (* x x))))))) @title[#:tag "Qi_Macros"]{Qi Macros} diff --git a/qi-doc/scribblings/tutorial.scrbl b/qi-doc/scribblings/tutorial.scrbl index 054fcc9ca..0dcdfb62f 100644 --- a/qi-doc/scribblings/tutorial.scrbl +++ b/qi-doc/scribblings/tutorial.scrbl @@ -8,16 +8,22 @@ racket]] @(define eval-for-docs - (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-memory-limit #f]) - (make-evaluator 'racket/base - '(require qi - (only-in racket/list range) - (only-in racket/function curry) - racket/string) - '(define (sqr x) - (* x x))))) + ;; The "trusted" sandbox configuration is needed possibly + ;; because of the interaction of binding spaces with + ;; sandbox evaluator. For more context, see the Qi wiki + ;; "Qi Compiler Sync Sept 2 2022." + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-memory-limit #f]) + (make-evaluator 'racket/base + '(require qi + (only-in racket/list range) + (only-in racket/function curry) + racket/string) + '(define (sqr x) + (* x x))))))) @title{Tutorial} diff --git a/qi-lib/flow.rkt b/qi-lib/flow.rkt index af6f067ac..773d33328 100644 --- a/qi-lib/flow.rkt +++ b/qi-lib/flow.rkt @@ -1,19 +1,19 @@ #lang racket/base (provide flow - ☯) + ☯ + (all-from-out "flow/extended/expander.rkt") + (all-from-out "flow/extended/forms.rkt")) -(require syntax/parse/define - (prefix-in fancy: fancy-app) - racket/function - (only-in racket/list - make-list) +(require syntax-spec-v1 (for-syntax racket/base syntax/parse (only-in "private/util.rkt" - report-syntax-error) - "flow/expander.rkt") - "flow/compiler.rkt" + report-syntax-error)) + "flow/extended/expander.rkt" + "flow/core/compiler.rkt" + "flow/extended/forms.rkt" + (for-syntax "flow/extended/util.rkt") (only-in "private/util.rkt" define-alias)) @@ -33,14 +33,19 @@ module, defined after the flow macro. They are all invoked as needed in the flow macro. |# -(define-syntax-parser flow - [(_ onex) ((compose compile-flow expand-flow) #'onex)] - ;; a non-flow - [(_) #'values] - ;; error handling catch-all - [(_ expr0 expr ...+) - (report-syntax-error - 'flow - (syntax->datum #'(expr0 expr ...)) - "(flow flo)" - "flow expects a single flow specification, but it received many.")]) +(syntax-spec + (host-interface/expression + (flow f:closed-floe ...) + (syntax-parse #'(f ...) + [(f) (compile-flow #'f)] + ;; a non-flow + [() #'values] + ;; error handling catch-all + [(expr0 expr ...+) + (report-syntax-error + (datum->syntax this-syntax + (cons 'flow + (map prettify-flow-syntax + (syntax->list this-syntax)))) + "(flow flo)" + "flow expects a single flow specification, but it received many.")]))) diff --git a/qi-lib/flow/aux-syntax.rkt b/qi-lib/flow/aux-syntax.rkt index 0f12421db..e5cf653a4 100644 --- a/qi-lib/flow/aux-syntax.rkt +++ b/qi-lib/flow/aux-syntax.rkt @@ -17,6 +17,9 @@ expr:number expr:regexp expr:byte-regexp + expr:vector-literal + expr:box-literal + expr:prefab-literal ;; We'd like to treat quoted forms as literals as well. This ;; includes symbols, and would also include, for instance, ;; syntactic specifications of flows, since flows are @@ -30,17 +33,26 @@ (define-syntax-class subject #:attributes (args arity) - (pattern - (arg:expr ...) - #:with args #'(arg ...) - #:attr arity (length (syntax->list #'args)))) + (pattern (arg:expr ...) + #:with args #'(arg ...) + #:attr arity (length (syntax->list #'args)))) (define-syntax-class clause - (pattern - expr:expr)) + (pattern expr:expr)) -(define-syntax-class (starts-with pfx) - (pattern - i:id #:when (string-prefix? (symbol->string - (syntax-e #'i)) pfx))) +(define-syntax-class vector-literal + (pattern #(_ ...))) +(define-syntax-class box-literal + (pattern #&v)) + +(define-syntax-class prefab-literal + (pattern e:expr + #:when (prefab-struct-key (syntax-e #'e)))) + +(define-syntax-class (starts-with pfx) + (pattern i:id + #:when (string-prefix? + (symbol->string + (syntax-e #'i)) + pfx))) diff --git a/qi-lib/flow/compiler.rkt b/qi-lib/flow/compiler.rkt deleted file mode 100644 index 823452eb4..000000000 --- a/qi-lib/flow/compiler.rkt +++ /dev/null @@ -1,639 +0,0 @@ -#lang racket/base - -(provide (for-syntax compile-flow)) - -(require (for-syntax racket/base - syntax/parse - racket/match - (only-in racket/list - make-list) - "syntax.rkt" - "aux-syntax.rkt" - (only-in "../private/util.rkt" - report-syntax-error)) - (only-in "../macro.rkt" - qi-macro? - qi-macro-transformer) - "impl.rkt" - racket/function - (prefix-in fancy: fancy-app) - (only-in racket/list - make-list)) - -(begin-for-syntax - ;; note: this does not return compiled code but instead, - ;; syntax whose expansion compiles the code - (define (compile-flow stx) - #`(qi0->racket #,(optimize-flow stx))) - - (define (optimize-flow stx) - stx)) - -(define-syntax (qi0->racket stx) - (syntax-parse (cadr (syntax->list stx)) - ;; Check first whether the form is a macro. If it is, expand it. - ;; This is prioritized over other forms so that extensions may - ;; override built-in Qi forms. - [stx - #:with (~or* (m:id expr ...) m:id) #'stx - #:do [(define space-m ((make-interned-syntax-introducer 'qi) #'m))] - #:when (qi-macro? (syntax-local-value space-m (λ () #f))) - #:with expanded (syntax-local-apply-transformer - (qi-macro-transformer (syntax-local-value space-m)) - space-m - 'expression - #f - #'stx) - #'(qi0->racket expanded)] - - ;;; Special words - [((~datum one-of?) v:expr ...) - #'(compose - ->boolean - (curryr member (list v ...)))] - [((~datum all) onex:clause) - #`(give (curry andmap (qi0->racket onex)))] - [((~datum any) onex:clause) - #'(give (curry ormap (qi0->racket onex)))] - [((~datum none) onex:clause) - #'(qi0->racket (not (any onex)))] - [((~datum and) onex:clause ...) - #'(conjoin (qi0->racket onex) ...)] - [((~datum or) onex:clause ...) - #'(disjoin (qi0->racket onex) ...)] - [((~datum not) onex:clause) - #'(negate (qi0->racket onex))] - [((~datum gen) ex:expr ...) - #'(λ _ (values ex ...))] - [(~or* (~datum NOT) (~datum !)) - #'not] - [(~or* (~datum AND) (~datum &)) - #'all?] - [(~or* (~datum OR) (~datum ∥)) - #'any?] - [(~datum NOR) - #'(qi0->racket (~> OR NOT))] - [(~datum NAND) - #'(qi0->racket (~> AND NOT))] - [(~datum XOR) - #'parity-xor] - [(~datum XNOR) - #'(qi0->racket (~> XOR NOT))] - [e:and%-form (and%-parser #'e)] - [e:or%-form (or%-parser #'e)] - [(~datum any?) #'any?] - [(~datum all?) #'all?] - [(~datum none?) #'none?] - [(~or* (~datum ▽) (~datum collect)) - #'list] - [e:sep-form (sep-parser #'e)] - - ;;; Core routing elements - - [(~or* (~datum ⏚) (~datum ground)) - #'(qi0->racket (select))] - [((~or* (~datum ~>) (~datum thread)) onex:clause ...) - #`(compose . #,(reverse - (syntax->list - #'((qi0->racket onex) ...))))] - [e:right-threading-form (right-threading-parser #'e)] - [(~or* (~datum X) (~datum crossover)) - #'(qi0->racket (~> ▽ reverse △))] - [((~or* (~datum ==) (~datum relay)) onex:clause ...) - #'(relay (qi0->racket onex) ...)] - [((~or* (~datum ==*) (~datum relay*)) onex:clause ... rest-onex:clause) - (with-syntax ([len #`#,(length (syntax->list #'(onex ...)))]) - #'(qi0->racket (group len (== onex ...) rest-onex) ))] - [((~or* (~datum -<) (~datum tee)) onex:clause ...) - #'(λ args - (apply values - (append (values->list - (apply (qi0->racket onex) args)) - ...)))] - [e:select-form (select-parser #'e)] - [e:block-form (block-parser #'e)] - [((~datum bundle) (n:number ...) - selection-onex:clause - remainder-onex:clause) - #'(qi0->racket (-< (~> (select n ...) selection-onex) - (~> (block n ...) remainder-onex)))] - [e:group-form (group-parser #'e)] - - ;;; Conditionals - - [e:if-form (if-parser #'e)] - [((~datum when) condition:clause - consequent:clause) - #'(qi0->racket (if condition consequent ⏚))] - [((~datum unless) condition:clause - alternative:clause) - #'(qi0->racket (if condition ⏚ alternative))] - [e:switch-form (switch-parser #'e)] - [e:sieve-form (sieve-parser #'e)] - [e:partition-form (partition-parser #'e)] - [((~datum gate) onex:clause) - #'(qi0->racket (if onex _ ⏚))] - - ;;; Exceptions - - [e:try-form (try-parser #'e)] - - ;;; High level circuit elements - - ;; aliases for inputs - [e:input-alias (input-alias-parser #'e)] - - ;; common utilities - [(~datum count) - #'(λ args (length args))] - [(~datum live?) - #'(λ args (not (null? args)))] - [((~datum rectify) v:expr ...) - #'(qi0->racket (if live? _ (gen v ...)))] - - ;; high level routing - [e:fanout-form (fanout-parser #'e)] - [e:feedback-form (feedback-parser #'e)] - [(~datum inverter) - #'(qi0->racket (>< NOT))] - [e:side-effect-form (side-effect-parser #'e)] - - ;;; Higher-order flows - - ;; map, filter, and fold - [e:amp-form (amp-parser #'e)] - [e:pass-form (pass-parser #'e)] - [e:fold-left-form (fold-left-parser #'e)] - [e:fold-right-form (fold-right-parser #'e)] - - ;; looping - [e:loop-form (loop-parser #'e)] - [((~datum loop2) pred:clause mapex:clause combex:clause) - #'(letrec ([loop2 (qi0->racket (if pred - (~> (== (-< cdr - (~> car mapex)) _) - (group 1 _ combex) - loop2) - 2>))]) - loop2)] - - ;; towards universality - [(~datum apply) - #'call] - [e:clos-form (clos-parser #'e)] - - ;;; Miscellaneous - - ;; escape hatch for racket expressions or anything - ;; to be "passed through" - [((~datum esc) ex:expr) - #'ex] - - ;; backwards compat macro extensibility via Racket macros - [((~var ext-form (starts-with "qi:")) expr ...) - #'(ext-form expr ...)] - - ;; a literal is interpreted as a flow generating it - [e:literal (literal-parser #'e)] - - ;; Partial application with syntactically pre-supplied arguments - ;; in a blanket template - [e:blanket-template-form (blanket-template-form-parser #'e)] - - ;; Fine-grained template-based application - ;; This handles templates that indicate a specific number of template - ;; variables (i.e. expected arguments). The semantics of template-based - ;; application here is fulfilled by the fancy-app module. In order to use - ;; it, we simply use the #%app macro provided by fancy-app instead of the - ;; implicit one used for function application in racket/base. - ;; "prarg" = "pre-supplied argument" - [(prarg-pre ... (~datum _) prarg-post ...) - #'(fancy:#%app prarg-pre ... _ prarg-post ...)] - - ;; Pre-supplied arguments without a template - [(natex prarg ...+) - ;; we use currying instead of templates when a template hasn't - ;; explicitly been indicated since in such cases, we cannot - ;; always infer the appropriate arity for a template (e.g. it - ;; may change under composition within the form), while a - ;; curried function will accept any number of arguments - #:do [(define chirality (syntax-property this-syntax 'chirality))] - (if (and chirality (eq? chirality 'right)) - #'(curry natex prarg ...) - #'(curryr natex prarg ...))] - - ;; pass-through (identity flow) - [(~datum _) #'values] - - ;; literally indicated function identifier - [natex:expr #'natex])) - -;; 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-syntax-class disjux-clause ; "juxtaposed" disjoin - #:attributes (parsed) - (pattern - (~datum _) - #:with parsed #'false.) - (pattern - onex:clause - #:with parsed #'onex)) - - (define-syntax-class conjux-clause ; "juxtaposed" conjoin - #:attributes (parsed) - (pattern - (~datum _) - #:with parsed #'true.) - (pattern - onex:clause - #:with parsed #'onex)) - - (define (and%-parser stx) - (syntax-parse stx - [(_ onex:conjux-clause ...) - #'(qi0->racket (~> (== onex.parsed ...) - all?))])) - - (define (or%-parser stx) - (syntax-parse stx - [(_ onex:disjux-clause ...) - #'(qi0->racket (~> (== onex.parsed ...) - any?))])) - - (define (make-right-chiral stx) - (syntax-property stx 'chirality 'right)) - - (define-syntax-class right-threading-clause - (pattern - onex:clause - #:with chiral (make-right-chiral #'onex))) - - (define (right-threading-parser stx) - ;; right-threading is just normal threading - ;; but with a syntax property attached to - ;; the components indicating the chirality - (syntax-parse stx - [(_ onex:right-threading-clause ...) - #'(qi0->racket (~> onex.chiral ...))])) - - (define (sep-parser stx) - (syntax-parse stx - [_:id - #'(qi0->racket (if list? - (apply values _) - (raise-argument-error '△ - "list?" - _)))] - [(_ onex:clause) - #'(λ (v . vs) - ((qi0->racket (~> △ (>< (apply (qi0->racket onex) _ vs)))) v))])) - - (define (select-parser stx) - (syntax-parse stx - [(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'select - (syntax->datum #'(arg ...)) - "(select ...)")])) - - (define (block-parser stx) - (syntax-parse stx - [(_ n:number ...) - #'(qi0->racket (~> (esc (except-args n ...)) - △))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'block - (syntax->datum #'(arg ...)) - "(block ...)")])) - - (define (group-parser stx) - (syntax-parse stx - [(_ 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 selection-flo remainder-flo)) vs))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'group - (syntax->datum #'(arg ...)) - "(group racket> racket>)")])) - - (define (switch-parser stx) - (syntax-parse stx - [(_) #'(qi0->racket _)] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause)) - #'(qi0->racket consequent-gate)] - [(_ [(~datum else) alternative:clause]) - #'(qi0->racket alternative)] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [(~datum else) alternative:clause]) - #'(qi0->racket (~> consequent-gate alternative))] - [(_ [condition0:clause ((~datum =>) consequent0:clause ...)] - [condition:clause consequent:clause] - ...) - ;; we split the flow ahead of time to avoid evaluating - ;; the condition more than once - #'(qi0->racket (~> (-< condition0 _) - (if 1> - (~> consequent0 ...) - (group 1 ⏚ - (switch [condition consequent] - ...)))))] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [condition0:clause ((~datum =>) consequent0:clause ...)] - [condition:clause consequent:clause] - ...) - ;; both divert as well as => clauses. Here, the divert clause - ;; operates on the original inputs, not including the result - ;; of the condition flow. - ;; as before, we split the flow ahead of time to avoid evaluating - ;; the condition more than once - #'(qi0->racket (~> (-< (~> condition-gate condition0) _) - (if 1> - (~> (group 1 _ consequent-gate) - consequent0 ...) - (group 1 ⏚ - (switch (divert condition-gate consequent-gate) - [condition consequent] - ...)))))] - [(_ [condition0:clause consequent0:clause] - [condition:clause consequent:clause] - ...) - #'(qi0->racket (if condition0 - consequent0 - (switch [condition consequent] - ...)))] - [(_ ((~or* (~datum divert) (~datum %)) - condition-gate:clause - consequent-gate:clause) - [condition0:clause consequent0:clause] - [condition:clause consequent:clause] - ...) - #'(qi0->racket (if (~> condition-gate condition0) - (~> consequent-gate consequent0) - (switch (divert condition-gate consequent-gate) - [condition consequent] - ...)))])) - - (define (sieve-parser stx) - (syntax-parse stx - [(_ condition:clause - sonex:clause - ronex:clause) - #'(qi0->racket (-< (~> (pass condition) sonex) - (~> (pass (not condition)) ronex)))] - [_:id - #'(λ (condition sonex ronex . args) - (apply (qi0->racket (-< (~> (pass condition) sonex) - (~> (pass (not condition)) ronex))) - args))] - [(_ arg ...) ; error handling catch-all - (report-syntax-error 'sieve - (syntax->datum #'(arg ...)) - "(sieve racket> racket> racket>)")])) - - (define (partition-parser stx) - (syntax-parse stx - [(_:id) - #'(qi0->racket ground)] - [(_ [cond:clause body:clause]) - #'(qi0->racket (~> (pass cond) body))] - [(_ [cond:clause body:clause] ...+) - #:with c+bs #'(list (cons (qi0->racket cond) (qi0->racket body)) ...) - #'(qi0->racket (~>> (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)))] - [(_ arg ...) - (report-syntax-error 'try - (syntax->datum #'(arg ...)) - "(try [error-predicate-flo error-handler-flo] ...)")])) - - (define (input-alias-parser stx) - (syntax-parse stx - [(~datum 1>) - #'(qi0->racket (select 1))] - [(~datum 2>) - #'(qi0->racket (select 2))] - [(~datum 3>) - #'(qi0->racket (select 3))] - [(~datum 4>) - #'(qi0->racket (select 4))] - [(~datum 5>) - #'(qi0->racket (select 5))] - [(~datum 6>) - #'(qi0->racket (select 6))] - [(~datum 7>) - #'(qi0->racket (select 7))] - [(~datum 8>) - #'(qi0->racket (select 8))] - [(~datum 9>) - #'(qi0->racket (select 9))])) - - (define (if-parser stx) - (syntax-parse stx - [(_ consequent:clause - 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 - #`(λ 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) 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) - #'(feedback-times (qi0->racket onex) n (qi0->racket thenex))] - [(_ n:expr - ((~datum then) thenex:clause)) - #'(λ (f . args) - (apply (qi0->racket (feedback n (then thenex) 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 flo)) - args))])) - - (define (side-effect-parser stx) - (syntax-parse stx - [(_ sidex:clause onex:clause) - #'(qi0->racket (-< (~> sidex ⏚) - onex))] - [(_ sidex:clause) - #'(qi0->racket (-< (~> sidex ⏚) - _))])) - - (define (amp-parser stx) - (syntax-parse stx - [_:id - #'map-values] - [(_ onex:clause) - #'(curry map-values (qi0->racket onex))] - [(_ onex0:clause onex:clause ...) - (report-syntax-error - 'amp - (syntax->datum #'(onex0 onex ...)) - "(>< flo)" - "amp expects a single qi0->racket specification, but it received many.")])) - - (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 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 #t mapex _ ⏚))])) - - (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 (literal-parser stx) - (syntax-parse stx - [val:literal #'(qi0->racket (gen val))])) - - (define (blanket-template-form-parser stx) - (syntax-parse stx - ;; "prarg" = "pre-supplied argument" - [(natex prarg-pre ...+ (~datum __) prarg-post ...+) - #'(curry (curryr natex - prarg-post ...) - prarg-pre ...)] - [(natex prarg-pre ...+ (~datum __)) - #'(curry natex prarg-pre ...)] - [(natex (~datum __) prarg-post ...+) - #'(curryr natex prarg-post ...)] - [(natex (~datum __)) - #'natex]))) diff --git a/qi-lib/flow/core/compiler.rkt b/qi-lib/flow/core/compiler.rkt new file mode 100644 index 000000000..84adc4e49 --- /dev/null +++ b/qi-lib/flow/core/compiler.rkt @@ -0,0 +1,519 @@ +#lang racket/base + +(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" + "util.rkt" + "debug.rkt" + "normalize.rkt") + "deforest.rkt" + "impl.rkt" + (only-in racket/list make-list) + racket/function + racket/undefined + (prefix-in fancy: fancy-app) + racket/list) + +(begin-for-syntax + + ;; note: this does not return compiled code but instead, + ;; syntax whose expansion compiles the code + (define (compile-flow stx) + (process-bindings + #`(qi0->racket + #,(optimize-flow stx)))) + + (define (deforest-pass stx) + ;; Note: deforestation happens only for threading, + ;; and the normalize pass strips the threading form + ;; if it contains only one expression, so this would not be hit. + (find-and-map/qi deforest-rewrite + stx)) + + (define-qi-expansion-step (~deforest-pass stx) + (deforest-rewrite stx)) + + (define (normalize-pass stx) + (find-and-map/qi (fix normalize-rewrite) + stx)) + + (define-qi-expansion-step (~normalize-pass stx) + (normalize-pass stx)) + + (define (optimize-flow stx) + (~deforest-pass + (~normalize-pass stx)))) + +;; 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)] + [_ #f]) + stx)) + + (define (bound-identifiers stx) + (let ([ids null]) + (find-and-map/qi (syntax-parser + [((~datum as) x ...) + (set! ids + (append (attribute x) ids))] + [_ #f]) + stx) + ids)) + + ;; wrap stx with (let ([v undefined] ...) stx) for v ∈ ids + (define (wrap-with-scopes stx ids) + (with-syntax ([(v ...) ids]) + #`(let ([v undefined] ...) #,stx))) + + (define-qi-expansion-step (process-bindings stx) + ;; TODO: use syntax-parse and match ~> specifically. + ;; Since macros are expanded "outside in," presumably + ;; it will naturally wrap the outermost ~> + (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 (literal-parser stx) + (syntax-parse stx + [val:literal #'(qi0->racket (gen val))])) + + (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/debug.rkt b/qi-lib/flow/core/debug.rkt new file mode 100644 index 000000000..fd5b0e926 --- /dev/null +++ b/qi-lib/flow/core/debug.rkt @@ -0,0 +1,22 @@ +#lang racket/base + +(provide qi-expansion-step + define-qi-expansion-step) + +(require macro-debugger/emit) + +;; These macros emit expansion "events" that allow the macro +;; stepper to report stages in the expansion of an expression, +;; giving us visibility into this process for debugging purposes. +;; Note that this currently does not distinguish substeps +;; of a parent expansion step. +(define-syntax-rule (qi-expansion-step name stx0 stx1) + (let () + (emit-local-step stx0 stx1 #:id #'name) + stx1)) + +(define-syntax-rule (define-qi-expansion-step (name stx0) + body ...) + (define (name stx0) + (let ([stx1 (let () body ...)]) + (qi-expansion-step name stx0 stx1)))) diff --git a/qi-lib/flow/core/deforest.rkt b/qi-lib/flow/core/deforest.rkt new file mode 100644 index 000000000..26fdfb592 --- /dev/null +++ b/qi-lib/flow/core/deforest.rkt @@ -0,0 +1,403 @@ +#lang racket/base + +(provide (for-syntax deforest-rewrite)) + +(require (for-syntax racket/base + syntax/parse + racket/syntax-srcloc + "../extended/util.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))])])) + + ;; Used for producing the stream from particular + ;; expressions. Implicit producer is list->cstream-next and it is + ;; not created by using this class but rather explicitly used when + ;; no syntax class producer is matched. + (define-syntax-class fusable-stream-producer + #:attributes (next prepare contract name curry) + #:datum-literals (#%host-expression #%blanket-template #%fine-template esc __) + ;; Explicit range producers. + (pattern (~and (~or (esc (#%host-expression (~datum range))) + (~and (#%fine-template + ((#%host-expression (~datum range)) + arg ...)) + fine?) + (~and (#%blanket-template + ((#%host-expression (~datum range)) + (#%host-expression pre-arg) ... + __ + (#%host-expression post-arg) ...)) + blanket?)) + form-stx) + #:attr next #'range->cstream-next + #:attr prepare #'range->cstream-prepare + #:attr contract #'(->* (real?) (real? real?) any) + #:attr name #'range + #:attr curry (make-producer-curry 1 3 + blanket? pre-arg post-arg + fine? arg + form-stx)) + + ;; The implicit stream producer from plain list. + (pattern (~literal list->cstream) + #:attr next #'list->cstream-next + #:attr prepare #'list->cstream-prepare + #:attr contract #'(-> list? any) + #:attr name #''list->cstream + #:attr curry (λ (ctx name) #'(λ (v) v)))) + + ;; Matches any stream transformer that can be in the head position + ;; of the fused sequence even when there is no explicit + ;; producer. Procedures accepting variable number of arguments like + ;; `map` cannot be in this class. + (define-syntax-class fusable-stream-transformer0 + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + + ;; All implemented stream transformers - within the stream, only + ;; single value is being passed and therefore procedures like `map` + ;; can (and should) be matched. + (define-syntax-class fusable-stream-transformer + #:attributes (f next) + #:datum-literals (#%host-expression #%blanket-template __ _ #%fine-template) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum map)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum map)) + (#%host-expression f) + _))) + #:attr next #'map-cstream-next) + + (pattern (~or (#%blanket-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + __)) + (#%fine-template + ((#%host-expression (~datum filter)) + (#%host-expression f) + _))) + #:attr next #'filter-cstream-next)) + + ;; Terminates the fused sequence (consumes the stream) and produces + ;; an actual result value. + (define-syntax-class fusable-stream-consumer + #:attributes (end) + #:datum-literals (#%host-expression #%blanket-template _ __ #%fine-template esc) + (pattern (~or (#%blanket-template + ((#%host-expression (~datum foldr)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~datum foldr)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldr-cstream-next op init)) + + (pattern (~or (#%blanket-template + ((#%host-expression (~datum foldl)) + (#%host-expression op) + (#%host-expression init) + __)) + (#%fine-template + ((#%host-expression (~datum foldl)) + (#%host-expression op) + (#%host-expression init) + _))) + #:attr end #'(foldl-cstream-next op init)) + + (pattern (~or (esc (#%host-expression (~datum car))) + (#%fine-template + ((#%host-expression (~datum car)) + _)) + (#%blanket-template + ((#%host-expression (~datum car)) + __))) + #:attr end #'(car-cstream-next)) + + (pattern (~literal cstream->list) + #:attr end #'(cstream-next->list))) + + ;; Used only in deforest-rewrite to properly recognize the end of + ;; fusable sequence. + (define-syntax-class non-fusable + (pattern (~not (~or _:fusable-stream-transformer + _:fusable-stream-producer + _:fusable-stream-consumer)))) + + ;; Generates a syntax for the fused operation for given + ;; sequence. The syntax list must already be in the following form: + ;; (producer transformer ... consumer) + (define (generate-fused-operation ops ctx) + (syntax-parse (reverse ops) + [(c:fusable-stream-consumer + t:fusable-stream-transformer ... + p:fusable-stream-producer) + ;; A static runtime contract is placed at the beginning of the + ;; fused sequence. And runtime checks for consumers are in + ;; their respective implementation procedure. + #`(esc + (#,((attribute p.curry) ctx (attribute p.name)) + (contract p.contract + (p.prepare + (#,@#'c.end + (inline-compose1 [t.next t.f] ... + p.next) + '#,(prettify-flow-syntax ctx) + #,(syntax-srcloc ctx))) + p.name + '#,(prettify-flow-syntax ctx) + #f + #,(syntax-srcloc ctx))))])) + + ;; Performs one step of deforestation rewrite. Should be used as + ;; many times as needed - until it returns the source syntax + ;; unchanged. + (define (deforest-rewrite stx) + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; There can be zero transformers here: + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fusable-stream-transformer0 + t:fusable-stream-transformer ... + c:fusable-stream-consumer + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fusable-stream-producer + ;; Must be 1 or more transformers here: + t:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fusable-stream-transformer0 + f:fusable-stream-transformer ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [_ this-syntax]))) + +(begin-encourage-inline + + ;; 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)))))) + + ;; 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 (car-cstream-next next ctx src) + (λ (state) + (let loop ([state state]) + ((next (λ () ((contract (-> pair? any) + (λ (v) v) + 'car-cstream-next ctx #f + src) '())) + (λ (state) (loop state)) + (λ (value state) + value)) + state)))) + + ) diff --git a/qi-lib/flow/impl.rkt b/qi-lib/flow/core/impl.rkt similarity index 92% rename from qi-lib/flow/impl.rkt rename to qi-lib/flow/core/impl.rkt index 679b64649..8cfc523a6 100644 --- a/qi-lib/flow/impl.rkt +++ b/qi-lib/flow/core/impl.rkt @@ -1,9 +1,6 @@ #lang racket/base (provide give - ->boolean - true. - false. any? all? none? @@ -17,27 +14,32 @@ except-args call repeat-values - power foldl-values foldr-values values->list feedback-times - feedback-while) + feedback-while + kw-helper) (require racket/match (only-in racket/function - thunk - thunk* - negate) + negate + thunk) racket/bool racket/list racket/format syntax/parse/define - (for-syntax racket/base)) + (for-syntax racket/base) + racket/performance-hint) (define-syntax-parse-rule (values->list body:expr ...+) (call-with-values (λ () body ...) list)) +(define (kw-helper f args) + (make-keyword-procedure + (λ (kws kws-vs . pos) + (keyword-apply f kws kws-vs (append args pos))))) + ;; we use a lambda to capture the arguments at runtime ;; since they aren't available at compile time (define (loom-compose f g [n #f]) @@ -120,6 +122,8 @@ [(cons v vs) (append (values->list (f v)) (~map f vs))])) +;; Note: can probably get rid of implicit packing to args, and the +;; final apply values (define (map-values f . args) (apply values (~map f args))) @@ -167,11 +171,8 @@ (call-with-values (λ () (apply b args)) list))) (apply values (apply append results))) -(define (->boolean v) (and v #t)) -(define true. (thunk* #t)) -(define false. (thunk* #f)) +(define exists ormap) -(define exists ormap) (define for-all andmap) (define (zip-with op . seqs) @@ -210,9 +211,6 @@ (define (repeat-values n . vs) (apply values (apply append (make-list n vs)))) -(define (power n f) - (apply compose (make-list n f))) - (define (fold-values f init vs) (let loop ([vs vs] [accs (values->list (init))]) @@ -227,7 +225,11 @@ (fold-values f init (reverse vs))) (define (feedback-times f n then-f) - (compose then-f (power n f))) + (λ args + (if (= n 0) + (apply then-f args) + (call-with-values (thunk (apply f args)) + (feedback-times f (sub1 n) then-f))))) (define (feedback-while f condition then-f) (λ args diff --git a/qi-lib/flow/core/normalize.rkt b/qi-lib/flow/core/normalize.rkt new file mode 100644 index 000000000..3d92bc5a1 --- /dev/null +++ b/qi-lib/flow/core/normalize.rkt @@ -0,0 +1,72 @@ +#lang racket/base + +(provide normalize-rewrite) + +(require syntax/parse + (for-template racket/base)) + +;; 0. "Qi-normal form" +(define (normalize-rewrite stx) + (syntax-parse stx + #:datum-literals (#%host-expression + #%blanket-template + #%fine-template + esc + gen + thread + pass + if + amp + relay + tee + sep + collect + __) + + ;; "deforestation" for values + ;; (~> (pass f) (>< g)) → (>< (if f g ⏚)) + [(thread _0 ... (pass f) (amp g) _1 ...) + #'(thread _0 ... (amp (if f g ground)) _1 ...)] + ;; merge pass filters in sequence + [(thread _0 ... (pass f) (pass g) _1 ...) + #'(thread _0 ... (pass (and f g)) _1 ...)] + ;; collapse deterministic conditionals + [(if (~datum #t) f g) #'f] + [(if (~datum #f) f g) #'g] + ;; trivial threading form + [(thread f) + #'f] + ;; associative laws for ~> + [(thread _0 ... (thread f ...) _1 ...) ; note: greedy matching + #'(thread _0 ... f ... _1 ...)] + ;; left and right identity for ~> + [(thread _0 ... (~datum _) _1 ...) + #'(thread _0 ... _1 ...)] + ;; composition of identity flows is the identity flow + [(thread (~datum _) ...) + #'_] + ;; amp and identity + [(amp (~datum _)) + #'_] + ;; trivial tee junction + [(tee f) + #'f] + ;; merge adjacent gens in a tee junction + [(tee _0 ... (gen a ...) (gen b ...) _1 ...) + #'(tee _0 ... (gen a ... b ...) _1 ...)] + ;; dead gen elimination + [(thread _0 ... (gen a ...) (gen b ...) _1 ...) + #'(thread _0 ... (gen b ...) _1 ...)] + ;; prism identities + ;; Note: (~> ... △ ▽ ...) can't be rewritten to `values` since that's + ;; only valid if the input is in fact a list, and is an error otherwise, + ;; and we can only know this at runtime. + [(thread _0 ... collect sep _1 ...) + #'(thread _0 ... _1 ...)] + ;; collapse `values` inside a threading form + [(thread _0 ... (esc (#%host-expression (~literal values))) _1 ...) + #'(thread _0 ... _1 ...)] + [(#%blanket-template (hex __)) + #'hex] + ;; return syntax unchanged if there are no applicable normalizations + [_ stx])) diff --git a/qi-lib/flow/syntax.rkt b/qi-lib/flow/core/syntax.rkt similarity index 73% rename from qi-lib/flow/syntax.rkt rename to qi-lib/flow/core/syntax.rkt index d8edb92d9..2cf8a0ca8 100644 --- a/qi-lib/flow/syntax.rkt +++ b/qi-lib/flow/core/syntax.rkt @@ -4,24 +4,19 @@ select-form block-form group-form - switch-form sieve-form partition-form try-form - fanout-form feedback-form - side-effect-form amp-form - input-alias + relay-form + tee-form + fanout-form if-form pass-form fold-left-form fold-right-form loop-form - blanket-template-form - and%-form - or%-form - right-threading-form clos-form) (require syntax/parse) @@ -59,10 +54,6 @@ See comments in flow.rkt for more details. (pattern ((~datum group) arg ...))) -(define-syntax-class switch-form - (pattern - ((~datum switch) arg ...))) - (define-syntax-class sieve-form (pattern (~datum sieve)) @@ -77,18 +68,6 @@ See comments in flow.rkt for more details. (pattern ((~datum try) arg ...))) -(define-syntax-class input-alias - (pattern - (~or* (~datum 1>) - (~datum 2>) - (~datum 3>) - (~datum 4>) - (~datum 5>) - (~datum 6>) - (~datum 7>) - (~datum 8>) - (~datum 9>)))) - (define-syntax-class if-form (pattern ((~datum if) arg ...))) @@ -105,16 +84,24 @@ See comments in flow.rkt for more details. (pattern ((~datum feedback) arg ...))) -(define-syntax-class side-effect-form - (pattern - ((~or* (~datum ε) (~datum effect)) arg ...))) - (define-syntax-class amp-form (pattern (~or* (~datum ><) (~datum amp))) (pattern ((~or* (~datum ><) (~datum amp)) arg ...))) +(define-syntax-class relay-form + (pattern + (~or* (~datum ==) (~datum relay))) + (pattern + ((~or* (~datum ==) (~datum relay)) arg ...))) + +(define-syntax-class tee-form + (pattern + (~or* (~datum -<) (~datum tee))) + (pattern + ((~or* (~datum -<) (~datum tee)) arg ...))) + (define-syntax-class pass-form (pattern (~datum pass)) @@ -135,24 +122,9 @@ See comments in flow.rkt for more details. (define-syntax-class loop-form (pattern - ((~datum loop) arg ...))) - -(define-syntax-class blanket-template-form - ;; "prarg" = "pre-supplied argument" - (pattern - (natex prarg-pre ... (~datum __) prarg-post ...))) - -(define-syntax-class and%-form + (~datum loop)) (pattern - ((~datum and%) arg ...))) - -(define-syntax-class or%-form - (pattern - ((~datum or%) arg ...))) - -(define-syntax-class right-threading-form - (pattern - ((~or* (~datum ~>>) (~datum thread-right)) arg ...))) + ((~datum loop) arg ...))) (define-syntax-class clos-form (pattern diff --git a/qi-lib/flow/core/util.rkt b/qi-lib/flow/core/util.rkt new file mode 100644 index 000000000..92ee671d2 --- /dev/null +++ b/qi-lib/flow/core/util.rkt @@ -0,0 +1,49 @@ +#lang racket/base + +(provide find-and-map/qi + fix) + +(require racket/match + syntax/parse) + +;; Walk the syntax tree in a "top down" manner, i.e. from the root down +;; to the leaves, applying a transformation to each node. The +;; transforming function is expected to either return the transformed +;; syntax or false. The traversal terminates in the former case (i.e. it +;; does not traverse the transformed expression to look for further +;; matches), and continues in the latter case. +(define (find-and-map f stx) + ;; f : syntax? -> (or/c syntax? #f) + (match stx + [(? syntax?) (let ([stx^ (f stx)]) + (or stx^ (datum->syntax stx + (find-and-map f (syntax-e stx)) + stx + stx)))] + [(cons a d) (cons (find-and-map f a) + (find-and-map f d))] + [_ stx])) + +;; A thin wrapper around find-and-map that does not traverse subexpressions +;; that are tagged as host language (rather than Qi) expressions +(define (find-and-map/qi f stx) + ;; #%host-expression is a Racket macro defined by syntax-spec + ;; that resumes expansion of its sub-expression with an + ;; expander environment containing the original surface bindings + (find-and-map (syntax-parser [((~datum #%host-expression) e:expr) this-syntax] + [_ (f this-syntax)]) + stx)) + +;; Applies f repeatedly to the init-val terminating the loop if the +;; result of f is #f or the new syntax object is eq? to the previous +;; (possibly initial) one. +;; +;; Caveats: +;; * the syntax object is not inspected, only eq? is used +;; * comparison is performed only between consecutive steps (does not handle cyclic occurences) +(define ((fix f) init-val) + (let ([new-val (f init-val)]) + (if (or (not new-val) + (eq? new-val init-val)) + init-val + ((fix f) new-val)))) diff --git a/qi-lib/flow/expander.rkt b/qi-lib/flow/expander.rkt deleted file mode 100644 index e6a2d7966..000000000 --- a/qi-lib/flow/expander.rkt +++ /dev/null @@ -1,6 +0,0 @@ -#lang racket/base - -(provide expand-flow) - -(define (expand-flow stx) - stx) diff --git a/qi-lib/flow/extended/expander.rkt b/qi-lib/flow/extended/expander.rkt new file mode 100644 index 000000000..fe6b01f2a --- /dev/null +++ b/qi-lib/flow/extended/expander.rkt @@ -0,0 +1,219 @@ +#lang racket/base + +(provide (for-syntax qi-macro + closed-floe) + (for-space qi + (all-defined-out) + (rename-out [ground ⏚] + [thread ~>] + [relay ==] + [tee -<] + [amp ><] + [sep △] + [collect ▽]))) + +(require syntax-spec-v1 + (for-syntax "../aux-syntax.rkt" + "syntax.rkt" + racket/base + syntax/parse + "../../private/util.rkt")) + +(syntax-spec + + ;; Declare a compile-time datatype by which qi macros may + ;; be identified. + (extension-class qi-macro + #:binding-space qi) + + (nonterminal closed-floe + #:description "a flow expression" + + f:floe + #:binding (nest-one f [])) + + (nonterminal/nesting floe (nested) + #:description "a flow expression" + #:allow-extension qi-macro + #:binding-space qi + + (as v:racket-var ...+) + #:binding {(bind v) nested} + + (thread f:floe ...) + #:binding (nest f nested) + + (tee f:floe ...) + #:binding (nest f nested) + tee + ;; Note: `#:binding nested` is the implicit binding rule here + + (relay f:floe ...) + #:binding (nest f nested) + relay + + ;; [f nested] is the implicit binding rule + ;; anything not mentioned (e.g. nested) is treated as a + ;; subexpression that's not in any scope + ;; Note: once a nonterminal is chosen, it doesn't backtrack + ;; to consider alternatives + + (gen e:racket-expr ...) + ;; Ad hoc expansion rule to allow _ to be used in application + ;; position in a template. + ;; Without it, (_ v ...) would be treated as an error since + ;; _ is an unrelated form of the core language having different + ;; semantics. The expander would assume it is a syntax error + ;; from that perspective. + (~> ((~literal _) arg ...) #'(#%fine-template (_ arg ...))) + _ + ground + amp + (amp f:closed-floe) + (~>/form (amp f0:clause f:clause ...) + ;; potentially pull out as a phase 1 function + ;; just a stopgap until better error messages + (report-syntax-error this-syntax + "(>< flo)" + "amp expects a single flow specification, but it received many.")) + pass + (pass f:closed-floe) + sep + (sep f:closed-floe) + collect + NOT + XOR + (and f:closed-floe ...) + (or f:closed-floe ...) + (not f:closed-floe) + (all f:closed-floe) + (any f:closed-floe) + (select n:number ...) + (~>/form (select arg ...) + (report-syntax-error this-syntax + "(select ...)")) + (block n:number ...) + (~>/form (block arg ...) + (report-syntax-error this-syntax + "(block ...)")) + (fanout n:racket-expr) + fanout + (group n:racket-expr e1:closed-floe e2:closed-floe) + group + (~>/form (group arg ...) + (report-syntax-error this-syntax + "(group )")) + (if consequent:closed-floe + alternative:closed-floe) + (if condition:floe + consequent:closed-floe + alternative:closed-floe) + #:binding (nest-one condition [consequent alternative]) + (sieve condition:closed-floe + sonex:closed-floe + ronex:closed-floe) + sieve + (~>/form (sieve arg ...) + (report-syntax-error this-syntax + "(sieve )")) + (partition) + (partition [cond:closed-floe body:closed-floe] ...+) + (try flo:closed-floe + [error-condition-flo:closed-floe error-handler-flo:closed-floe] + ...+) + (~>/form (try arg ...) + (report-syntax-error this-syntax + "(try [error-predicate-flo error-handler-flo] ...)")) + >> + (>> fn:closed-floe init:closed-floe) + (>> fn:closed-floe) + << + (<< fn:closed-floe init:closed-floe) + (<< fn:closed-floe) + (feedback ((~datum while) tilex:closed-floe) + ((~datum then) thenex:closed-floe) + onex:closed-floe) + (feedback ((~datum while) tilex:closed-floe) + ((~datum then) thenex:closed-floe)) + (feedback ((~datum while) tilex:closed-floe) onex:closed-floe) + (feedback ((~datum while) tilex:closed-floe)) + (feedback n:racket-expr + ((~datum then) thenex:closed-floe) + onex:closed-floe) + (feedback n:racket-expr + ((~datum then) thenex:closed-floe)) + (feedback n:racket-expr onex:closed-floe) + (feedback onex:closed-floe) + feedback + (loop pred:closed-floe mapex:closed-floe combex:closed-floe retex:closed-floe) + (loop pred:closed-floe mapex:closed-floe combex:closed-floe) + (loop pred:closed-floe mapex:closed-floe) + (loop mapex:closed-floe) + loop + (loop2 pred:closed-floe mapex:closed-floe combex:closed-floe) + appleye + (~> (~literal apply) #'appleye) + clos + (clos onex:closed-floe) + (esc ex:racket-expr) + + ;; backwards compat macro extensibility via Racket macros + (~> ((~var ext-form (starts-with "qi:")) expr ...) + #'(esc (ext-form expr ...))) + ;; a literal is interpreted as a flow generating it + (~> val:literal + #'(gen val)) + ;; Certain rules of the language aren't determined by the "head" + ;; position, so naively, these can't be core forms. In order to + ;; treat them as core forms, we tag them at the expander level + ;; by wrapping them with #%-prefixed forms, similar to Racket's + ;; approach to a similiar case - "interposition points." These + ;; new forms can then be treated as core forms in the compiler. + ;; + ;; Be careful with these tagging rules, though -- if they are too + ;; lax in their match criteria they may produce infinite code + ;; unless their output is matched prior to reaching the tagging rule. + ;; So core forms expected to be produced by these tagging rules + ;; should generally occur before the tagging rule + (#%blanket-template (arg:arg-stx ...)) + (~> f:blanket-template-form + #'(#%blanket-template f)) + + (#%fine-template (arg:arg-stx ...)) + (~> f:fine-template-form + #'(#%fine-template f)) + + ;; When there is a partial application where a template hasn't + ;; explicitly been indicated, we rewrite it to an equivalent use + ;; of a blanket template. + ;; We use a blanket rather than fine template since in such cases, + ;; we cannot always infer the appropriate arity for a template + ;; (e.g. it may change under composition within the form), while a + ;; blanket template will accept any number of arguments + (~> f:partial-application-form + #:do [(define chirality (syntax-property this-syntax 'chirality))] + (if (and chirality (eq? chirality 'right)) + (datum->syntax this-syntax + (append (syntax->list this-syntax) + (list '__))) + (datum->syntax this-syntax + (let ([stx-list (syntax->list this-syntax)]) + (cons (car stx-list) + (cons '__ (cdr stx-list))))))) + ;; literally indicated function identifier + ;; + ;; functions defined in the Qi binding space take precedence over + ;; Racket definitions here, for cases of "library functions" like + ;; `count` that we don't include in the core language but which + ;; we'd like to treat as part of the language rather than as + ;; functions which could be shadowed. + (~> f:id + #:with spaced-f ((make-interned-syntax-introducer 'qi) #'f) + #'(esc spaced-f))) + + (nonterminal arg-stx + (~datum _) + (~datum __) + k:keyword + + e:racket-expr)) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt new file mode 100644 index 000000000..a1080b8fb --- /dev/null +++ b/qi-lib/flow/extended/forms.rkt @@ -0,0 +1,192 @@ +#lang racket/base + +(provide (for-space qi + (all-defined-out) + ;; defining and using a `define-qi-alias` form + ;; would be a more direct way to do this + (rename-out [thread-right ~>>] + [crossover X] + [relay* ==*] + [effect ε]))) + +(require (for-syntax racket/base + "syntax.rkt" + "../aux-syntax.rkt") + syntax/parse/define + "expander.rkt" + "../../macro.rkt" + "../space.rkt" + "impl.rkt") + +;;; Predicates + +(define-for-qi all? ~all?) + +(define-for-qi AND ~all?) + +(define-for-qi OR ~any?) + +(define-for-qi any? ~any?) + +(define-for-qi none? ~none?) + +(define-qi-syntax-rule (one-of? v:expr ...) + (~> (member (list v ...)) ->boolean)) + +(define-qi-syntax-rule (none onex:clause) + (not (any onex))) + +(define-qi-syntax-parser NOR + [_:id #'(~> OR NOT)]) + +(define-qi-syntax-parser NAND + [_:id #'(~> AND NOT)]) + +(define-qi-syntax-parser XNOR + [_:id #'(~> XOR NOT)]) + +(define-qi-syntax-rule (and% onex:conjux-clause ...) + (~> (== onex.parsed ...) + all?)) + +(define-qi-syntax-rule (or% onex:disjux-clause ...) + (~> (== onex.parsed ...) + any?)) + +;;; Routing + +;; Right-threading is just normal threading but with a syntax +;; property attached to the components indicating the chirality +(define-qi-syntax-rule (thread-right onex:right-threading-clause ...) + (~> onex.chiral ...)) + +(define-qi-syntax-parser crossover + [_:id #'(~> ▽ reverse △)]) + +(define-qi-syntax-parser relay* + [(_ onex:clause ... rest-onex:clause) + #:with len #`#,(length (syntax->list #'(onex ...))) + #'(group len (== onex ...) rest-onex)]) + +(define-qi-syntax-rule (bundle (n:number ...) + selection-onex:clause + remainder-onex:clause) + (-< (~> (select n ...) selection-onex) + (~> (block n ...) remainder-onex))) + +;;; Conditionals + +(define-qi-syntax-rule (when condition:clause + consequent:clause) + (if condition consequent ⏚)) + +(define-qi-syntax-rule (unless condition:clause + alternative:clause) + (if condition ⏚ alternative)) + +(define-qi-syntax-parser switch + [(_) #'_] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause)) + #'consequent-gate] + [(_ [(~datum else) alternative:clause]) + #'alternative] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [(~datum else) alternative:clause]) + #'(~> consequent-gate alternative)] + [(_ [condition0:clause ((~datum =>) consequent0:clause ...)] + [condition:clause consequent:clause] + ...) + ;; we split the flow ahead of time to avoid evaluating + ;; the condition more than once + #'(~> (-< condition0 _) + (if 1> + (~> consequent0 ...) + (group 1 ⏚ + (switch [condition consequent] + ...))))] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [condition0:clause ((~datum =>) consequent0:clause ...)] + [condition:clause consequent:clause] + ...) + ;; both divert as well as => clauses. Here, the divert clause + ;; operates on the original inputs, not including the result + ;; of the condition flow. + ;; as before, we split the flow ahead of time to avoid evaluating + ;; the condition more than once + #'(~> (-< (~> condition-gate condition0) _) + (if 1> + (~> (group 1 _ consequent-gate) + consequent0 ...) + (group 1 ⏚ + (switch (divert condition-gate consequent-gate) + [condition consequent] + ...))))] + [(_ [condition0:clause consequent0:clause] + [condition:clause consequent:clause] + ...) + #'(if condition0 + consequent0 + (switch [condition consequent] + ...))] + [(_ ((~or* (~datum divert) (~datum %)) + condition-gate:clause + consequent-gate:clause) + [condition0:clause consequent0:clause] + [condition:clause consequent:clause] + ...) + #'(if (~> condition-gate condition0) + (~> consequent-gate consequent0) + (switch (divert condition-gate consequent-gate) + [condition consequent] + ...))]) + +(define-qi-syntax-rule (gate onex:clause) + (if onex _ ⏚)) + +;;; Common utilities + +(define-for-qi count ~count) + +(define-for-qi live? ~live?) + +(define-qi-syntax-rule (rectify v:expr ...) + (if live? _ (gen v ...))) + +;;; High level circuit elements + +;; aliases for inputs +(define-qi-syntax-parser 1> + [_:id #'(select 1)]) +(define-qi-syntax-parser 2> + [_:id #'(select 2)]) +(define-qi-syntax-parser 3> + [_:id #'(select 3)]) +(define-qi-syntax-parser 4> + [_:id #'(select 4)]) +(define-qi-syntax-parser 5> + [_:id #'(select 5)]) +(define-qi-syntax-parser 6> + [_:id #'(select 6)]) +(define-qi-syntax-parser 7> + [_:id #'(select 7)]) +(define-qi-syntax-parser 8> + [_:id #'(select 8)]) +(define-qi-syntax-parser 9> + [_:id #'(select 9)]) + +(define-qi-syntax-parser inverter + [_:id #'(>< NOT)]) + +(define-qi-syntax-parser effect + [(_ sidex:clause onex:clause) + #'(-< (~> sidex ⏚) + onex)] + [(_ sidex:clause) + #'(-< (~> sidex ⏚) + _)]) diff --git a/qi-lib/flow/extended/impl.rkt b/qi-lib/flow/extended/impl.rkt new file mode 100644 index 000000000..8ac1328e7 --- /dev/null +++ b/qi-lib/flow/extended/impl.rkt @@ -0,0 +1,41 @@ +#lang racket/base + +(require (only-in racket/function + const)) + +(provide ->boolean + true. + false. + ~all? + ~any? + ~none? + ~count + ~live?) + +(define (->boolean v) (and v #t)) + +(define true. + (procedure-rename (const #t) + 'true.)) + +(define false. + (procedure-rename (const #f) + 'false.)) + +(define (~all? . args) + (for/and ([v (in-list args)]) v)) + +(define (~any?-helper args) + (for/or ([v (in-list args)]) v)) + +(define (~any? . args) + (~any?-helper args)) + +(define (~none? . args) + (not (~any?-helper args))) + +(define (~count . args) + (length args)) + +(define (~live? . args) + (not (null? args))) diff --git a/qi-lib/flow/extended/syntax.rkt b/qi-lib/flow/extended/syntax.rkt new file mode 100644 index 000000000..1691380e9 --- /dev/null +++ b/qi-lib/flow/extended/syntax.rkt @@ -0,0 +1,68 @@ +#lang racket/base + +(provide conjux-clause + disjux-clause + right-threading-clause + blanket-template-form + fine-template-form + partial-application-form + any-stx + ;; only provided for use in unit tests + make-right-chiral) + +(require syntax/parse + "../aux-syntax.rkt" + (for-template "impl.rkt")) + +(define-syntax-class conjux-clause ; "juxtaposed" conjoin + #:attributes (parsed) + (pattern + (~datum _) + #:with parsed #'true.) + (pattern + onex:clause + #:with parsed #'onex)) + +(define-syntax-class disjux-clause ; "juxtaposed" disjoin + #:attributes (parsed) + (pattern + (~datum _) + #:with parsed #'false.) + (pattern + onex:clause + #:with parsed #'onex)) + +(define-syntax-class pre-supplied-argument + (pattern + (~not + (~or (~datum _) + (~datum __))))) + +(define (make-right-chiral stx) + (syntax-property stx 'chirality 'right)) + +(define-syntax-class right-threading-clause + (pattern + onex:clause + #:with chiral (make-right-chiral #'onex))) + +;; Note these are used in the expander instead of in the compiler. +;; That's why they don't need the tag (i.e. they don't look for +;; #%blanket-template, #%fine-template, or #%partial-application) +(define-syntax-class blanket-template-form + ;; "prarg" = "pre-supplied argument" + (pattern + (natex prarg-pre ... (~datum __) prarg-post ...))) + +(define-syntax-class fine-template-form + ;; "prarg" = "pre-supplied argument" + (pattern + (prarg-pre ... (~datum _) prarg-post ...))) + +(define-syntax-class partial-application-form + ;; "prarg" = "pre-supplied argument" + (pattern + (natex prarg:pre-supplied-argument ...+))) + +(define-syntax-class any-stx + (pattern _)) diff --git a/qi-lib/flow/extended/util.rkt b/qi-lib/flow/extended/util.rkt new file mode 100644 index 000000000..94cd46a08 --- /dev/null +++ b/qi-lib/flow/extended/util.rkt @@ -0,0 +1,121 @@ +#lang racket/base + +(provide prettify-flow-syntax) + +(require syntax/parse) + +;; Partially reconstructs original flow expressions. The chirality +;; is lost and the form is already normalized at this point though! +(define (prettify-flow-syntax stx) + (syntax-parse stx + #:datum-literals (#%host-expression + esc + #%blanket-template + #%fine-template + thread + amp + tee + relay + gen + pass + sep + and + or + not + all + any + fanout + group + if + sieve + partition + try + >> + << + feedback + loop + loop2 + clos) + [(thread + expr ...) + #`(~> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [((~or #%blanket-template #%fine-template) + (expr ...)) + (map prettify-flow-syntax (syntax->list #'(expr ...)))] + [(#%host-expression expr) #'expr] + [(amp + expr ...) + #`(>< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(tee + expr ...) + #`(-< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(relay + expr ...) + #`(== #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(gen + expr ...) + #`(gen #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(pass + expr ...) + #`(pass #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(sep + expr ...) + #`(sep #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(and + expr ...) + #`(and #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(or + expr ...) + #`(or #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(not + expr ...) + #`(not #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(all + expr ...) + #`(all #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(any + expr ...) + #`(any #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(fanout + expr ...) + #`(fanout #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(group + expr ...) + #`(group #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(if + expr ...) + #`(if #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(sieve + expr ...) + #`(sieve #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(partition + [e1 e2] ...) + #:with e1-prettified (map prettify-flow-syntax (attribute e1)) + #:with e2-prettified (map prettify-flow-syntax (attribute e2)) + #`(partition [e1-prettified e2-prettified])] + [(try expr + [e1 e2] ...) + #:with expr-prettified (prettify-flow-syntax #'expr) + #:with e1-prettified (map prettify-flow-syntax (attribute e1)) + #:with e2-prettified (map prettify-flow-syntax (attribute e2)) + #`(try expr-prettified [e1-prettified e2-prettified])] + [(>> + expr ...) + #`(>> #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(<< + expr ...) + #`(<< #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(feedback + expr ...) + #`(feedback #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(loop + expr ...) + #`(loop #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(loop2 + expr ...) + #`(loop2 #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(clos + expr ...) + #`(clos #,@(map prettify-flow-syntax (syntax->list #'(expr ...))))] + [(esc expr) (prettify-flow-syntax #'expr)] + [expr #'expr])) diff --git a/qi-lib/flow/space.rkt b/qi-lib/flow/space.rkt new file mode 100644 index 000000000..17b42be48 --- /dev/null +++ b/qi-lib/flow/space.rkt @@ -0,0 +1,26 @@ +#lang racket/base + +(provide define-for-qi) + +(require syntax/parse/define + (for-syntax racket/base + syntax/parse/lib/function-header)) + +;; Define variables in the qi binding space. +;; This allows us to define functions in the qi space which, when used in +;; qi contexts, would not be shadowed by bindings at the use site. This +;; gives us some of the benefits of core linguistic forms while also not +;; actually inflating the size of the core language nor incurring the +;; performance penalty it might if it were implemented as a macro +;; compiling to the core language. +;; See "A loophole in Qi space": +;; https://github.com/drym-org/qi/wiki/Qi-Compiler-Sync-Jan-26-2023 +(define-syntax-parser define-for-qi + [(_ name:id expr:expr) + #:with spaced-name ((make-interned-syntax-introducer 'qi) #'name) + #'(define spaced-name expr)] + [(_ (name:id . args:formals) + expr:expr ...) + #'(define-for-qi name + (lambda args + expr ...))]) diff --git a/qi-lib/info.rkt b/qi-lib/info.rkt index aec2a73a7..a8b349bd6 100644 --- a/qi-lib/info.rkt +++ b/qi-lib/info.rkt @@ -3,7 +3,9 @@ (define version "3.0") (define collection "qi") (define deps '("base" - ("fancy-app" #:version "1.1"))) + ("fancy-app" #:version "1.1") + "syntax-spec-v1" + "macro-debugger")) (define build-deps '()) (define clean '("compiled" "private/compiled")) (define pkg-authors '(countvajhula)) diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index df1a70032..fbb96a056 100644 --- a/qi-lib/macro.rkt +++ b/qi-lib/macro.rkt @@ -4,21 +4,19 @@ define-qi-syntax-rule define-qi-syntax-parser define-qi-foreign-syntaxes - (for-syntax qi-macro? - qi-macro-transformer - qi-macro)) + (for-syntax qi-macro)) (require (for-syntax racket/base - syntax/parse racket/format racket/match racket/list) - racket/format + (only-in "flow/extended/expander.rkt" + qi-macro + esc) syntax/parse/define syntax/parse) (begin-for-syntax - (struct qi-macro [transformer]) (define (foreign-template-arg-indices tmpl) ;; return a list of indices corresponding to @@ -94,6 +92,11 @@ #`(define-syntax #,((make-interned-syntax-introducer 'qi) #'name) transformer)])) +;; TODO: get this to work +;; (define-syntax define-qi-alias +;; (syntax-parser +;; [(_ alias:id name:id) #'(define-qi-syntax alias (make-rename-transformer #'name))])) + (define-syntax define-qi-syntax-rule (syntax-parser [(_ (name . pat) template) diff --git a/qi-lib/main.rkt b/qi-lib/main.rkt index 4e38131dc..b81c616ee 100644 --- a/qi-lib/main.rkt +++ b/qi-lib/main.rkt @@ -8,9 +8,7 @@ qi/threading)) (require qi/flow - (except-in qi/macro - qi-macro-transformer - qi-macro?) + qi/macro qi/on qi/switch qi/threading) diff --git a/qi-lib/private/util.rkt b/qi-lib/private/util.rkt index 1dd34c618..4a6c329aa 100644 --- a/qi-lib/private/util.rkt +++ b/qi-lib/private/util.rkt @@ -6,21 +6,25 @@ (require racket/string racket/format + racket/match syntax/parse/define (for-syntax racket/base syntax/parse/lib/function-header)) -(define (report-syntax-error name args usage . msgs) - (raise-syntax-error name - (~a "Syntax error in " - (list* name args) - "\n" - "Usage:\n" - " " usage - (if (null? msgs) - "" - (string-append "\n" - (string-join msgs "\n")))))) +(define (report-syntax-error stx usage . msgs) + (match (syntax->datum stx) + [(cons name args) + (raise-syntax-error name + (~a "Syntax error in " + (list* name args) + "\n" + "Usage:\n" + " " usage + (if (null? msgs) + "" + (string-append "\n" + (string-join msgs "\n")))) + stx)])) (define-syntax-parse-rule (define-alias alias:id name:id) (define-syntax alias (make-rename-transformer #'name))) diff --git a/qi-lib/switch.rkt b/qi-lib/switch.rkt index a6b8ce7de..a5c3dbf2e 100644 --- a/qi-lib/switch.rkt +++ b/qi-lib/switch.rkt @@ -1,6 +1,10 @@ #lang racket/base -(provide switch +;; This name juggling is necessary since the Racket macros would +;; otherwise collide with the Qi forms with the same name in the qi +;; binding space, since Qi forms are now exported literals and not simply +;; matched as datum patterns as they were formerly. +(provide (rename-out [%switch switch]) switch-lambda switch-λ λ01 @@ -16,7 +20,7 @@ define-alias params-parser)) -(define-syntax-parser switch +(define-syntax-parser %switch [(_ args:subject clause ...) #'(on args @@ -30,7 +34,7 @@ [(_ args:formals expr:expr ...) #:with ags (params-parser #'args) #'(lambda args - (switch ags + (%switch ags expr ...))]) (define-alias λ01 switch-lambda) @@ -44,4 +48,4 @@ expr ...))] [(_ name:id expr:expr ...) #'(define name - (☯ (switch expr ...)))]) + (flow (switch expr ...)))]) diff --git a/qi-lib/threading.rkt b/qi-lib/threading.rkt index 7c20effe7..42ac361b0 100644 --- a/qi-lib/threading.rkt +++ b/qi-lib/threading.rkt @@ -1,35 +1,38 @@ #lang racket/base -(provide ~> - ~>>) +;; This name juggling is necessary since the Racket macros would +;; otherwise collide with the Qi forms with the same name in the qi +;; binding space, since Qi forms are now exported literals and not simply +;; matched as datum patterns as they were formerly. +(provide (rename-out [%~> ~>] + [%~>> ~>>])) (require syntax/parse/define (for-syntax racket/base (only-in "private/util.rkt" report-syntax-error) "flow/aux-syntax.rkt") + "flow.rkt" "on.rkt") -(define-syntax-parser ~> - [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) +(define-syntax-parser %~> + [(_ (arg0:expr arg:expr ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error - (report-syntax-error '~> - (syntax->datum #'((arg0 arg ...) sep clause ...)) - "(~> (arg ...) flo ...)" - "Attempted to separate multiple values." - "Note that the inputs to ~> must be wrapped in parentheses.")] + (report-syntax-error this-syntax + "(~> (arg ...) flo ...)" + "Attempted to separate multiple values." + "Note that the inputs to ~> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) #'(on ags (~> clause ...))]) -(define-syntax-parser ~>> - [(_ (arg0 arg ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) +(define-syntax-parser %~>> + [(_ (arg0:expr arg:expr ...+) (~or* (~datum sep) (~datum △)) clause:clause ...) ;; catch a common usage error - (report-syntax-error '~>> - (syntax->datum #'((arg0 arg ...) sep clause ...)) - "(~>> (arg ...) flo ...)" - "Attempted to separate multiple values." - "Note that the inputs to ~>> must be wrapped in parentheses.")] + (report-syntax-error this-syntax + "(~>> (arg ...) flo ...)" + "Attempted to separate multiple values." + "Note that the inputs to ~>> must be wrapped in parentheses.")] [(_ args:subject clause:clause ...) #:with ags (attribute args.args) #'(on ags (~>> clause ...))]) diff --git a/qi-sdk/info.rkt b/qi-sdk/info.rkt index 8ee90a5ea..ea3ccec2d 100644 --- a/qi-sdk/info.rkt +++ b/qi-sdk/info.rkt @@ -9,6 +9,8 @@ "math-lib" "collections-lib" "relation-lib" + "csv-writing" + "require-latency" "cover" "cover-coveralls")) (define build-deps '()) diff --git a/qi-sdk/profile/competitive.rkt b/qi-sdk/profile/competitive.rkt deleted file mode 100644 index 3fde6766a..000000000 --- a/qi-sdk/profile/competitive.rkt +++ /dev/null @@ -1,76 +0,0 @@ -#lang racket/base - -(require (only-in data/collection - cycle - take - in) - (only-in racket/list - range) - (only-in racket/function - curryr) - (prefix-in q: "qi.rkt") - (prefix-in b: "builtin.rkt")) - -(require "util.rkt") - -(displayln "\nRunning flat benchmarks...") - -(run-competitive-benchmark "Conditionals" - check-value - cond-fn - 300000) - -(run-competitive-benchmark "Composition" - check-value - compose-fn - 300000) - -(run-competitive-benchmark "Root Mean Square" - check-list - root-mean-square - 500000) - -(run-competitive-benchmark "Filter-map" - check-list - filter-map-fn - 500000) - -(run-competitive-benchmark "Filter-map values" - check-values - filter-map-values - 500000) - -(run-competitive-benchmark "Double list" - check-list - double-list - 500000) - -(run-competitive-benchmark "Double values" - check-values - double-values - 500000) - -(displayln "\nRunning Recursive benchmarks...") - -(run-competitive-benchmark "Factorial" - check-value - fact - 100000) - -(run-competitive-benchmark "Pingala" - check-value - ping - 10000) - -(define check-value-primes (curryr check-value #(100 200 300))) - -(run-competitive-benchmark "Eratosthenes" - check-value-primes - eratos - 100) - -;; See https://en.wikipedia.org/wiki/Collatz_conjecture -(run-competitive-benchmark "Collatz" - check-value - collatz - 10000) diff --git a/qi-sdk/profile/loading/loadlib.rkt b/qi-sdk/profile/loading/loadlib.rkt new file mode 100755 index 000000000..b0dae806e --- /dev/null +++ b/qi-sdk/profile/loading/loadlib.rkt @@ -0,0 +1,16 @@ +#!/usr/bin/env racket +#lang racket/base + +(provide profile-load) + +(require pkg/require-latency + racket/format) + +(define (profile-load module-name) + (let ([name (~a "(require " module-name ")")] + [ms (cdr (time-module-ms module-name))]) + (displayln (~a name ": " ms " ms") + (current-error-port)) + (hash 'name name + 'unit "ms" + 'value ms))) diff --git a/qi-sdk/profile/loading/report.rkt b/qi-sdk/profile/loading/report.rkt new file mode 100755 index 000000000..e91d64de6 --- /dev/null +++ b/qi-sdk/profile/loading/report.rkt @@ -0,0 +1,41 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call + write-csv + format-output) + "../regression.rkt" + "loadlib.rkt") + +(help + (usage + (~a "Measure module load time, i.e. the time taken by (require qi)."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(program (main) + (displayln "\nMeasuring module load time..." (current-error-port)) + + (let ([output (profile-load "qi")]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +(run main) diff --git a/qi-sdk/profile/loadlib.rkt b/qi-sdk/profile/loadlib.rkt deleted file mode 100755 index 4ebdaed6d..000000000 --- a/qi-sdk/profile/loadlib.rkt +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/env racket -#lang cli - -(provide time-racket - time-module-ms) - -(require racket/port - racket/format) - -#| -This works by: -1. Running `racket -l ` and `racket -l racket/base` independently -2. Subtracting the latter from the former. -3. Printing that result in milliseconds. - -where is the argument you specified at the command line, -e.g. ./loadlib.rkt racket/list - -The idea is to subtract out the contribution from racket/base, so that -what remains is just the time contributed by requiring the specified module. -|# - -(define (time-racket [module-name "racket/base"]) - (define-values (sp out in err) - (subprocess #f #f #f (find-executable-path "time") "-p" (find-executable-path "racket") "-l" module-name)) - (define result (port->string err)) - (define seconds (string->number - (car - (regexp-match #px"[\\d|\\.]+" - (car - (regexp-match #rx"(?m:^real.*)" - result)))))) - (close-input-port out) - (close-output-port in) - (close-input-port err) - (subprocess-wait sp) - seconds) - -(define (time-module-ms module-name) - (* 1000 - (- (time-racket module-name) - (time-racket)))) - -(program (time-require module-name) - (displayln (~a (time-module-ms module-name) " ms"))) - -(module+ main - (run time-require)) diff --git a/qi-sdk/profile/forms-base.rkt b/qi-sdk/profile/local/base.rkt similarity index 69% rename from qi-sdk/profile/forms-base.rkt rename to qi-sdk/profile/local/base.rkt index 707bc19a3..7431b112f 100644 --- a/qi-sdk/profile/forms-base.rkt +++ b/qi-sdk/profile/local/base.rkt @@ -2,11 +2,9 @@ (provide (all-from-out racket/base) (all-from-out qi) - (all-from-out "util.rkt") + (all-from-out "../util.rkt") sqr) (require qi - "util.rkt" + "../util.rkt" (only-in math sqr)) - - diff --git a/qi-sdk/profile/forms.rkt b/qi-sdk/profile/local/benchmarks.rkt old mode 100644 new mode 100755 similarity index 75% rename from qi-sdk/profile/forms.rkt rename to qi-sdk/profile/local/benchmarks.rkt index 5cd5a383a..3a4794c57 --- a/qi-sdk/profile/forms.rkt +++ b/qi-sdk/profile/local/benchmarks.rkt @@ -1,3 +1,4 @@ +#!/usr/bin/env racket #lang racket/base #| @@ -10,92 +11,97 @@ utility macros `run-benchmark` or `run-summary-benchmark`, and provides it one of the helper functions `check-value` (to invoke the form with a single value each time during benchmarking) or `check-values` (to invoke the form with multiple values each time -during benchmarking). +during benchmarking). Note that at the moment, as a hack for +convenience, `run-benchmark` expects a function with the name of the +form being benchmarked _prefixed with tilde_. This is to avoid name +collisions between this function and the Qi form with the same +name. Basically, just follow one of the numerous examples in this +module to see what this is referring to. 2. Require the submodule in the `main` submodule with an appropriate prefix (see other examples) 3. Add the required `run` function to the `env` hash in the main -submodule. This will ensure that it gets picked up when the benchmarks +submodule. This will ensure that it gets picked up when the benchmarks for the forms are run. |# -(module one-of? "forms-base.rkt" +(module one-of? "base.rkt" (provide run) - (define (one-of? v) + (define (~one-of? v) ((☯ (one-of? 3 5 7)) v)) (define (run) - (run-benchmark one-of? + (run-benchmark ~one-of? check-value 100000))) -(module and "forms-base.rkt" +(module and "base.rkt" (provide run) - (define (and v) + (define (~and v) ((☯ (and positive? integer?)) v)) (define (run) - (run-benchmark and + (run-benchmark ~and check-value 200000))) -(module or "forms-base.rkt" +(module or "base.rkt" (provide run) - (define (or v) + (define (~or v) ((☯ (or positive? integer?)) v)) (define (run) - (run-benchmark or + (run-benchmark ~or check-value 200000))) -(module not "forms-base.rkt" +(module not "base.rkt" (provide run) - (define (not v) + (define (~not v) ((☯ (not integer?)) v)) (define (run) - (run-benchmark not + (run-benchmark ~not check-value 200000))) -(module and% "forms-base.rkt" +(module and% "base.rkt" (provide run) - (define (and% a b) + (define (~and% a b) ((☯ (and% positive? integer?)) a b)) (define (run) - (run-benchmark and% + (run-benchmark ~and% check-two-values 200000))) -(module or% "forms-base.rkt" +(module or% "base.rkt" (provide run) - (define (or% a b) + (define (~or% a b) ((☯ (or% positive? integer?)) a b)) (define (run) - (run-benchmark or% + (run-benchmark ~or% check-two-values 200000))) -(module group "forms-base.rkt" +(module group "base.rkt" (provide run) - (define (group . vs) + (define (~group . vs) (apply (☯ (~> (group 2 + _) (group 3 + _) @@ -104,27 +110,27 @@ for the forms are run. vs)) (define (run) - (run-benchmark group + (run-benchmark ~group check-values 200000))) -(module count "forms-base.rkt" +(module count "base.rkt" (provide run) - (define (count . vs) + (define (~count . vs) (apply (☯ count) vs)) (define (run) - (run-benchmark count + (run-benchmark ~count check-values 1000000))) -(module relay "forms-base.rkt" +(module relay "base.rkt" (provide run) - (define (relay . vs) + (define (~relay . vs) (apply (☯ (== add1 sub1 @@ -139,14 +145,14 @@ for the forms are run. vs)) (define (run) - (run-benchmark relay + (run-benchmark ~relay check-values 50000))) -(module relay* "forms-base.rkt" +(module relay* "base.rkt" (provide run) - (define (relay* . vs) + (define (~relay* . vs) (apply (☯ (==* add1 sub1 @@ -155,40 +161,52 @@ for the forms are run. vs)) (define (run) - (run-benchmark relay* + (run-benchmark ~relay* check-values 50000))) -(module amp "forms-base.rkt" +(module amp "base.rkt" (provide run) - (define (amp . vs) + (define (~amp . vs) (apply (☯ (>< sqr)) vs)) (define (run) - (run-benchmark amp + (run-benchmark ~amp check-values 300000))) -(module ground "forms-base.rkt" +(module as "base.rkt" (provide run) - (define (ground . vs) + (define (~as v) + ((☯ (~> (as w))) + v)) + + (define (run) + (run-benchmark ~as + check-value + 500000))) + +(module ground "base.rkt" + (provide run) + + (define (~ground . vs) (apply (☯ ⏚) vs)) (define (run) - (run-benchmark ground + (run-benchmark ~ground check-values 200000))) -(module thread "forms-base.rkt" +(module thread "base.rkt" (provide run) - (define (thread . vs) + (define (~thread . vs) (apply (☯ (~> (+ 5) add1 @@ -204,14 +222,14 @@ for the forms are run. vs)) (define (run) - (run-benchmark thread + (run-benchmark ~thread check-values 200000))) -(module thread-right "forms-base.rkt" +(module thread-right "base.rkt" (provide run) - (define (thread-right . vs) + (define (~thread-right . vs) (apply (☯ (~>> (+ 5) add1 @@ -227,255 +245,255 @@ for the forms are run. vs)) (define (run) - (run-benchmark thread-right + (run-benchmark ~thread-right check-values 200000))) -(module crossover "forms-base.rkt" +(module crossover "base.rkt" (provide run) - (define (crossover . vs) + (define (~crossover . vs) (apply (☯ X) vs)) (define (run) - (run-benchmark crossover + (run-benchmark ~crossover check-values 200000))) -(module all "forms-base.rkt" +(module all "base.rkt" (provide run) - (define (all . vs) + (define (~all . vs) (apply (☯ (all positive?)) vs)) (define (run) - (run-benchmark all + (run-benchmark ~all check-values 200000))) -(module any "forms-base.rkt" +(module any "base.rkt" (provide run) - (define (any . vs) + (define (~any . vs) (apply (☯ (any positive?)) vs)) (define (run) - (run-benchmark any + (run-benchmark ~any check-values 200000))) -(module none "forms-base.rkt" +(module none "base.rkt" (provide run) - (define (none . vs) + (define (~none . vs) (apply (☯ (none positive?)) vs)) (define (run) - (run-benchmark none + (run-benchmark ~none check-values 200000))) -(module all? "forms-base.rkt" +(module all? "base.rkt" (provide run) - (define (all? . vs) + (define (~all? . vs) (apply (☯ all?) vs)) (define (run) - (run-benchmark all? + (run-benchmark ~all? check-values 200000))) -(module any? "forms-base.rkt" +(module any? "base.rkt" (provide run) - (define (any? . vs) + (define (~any? . vs) (apply (☯ any?) vs)) (define (run) - (run-benchmark any? + (run-benchmark ~any? check-values 200000))) -(module none? "forms-base.rkt" +(module none? "base.rkt" (provide run) - (define (none? . vs) + (define (~none? . vs) (apply (☯ none?) vs)) (define (run) - (run-benchmark none? + (run-benchmark ~none? check-values 200000))) -(module collect "forms-base.rkt" +(module collect "base.rkt" (provide run) - (define (collect . vs) + (define (~collect . vs) (apply (☯ ▽) vs)) (define (run) - (run-benchmark collect + (run-benchmark ~collect check-values 1000000))) -(module sep "forms-base.rkt" +(module sep "base.rkt" (provide run) - (define (sep v) + (define (~sep v) ((☯ △) v)) (define (run) - (run-benchmark sep + (run-benchmark ~sep check-list 1000000))) -(module gen "forms-base.rkt" +(module gen "base.rkt" (provide run) - (define (gen . vs) + (define (~gen . vs) (apply (☯ (gen 1 2 3)) vs)) (define (run) - (run-benchmark gen + (run-benchmark ~gen check-values 1000000))) -(module esc "forms-base.rkt" +(module esc "base.rkt" (provide run) - (define (esc . vs) + (define (~esc . vs) (apply (☯ (esc (λ args args))) vs)) (define (run) - (run-benchmark esc + (run-benchmark ~esc check-values 1000000))) -(module AND "forms-base.rkt" +(module AND "base.rkt" (provide run) - (define (AND . vs) + (define (~AND . vs) (apply (☯ AND) vs)) (define (run) - (run-benchmark AND + (run-benchmark ~AND check-values 200000))) -(module OR "forms-base.rkt" +(module OR "base.rkt" (provide run) - (define (OR . vs) + (define (~OR . vs) (apply (☯ OR) vs)) (define (run) - (run-benchmark OR + (run-benchmark ~OR check-values 200000))) -(module NOT "forms-base.rkt" +(module NOT "base.rkt" (provide run) - (define (NOT v) + (define (~NOT v) ((☯ NOT) v)) (define (run) - (run-benchmark NOT + (run-benchmark ~NOT check-value 200000))) -(module NAND "forms-base.rkt" +(module NAND "base.rkt" (provide run) - (define (NAND . vs) + (define (~NAND . vs) (apply (☯ NAND) vs)) (define (run) - (run-benchmark NAND + (run-benchmark ~NAND check-values 200000))) -(module NOR "forms-base.rkt" +(module NOR "base.rkt" (provide run) - (define (NOR . vs) + (define (~NOR . vs) (apply (☯ NOR) vs)) (define (run) - (run-benchmark NOR + (run-benchmark ~NOR check-values 200000))) -(module XOR "forms-base.rkt" +(module XOR "base.rkt" (provide run) - (define (XOR . vs) + (define (~XOR . vs) (apply (☯ XOR) vs)) (define (run) - (run-benchmark XOR + (run-benchmark ~XOR check-values 200000))) -(module XNOR "forms-base.rkt" +(module XNOR "base.rkt" (provide run) - (define (XNOR . vs) + (define (~XNOR . vs) (apply (☯ XNOR) vs)) (define (run) - (run-benchmark XNOR + (run-benchmark ~XNOR check-values 200000))) -(module tee "forms-base.rkt" +(module tee "base.rkt" (provide run) - (define (tee v) + (define (~tee v) ((☯ (-< add1 sub1 sqr)) v)) (define (run) - (run-benchmark tee + (run-benchmark ~tee check-value 200000))) -(module try "forms-base.rkt" +(module try "base.rkt" (provide run) (define (try-happy . vs) @@ -498,7 +516,7 @@ for the forms are run. (try-happy check-values 20000) (try-error check-values 20000)))) -(module currying "forms-base.rkt" +(module currying "base.rkt" (provide run) (define (currying . vs) @@ -509,7 +527,7 @@ for the forms are run. check-values 200000))) -(module template "forms-base.rkt" +(module template "base.rkt" (provide run) (define (template . vs) @@ -520,7 +538,7 @@ for the forms are run. check-values 200000))) -(module catchall-template "forms-base.rkt" +(module catchall-template "base.rkt" (provide run) (define (catchall-template . vs) @@ -531,43 +549,43 @@ for the forms are run. check-values 200000))) -(module if "forms-base.rkt" +(module if "base.rkt" (provide run) - (define (if . vs) + (define (~if . vs) (apply (☯ (if < 'hi 'bye)) vs)) (define (run) - (run-benchmark if + (run-benchmark ~if check-values 500000))) -(module when "forms-base.rkt" +(module when "base.rkt" (provide run) - (define (when . vs) + (define (~when . vs) (apply (☯ (when < 'hi)) vs)) (define (run) - (run-benchmark when + (run-benchmark ~when check-values 500000))) -(module unless "forms-base.rkt" +(module unless "base.rkt" (provide run) - (define (unless . vs) + (define (~unless . vs) (apply (☯ (unless < 'hi)) vs)) (define (run) - (run-benchmark unless + (run-benchmark ~unless check-values 500000))) -(module switch "forms-base.rkt" +(module switch "base.rkt" (provide run) (define (switch-basic . vs) @@ -595,41 +613,41 @@ for the forms are run. (switch-else check-values 200000) (switch-divert check-values 200000)))) -(module sieve "forms-base.rkt" +(module sieve "base.rkt" (provide run) - (define (sieve . vs) + (define (~sieve . vs) (apply (☯ (sieve positive? 'hi 'bye)) vs)) (define (run) - (run-benchmark sieve + (run-benchmark ~sieve check-values 100000))) -(module partition "forms-base.rkt" +(module partition "base.rkt" (provide run) - (define (partition . vs) + (define (~partition . vs) (apply (flow (partition [negative? *] [zero? count] [positive? +])) vs)) (define (run) - (run-benchmark partition check-values 100000))) + (run-benchmark ~partition check-values 100000))) -(module gate "forms-base.rkt" +(module gate "base.rkt" (provide run) - (define (gate . vs) + (define (~gate . vs) (apply (☯ (gate <)) vs)) (define (run) - (run-benchmark gate + (run-benchmark ~gate check-values 500000))) -(module input-aliases "forms-base.rkt" +(module input-aliases "base.rkt" (provide run) (define (input-alias-1 . vs) @@ -657,7 +675,7 @@ for the forms are run. check-values 100000)))) -(module fanout "forms-base.rkt" +(module fanout "base.rkt" (provide run) (define (fanout-small-n . vs) @@ -678,19 +696,19 @@ for the forms are run. check-values 20000)))) -(module inverter "forms-base.rkt" +(module inverter "base.rkt" (provide run) - (define (inverter . vs) + (define (~inverter . vs) (apply (☯ inverter) vs)) (define (run) - (run-benchmark inverter + (run-benchmark ~inverter check-values 200000))) -(module feedback "forms-base.rkt" +(module feedback "base.rkt" (provide run) (define (feedback-number . vs) @@ -719,130 +737,130 @@ for the forms are run. check-value 70000)))) -(module select "forms-base.rkt" +(module select "base.rkt" (provide run) - (define (select . vs) + (define (~select . vs) (apply (☯ (select 3 5 8)) vs)) (define (run) - (run-benchmark select + (run-benchmark ~select check-values 20000))) -(module block "forms-base.rkt" +(module block "base.rkt" (provide run) - (define (block . vs) + (define (~block . vs) (apply (☯ (block 3 5 8)) vs)) (define (run) - (run-benchmark block + (run-benchmark ~block check-values 20000))) -(module bundle "forms-base.rkt" +(module bundle "base.rkt" (provide run) - (define (bundle . vs) + (define (~bundle . vs) (apply (☯ (bundle (3 5 8) + -)) vs)) (define (run) - (run-benchmark bundle + (run-benchmark ~bundle check-values 20000))) -(module effect "forms-base.rkt" +(module effect "base.rkt" (provide run) - (define (effect . vs) + (define (~effect . vs) (apply (☯ (effect + +)) vs)) (define (run) - (run-benchmark effect + (run-benchmark ~effect check-values 200000))) -(module live? "forms-base.rkt" +(module live? "base.rkt" (provide run) - (define (live? . vs) + (define (~live? . vs) (apply (☯ live?) vs)) (define (run) - (run-benchmark live? + (run-benchmark ~live? check-values 500000))) -(module rectify "forms-base.rkt" +(module rectify "base.rkt" (provide run) - (define (rectify . vs) + (define (~rectify . vs) (apply (☯ (rectify #f)) vs)) (define (run) - (run-benchmark rectify + (run-benchmark ~rectify check-values 500000))) -(module pass "forms-base.rkt" +(module pass "base.rkt" (provide run) - (define (pass . vs) + (define (~pass . vs) (apply (☯ (pass odd?)) vs)) (define (run) - (run-benchmark pass + (run-benchmark ~pass check-values 200000))) -(module foldl "forms-base.rkt" +(module foldl "base.rkt" (provide run) - (define (>> . vs) + (define (~foldl . vs) (apply (☯ (>> +)) vs)) (define (run) - (run-benchmark >> + (run-benchmark ~foldl check-values 200000))) -(module foldr "forms-base.rkt" +(module foldr "base.rkt" (provide run) - (define (<< . vs) + (define (~foldr . vs) (apply (☯ (<< +)) vs)) (define (run) - (run-benchmark << + (run-benchmark ~foldr check-values 200000))) -(module loop "forms-base.rkt" +(module loop "base.rkt" (provide run) - (define (loop . vs) + (define (~loop . vs) (apply (☯ (loop live? sqr)) vs)) (define (run) - (run-benchmark loop + (run-benchmark ~loop check-values 100000))) -(module loop2 "forms-base.rkt" +(module loop2 "base.rkt" (provide run) - (define (loop2 . vs) + (define (~loop2 . vs) ((☯ (~> (loop2 (~> 1> (not null?)) sqr +))) @@ -850,46 +868,51 @@ for the forms are run. 0)) (define (run) - (run-benchmark loop2 + (run-benchmark ~loop2 check-values 100000))) -(module apply "forms-base.rkt" +(module apply "base.rkt" (provide run) (require (only-in racket/base [apply b:apply])) - (define (apply . vs) + (define (~apply . vs) (b:apply (☯ apply) (cons + vs))) (define (run) - (run-benchmark apply + (run-benchmark ~apply check-values 300000))) -(module clos "forms-base.rkt" +(module clos "base.rkt" (provide run) ;; TODO: this uses a lot of other things besides `clos` and is ;; likely not a reliable indicator - (define (clos . vs) + (define (~clos . vs) (apply (☯ (~> (-< (~> 5 (clos *)) _) apply)) vs)) (define (run) - (run-benchmark clos + (run-benchmark ~clos check-values 100000))) -;; To run benchmarks for a form interactively, use e.g.: -;; (require (submod "." fanout)) -;; (run) +(module main racket/base -(module* main cli + (provide benchmark) + (require racket/match + racket/format + relation + qi + (only-in "../util.rkt" + only-if + for/call)) (require (prefix-in one-of?: (submod ".." one-of?)) (prefix-in and: (submod ".." and)) @@ -902,6 +925,7 @@ for the forms are run. (prefix-in relay: (submod ".." relay)) (prefix-in relay*: (submod ".." relay*)) (prefix-in amp: (submod ".." amp)) + (prefix-in as: (submod ".." as)) (prefix-in ground: (submod ".." ground)) (prefix-in thread: (submod ".." thread)) (prefix-in thread-right: (submod ".." thread-right)) @@ -953,14 +977,6 @@ for the forms are run. (prefix-in apply: (submod ".." apply)) (prefix-in clos: (submod ".." clos))) - (require racket/match - racket/format - relation - qi - (only-in "util.rkt" - only-if - for/call)) - ;; It would be great if we could get the value of a variable ;; by using its (string) name, but (eval (string->symbol name)) ;; doesn't find it. So instead, we reify the "lexical environment" @@ -980,6 +996,7 @@ for the forms are run. "relay" relay:run "relay*" relay*:run "amp" amp:run + "as" as:run "ground" ground:run "thread" thread:run "thread-right" thread-right:run @@ -1031,19 +1048,17 @@ for the forms are run. "apply" apply:run "clos" clos:run)) - (flag (forms #:param [forms null] name) - ("-f" "--form" "Forms to benchmark") - (forms (cons name (forms)))) - - (constraint (multi forms)) - - (program (main) - (let ([fs (~>> ((forms)) - (only-if null? - (gen (hash-keys env))) - (sort <))]) - (for ([f fs]) - (match-let ([(list name ms) ((hash-ref env f))]) - (displayln (~a name ": " ms " ms")))))) - - (run main)) + (define (benchmark forms) + (define fs (~>> (forms) + (only-if null? + (gen (hash-keys env))) + (sort <))) + (define forms-data (for/list ([f (in-list fs)]) + (match-let ([(list name ms) ((hash-ref env f))]) + ;; Print results "live" to STDERR, with + ;; only the actual output (if desired) + ;; going to STDOUT at the end. + (displayln (~a name ": " ms " ms") + (current-error-port)) + (hash 'name name 'unit "ms" 'value ms)))) + forms-data)) diff --git a/qi-sdk/profile/local/report.rkt b/qi-sdk/profile/local/report.rkt new file mode 100755 index 000000000..2ff1e96ea --- /dev/null +++ b/qi-sdk/profile/local/report.rkt @@ -0,0 +1,46 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/format + (only-in "../util.rkt" + format-output) + "../regression.rkt" + (submod "benchmarks.rkt" main)) + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select form to benchmark") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run benchmarks for individual Qi forms " + "(by default, all of them), reporting the results " + "in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(program (main) + (displayln "\nRunning local (forms) benchmarks..." (current-error-port)) + + (let ([output (benchmark (selected))]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "fanout")) + +(run main) diff --git a/qi-sdk/profile/nonlocal/intrinsic.rkt b/qi-sdk/profile/nonlocal/intrinsic.rkt new file mode 100755 index 000000000..b5c04ad1b --- /dev/null +++ b/qi-sdk/profile/nonlocal/intrinsic.rkt @@ -0,0 +1,55 @@ +#!/usr/bin/env racket +#lang racket/base + +(provide benchmark) + +(require racket/runtime-path + "../util.rkt" + "spec.rkt") + +;; We use `eval` in this module to `require` the appropriate objective +;; functions (either Racket or Qi) for benchmarking in a dynamically +;; constructed namespace (following +;; https://docs.racket-lang.org/guide/eval.html). This allows us to +;; define those functions symmetrically in the Racket and Qi modules, and +;; invoke them in a common way here. But as this eval namespace is +;; dynamically constructed, the require paths are interpreted as being +;; relative to the path from which this module is executed (e.g. either +;; locally from this folder or from the qi root via the Makefile) and may +;; therefore fail to find the modules if executed from "the wrong" +;; location. To avoid this, we set the "load relative" directory to the +;; module's path, so that requiring modules is always relative to the +;; present module path, allowing it to behave the same no matter where it +;; is executed from. Another possibility is to simply assume that the +;; qi-sdk package is installed so that the modules are available via +;; collection paths, but currently, having the SDK "officially" installed +;; slows down building of other packages for reasons as yet unknown. See: +;; https://github.com/drym-org/qi/wiki/Installing-the-SDK#install-the-sdk +;; So for now, we use this fix so that we can have the SDK remain +;; uninstalled. + +(define-runtime-path lexical-module-path ".") + +(define (benchmark language benchmarks-to-run) + (let ([namespace (make-base-namespace)] + [benchmarks-to-run (if (null? benchmarks-to-run) + (map bm-name specs) + benchmarks-to-run)]) + (cond [(equal? "qi" language) + (parameterize ([current-load-relative-directory lexical-module-path]) + (eval '(require "qi/main.rkt") + namespace))] + [(equal? "racket" language) + (parameterize ([current-load-relative-directory lexical-module-path]) + (eval '(require "racket/main.rkt") + namespace))]) + + (for/list ([spec specs] + #:when (member (bm-name spec) benchmarks-to-run)) + (let ([name (bm-name spec)] + [exerciser (bm-exerciser spec)] + [f (eval + ;; the first datum in the benchmark name needs to be a function name + (read (open-input-string (bm-name spec))) namespace)] + [n-times (bm-times spec)]) + (run-nonlocal-benchmark name exerciser f n-times))))) diff --git a/qi-sdk/profile/nonlocal/qi/main.rkt b/qi-sdk/profile/nonlocal/qi/main.rkt new file mode 100644 index 000000000..7d9f154ac --- /dev/null +++ b/qi-sdk/profile/nonlocal/qi/main.rkt @@ -0,0 +1,111 @@ +#lang racket/base + +(provide conditionals + composition + root-mean-square + factorial + pingala + eratosthenes + collatz + range-map-car + filter-map + filter-map-foldr + filter-map-foldl + long-functional-pipeline + filter-map-values + range-map-sum + double-list + double-values) + +(require (only-in math sqr) + (only-in racket/list range) + qi) + +(define-switch conditionals + [(< 5) sqr] + [(> 5) add1] + [else _]) + +(define-flow composition + (~> add1 sqr sub1)) + +(define-flow root-mean-square + (~> (-< (~>> △ (>< sqr) +) + length) / sqrt)) + +(define-switch factorial + [(< 2) 1] + [else (~> (-< _ (~> sub1 factorial)) *)]) + +(define-switch pingala + [(< 2) _] + [else (~> (-< sub1 + (- 2)) (>< pingala) +)]) + +(define-flow (eratosthenes n) + (~> (-< (gen null) (~>> add1 (range 2) △)) + (feedback (while (~> (block 1) live?)) + (then (~> 1> reverse)) + (-< (~> (select 1 2) X cons) + (~> (-< (~>> 2> (clos (~> remainder (not (= 0))))) + (block 1 2)) pass))))) + +(define-flow collatz + (switch + [(<= 1) list] + [odd? (~> (-< _ (~> (* 3) (+ 1) collatz)) + cons)] + [even? (~> (-< _ (~> (quotient 2) collatz)) + cons)])) + + +;; (define-flow filter-map +;; (~> △ (>< (if odd? sqr ⏚)) ▽)) + +(define-flow filter-map + (~>> (filter odd?) + (map sqr))) + +(define-flow filter-map-foldr + (~>> (filter odd?) + (map sqr) + (foldr + 0))) + +(define-flow filter-map-foldl + (~>> (filter odd?) + (map sqr) + (foldl + 0))) + +(define-flow range-map-car + (~>> (range 0) + (map sqr) + car)) + +(define-flow range-map-sum + ;; TODO: this should be written as (apply +) + ;; and that should be normalized to (foldr/l + 0) + ;; (depending on which of foldl/foldr is more performant) + (~>> (range 0) (map sqr) (foldr + 0))) + +(define-flow long-functional-pipeline + (~>> (range 0) + (filter odd?) + (map sqr) + values + (filter (λ (v) (< (remainder v 10) 5))) + (map (λ (v) (* 2 v))) + (foldl + 0))) + +;; (define filter-double +;; (map (☯ (when odd? +;; (-< _ _))) +;; (list 1 2 3 4 5))) + +(define-flow filter-map-values + (>< (if odd? sqr ⏚))) + +(define-flow double-list + (~> △ (>< (-< _ _)) ▽)) + +(define-flow double-values + (>< (-< _ _))) diff --git a/qi-sdk/profile/builtin.rkt b/qi-sdk/profile/nonlocal/racket/main.rkt similarity index 53% rename from qi-sdk/profile/builtin.rkt rename to qi-sdk/profile/nonlocal/racket/main.rkt index 30351831d..897698053 100644 --- a/qi-sdk/profile/builtin.rkt +++ b/qi-sdk/profile/nonlocal/racket/main.rkt @@ -1,14 +1,19 @@ #lang racket/base -(provide cond-fn - compose-fn +(provide conditionals + composition root-mean-square - fact - ping - eratos + factorial + pingala + eratosthenes collatz - filter-map-fn + range-map-car + filter-map + filter-map-foldr + filter-map-foldl + long-functional-pipeline filter-map-values + range-map-sum double-list double-values) @@ -16,30 +21,30 @@ racket/list racket/match) -(define (cond-fn x) +(define (conditionals x) (cond [(< x 5) (sqr x)] [(> x 5) (add1 x)] [else x])) -(define (compose-fn v) +(define (composition v) (sub1 (sqr (add1 v)))) (define (root-mean-square vs) (sqrt (/ (apply + (map sqr vs)) (length vs)))) -(define (fact n) +(define (factorial n) (if (< n 2) 1 - (* (fact (sub1 n)) n))) + (* (factorial (sub1 n)) n))) -(define (ping n) +(define (pingala n) (if (< n 2) n - (+ (ping (sub1 n)) - (ping (- n 2))))) + (+ (pingala (sub1 n)) + (pingala (- n 2))))) -(define (eratos n) +(define (eratosthenes n) (let ([lst (range 2 (add1 n))]) (let loop ([rem lst] [result null]) @@ -55,9 +60,31 @@ [(odd? n) (cons n (collatz (+ (* 3 n) 1)))] [(even? n) (cons n (collatz (quotient n 2)))])) -(define (filter-map-fn lst) +(define (filter-map lst) (map sqr (filter odd? lst))) +(define (filter-map-foldr lst) + (foldr + 0 (map sqr (filter odd? lst)))) + +(define (filter-map-foldl lst) + (foldl + 0 (map sqr (filter odd? lst)))) + +(define (range-map-car v) + (car (map sqr (range 0 v)))) + +(define (range-map-sum n) + (apply + (map sqr (range 0 n)))) + +(define (long-functional-pipeline v) + (foldl + + 0 + (map (λ (v) (* 2 v)) + (filter (λ (v) (< (remainder v 10) 5)) + (values + (map sqr + (filter odd? + (range 0 v)))))))) + (define (filter-map-values . vs) (apply values (map sqr (filter odd? vs)))) diff --git a/qi-sdk/profile/nonlocal/report-competitive.rkt b/qi-sdk/profile/nonlocal/report-competitive.rkt new file mode 100755 index 000000000..7e03033ff --- /dev/null +++ b/qi-sdk/profile/nonlocal/report-competitive.rkt @@ -0,0 +1,44 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/format + (only-in "../util.rkt" + format-output) + "../regression.rkt" + "intrinsic.rkt") + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select benchmark by name") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run competitive benchmarks between Qi and Racket, " + "reporting the results in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(program (main) + (displayln "\nRunning competitive benchmarks..." (current-error-port)) + + (let* ([racket-output + (begin (displayln "\nRunning Racket benchmarks..." (current-error-port)) + (benchmark "racket" (selected)))] + [qi-output + (begin (displayln "\nRunning Qi benchmarks..." (current-error-port)) + (benchmark "qi" (selected)))] + [before (parse-benchmarks racket-output)] + [after (parse-benchmarks qi-output)]) + (format-output (compute-regression before after) + (output-format)))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "composition")) + +(run main) diff --git a/qi-sdk/profile/nonlocal/report-intrinsic.rkt b/qi-sdk/profile/nonlocal/report-intrinsic.rkt new file mode 100755 index 000000000..c451cd71d --- /dev/null +++ b/qi-sdk/profile/nonlocal/report-intrinsic.rkt @@ -0,0 +1,51 @@ +#!/usr/bin/env racket +#lang cli + +(require racket/format + (only-in "../util.rkt" + format-output) + "../regression.rkt" + "intrinsic.rkt") + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select benchmark by name") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run nonlocal benchmarks on either Qi or Racket, " + "reporting the results in a configurable output format."))) + +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +(flag (language #:param [language "qi"] lang) + ("-l" + "--language" + "Language to benchmark, either 'qi' or 'racket'. If none is specified, assumes 'qi'.") + (language lang)) + +(program (main) + (displayln "\nRunning nonlocal benchmarks..." (current-error-port)) + + (let ([output (benchmark (language) (selected))]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "composition")) + +(run main) diff --git a/qi-sdk/profile/nonlocal/spec.rkt b/qi-sdk/profile/nonlocal/spec.rkt new file mode 100644 index 000000000..eb7b5388f --- /dev/null +++ b/qi-sdk/profile/nonlocal/spec.rkt @@ -0,0 +1,65 @@ +#lang racket/base + +(provide specs + (struct-out bm)) + +(require "../util.rkt") + +(struct bm (name exerciser times) + #:transparent) + +(define specs + ;; the first datum in the benchmark name needs to be the name + ;; of the function that will be exercised + (list (bm "conditionals" + check-value + 300000) + (bm "composition" + check-value + 300000) + (bm "root-mean-square" + check-list + 500000) + (bm "range-map-car" + check-value-large + 50000) + (bm "filter-map" + check-list + 500000) + (bm "filter-map (large list)" + check-large-list + 50000) + (bm "filter-map-foldr" + check-large-list + 50000) + (bm "filter-map-foldl" + check-large-list + 50000) + (bm "long-functional-pipeline" + check-value-large + 5000) + (bm "range-map-sum" + check-value-large + 5000) + (bm "filter-map-values" + check-values + 500000) + (bm "double-list" + check-list + 500000) + (bm "double-values" + check-values + 500000) + (bm "factorial" + check-value + 100000) + (bm "pingala" + check-value + 10000) + (bm "eratosthenes" + check-value-medium-large + 100) + ;; See https://en.wikipedia.org/wiki/Collatz_conjecture + (bm "collatz" + check-value + 10000))) diff --git a/qi-sdk/profile/qi.rkt b/qi-sdk/profile/qi.rkt deleted file mode 100644 index d15594bb6..000000000 --- a/qi-sdk/profile/qi.rkt +++ /dev/null @@ -1,67 +0,0 @@ -#lang racket/base - -(provide cond-fn - compose-fn - root-mean-square - fact - ping - eratos - collatz - filter-map-fn - filter-map-values - double-list - double-values) - -(require (only-in math sqr) - (only-in racket/list range) - qi) - -(define-switch cond-fn - [(< 5) sqr] - [(> 5) add1] - [else _]) - -(define-flow compose-fn - (~> add1 sqr sub1)) - -(define-flow root-mean-square - (~> (-< (~>> △ (>< sqr) +) - length) / sqrt)) - -(define-switch fact - [(< 2) 1] - [else (~> (-< _ (~> sub1 fact)) *)]) - -(define-switch ping - [(< 2) _] - [else (~> (-< sub1 - (- 2)) (>< ping) +)]) - -(define-flow (eratos n) - (~> (-< (gen null) (~>> add1 (range 2) △)) - (feedback (while (~> (block 1) live?)) - (then (~> 1> reverse)) - (-< (~> (select 1 2) X cons) - (~> (-< (~>> 2> (clos (~> remainder (not (= 0))))) - (block 1 2)) pass))))) - -(define-flow collatz - (switch - [(<= 1) list] - [odd? (~> (-< _ (~> (* 3) (+ 1) collatz)) - cons)] - [even? (~> (-< _ (~> (quotient 2) collatz)) - cons)])) - - -(define-flow filter-map-fn - (~> △ (>< (if odd? sqr ⏚)) ▽)) - -(define-flow filter-map-values - (>< (if odd? sqr ⏚))) - -(define-flow double-list - (~> △ (>< (-< _ _)) ▽)) - -(define-flow double-values - (>< (-< _ _))) diff --git a/qi-sdk/profile/regression.rkt b/qi-sdk/profile/regression.rkt new file mode 100644 index 000000000..20ec8b6c7 --- /dev/null +++ b/qi-sdk/profile/regression.rkt @@ -0,0 +1,74 @@ +#!/usr/bin/env racket +#lang racket/base + +(provide parse-json-file + parse-benchmarks + compute-regression) + +(require qi + relation + json + racket/format + racket/pretty) + +(define LOWER-THRESHOLD 0.75) +(define HIGHER-THRESHOLD 1.33) + +(define (parse-json-file filename) + (call-with-input-file filename + (λ (port) + (read-json port)))) + +(define (parse-benchmarks benchmarks) + ;; renames some forms so they're consistently named + ;; but otherwise leaves the original data unmodified + (make-hash + (map (☯ (~> (-< (~> (hash-ref 'name) + (switch + [(equal? "foldr") "<<"] ; these were renamed at some point + [(equal? "foldl") ">>"] ; so rename them back to match them + [else _])) + (hash-ref 'value)) + cons)) + benchmarks))) + +(define (compute-regression before + after + [low LOWER-THRESHOLD] + [high HIGHER-THRESHOLD]) + + (define-flow calculate-ratio + (~> (-< (hash-ref after _) + (~> (hash-ref before _) + ;; avoid division by zero + (if (= 0) 1 _))) + / + (if (< low _ high) + 1 + (~r #:precision 2)))) + + (define-flow reformat + (~> △ + (>< (~> (-< car cadr) + (hash 'name _ 'value _ 'unit "x"))) + ▽)) + + (define (show-results results) + (displayln "\nPerformance relative to baseline:" (current-error-port)) + (pretty-display results (current-error-port))) + + (define results + (~>> (after) + hash-keys + △ + (>< + (~> + (-< _ + calculate-ratio) + ▽)) + ▽ + (sort > #:key (☯ (~> cadr ->inexact))) + (ε show-results) + reformat)) + + results) diff --git a/qi-sdk/profile/report.rkt b/qi-sdk/profile/report.rkt old mode 100644 new mode 100755 index 82ed4b2d7..1208491ac --- a/qi-sdk/profile/report.rkt +++ b/qi-sdk/profile/report.rkt @@ -1,158 +1,69 @@ +#!/usr/bin/env racket #lang cli -(require - (prefix-in one-of?: (submod "forms.rkt" one-of?)) - (prefix-in and: (submod "forms.rkt" and)) - (prefix-in or: (submod "forms.rkt" or)) - (prefix-in not: (submod "forms.rkt" not)) - (prefix-in and%: (submod "forms.rkt" and%)) - (prefix-in or%: (submod "forms.rkt" or%)) - (prefix-in group: (submod "forms.rkt" group)) - (prefix-in count: (submod "forms.rkt" count)) - (prefix-in relay: (submod "forms.rkt" relay)) - (prefix-in relay*: (submod "forms.rkt" relay*)) - (prefix-in amp: (submod "forms.rkt" amp)) - (prefix-in ground: (submod "forms.rkt" ground)) - (prefix-in thread: (submod "forms.rkt" thread)) - (prefix-in thread-right: (submod "forms.rkt" thread-right)) - (prefix-in crossover: (submod "forms.rkt" crossover)) - (prefix-in all: (submod "forms.rkt" all)) - (prefix-in any: (submod "forms.rkt" any)) - (prefix-in none: (submod "forms.rkt" none)) - (prefix-in all?: (submod "forms.rkt" all?)) - (prefix-in any?: (submod "forms.rkt" any?)) - (prefix-in none?: (submod "forms.rkt" none?)) - (prefix-in collect: (submod "forms.rkt" collect)) - (prefix-in sep: (submod "forms.rkt" sep)) - (prefix-in gen: (submod "forms.rkt" gen)) - (prefix-in esc: (submod "forms.rkt" esc)) - (prefix-in AND: (submod "forms.rkt" AND)) - (prefix-in OR: (submod "forms.rkt" OR)) - (prefix-in NOT: (submod "forms.rkt" NOT)) - (prefix-in NAND: (submod "forms.rkt" NAND)) - (prefix-in NOR: (submod "forms.rkt" NOR)) - (prefix-in XOR: (submod "forms.rkt" XOR)) - (prefix-in XNOR: (submod "forms.rkt" XNOR)) - (prefix-in tee: (submod "forms.rkt" tee)) - (prefix-in try: (submod "forms.rkt" try)) - (prefix-in currying: (submod "forms.rkt" currying)) - (prefix-in template: (submod "forms.rkt" template)) - (prefix-in catchall-template: (submod "forms.rkt" catchall-template)) - (prefix-in if: (submod "forms.rkt" if)) - (prefix-in when: (submod "forms.rkt" when)) - (prefix-in unless: (submod "forms.rkt" unless)) - (prefix-in switch: (submod "forms.rkt" switch)) - (prefix-in sieve: (submod "forms.rkt" sieve)) - (prefix-in partition: (submod "forms.rkt" partition)) - (prefix-in gate: (submod "forms.rkt" gate)) - (prefix-in input-aliases: (submod "forms.rkt" input-aliases)) - (prefix-in fanout: (submod "forms.rkt" fanout)) - (prefix-in inverter: (submod "forms.rkt" inverter)) - (prefix-in feedback: (submod "forms.rkt" feedback)) - (prefix-in select: (submod "forms.rkt" select)) - (prefix-in block: (submod "forms.rkt" block)) - (prefix-in bundle: (submod "forms.rkt" bundle)) - (prefix-in effect: (submod "forms.rkt" effect)) - (prefix-in live?: (submod "forms.rkt" live?)) - (prefix-in rectify: (submod "forms.rkt" rectify)) - (prefix-in pass: (submod "forms.rkt" pass)) - (prefix-in foldl: (submod "forms.rkt" foldl)) - (prefix-in foldr: (submod "forms.rkt" foldr)) - (prefix-in loop: (submod "forms.rkt" loop)) - (prefix-in loop2: (submod "forms.rkt" loop2)) - (prefix-in apply: (submod "forms.rkt" apply)) - (prefix-in clos: (submod "forms.rkt" clos))) - -(require "loadlib.rkt") - -(require racket/match - racket/format +(require racket/format relation - qi - json (only-in "util.rkt" - only-if - for/call)) + format-output) + "loading/loadlib.rkt" + "regression.rkt" + (submod "local/benchmarks.rkt" main) + (prefix-in n: "nonlocal/intrinsic.rkt")) + +(flag (selected #:param [selected null] name) + ("-s" "--select" "Select form to benchmark") + (selected (cons name (selected)))) + +(constraint (multi selected)) + +(help + (usage + (~a "Run benchmarks for individual Qi forms " + "(by default, all of them), reporting the results " + "in a configurable output format."))) -;; It would be great if we could get the value of a variable -;; by using its (string) name, but (eval (string->symbol name)) -;; doesn't find it. So instead, we reify the "lexical environment" -;; here manually, so that the values can be looked up at runtime -;; based on the string names (note that the value is always the key -;; + ":" + "run") -(define env - (hash - "one-of?" one-of?:run - "and" and:run - "or" or:run - "not" not:run - "and%" and%:run - "or%" or%:run - "group" group:run - "count" count:run - "relay" relay:run - "relay*" relay*:run - "amp" amp:run - "ground" ground:run - "thread" thread:run - "thread-right" thread-right:run - "crossover" crossover:run - "all" all:run - "any" any:run - "none" none:run - "all?" all?:run - "any?" any?:run - "none?" none?:run - "collect" collect:run - "sep" sep:run - "gen" gen:run - "esc" esc:run - "AND" AND:run - "OR" OR:run - "NOT" NOT:run - "NAND" NAND:run - "NOR" NOR:run - "XOR" XOR:run - "XNOR" XNOR:run - "tee" tee:run - "try" try:run - "currying" currying:run - "template" template:run - "catchall-template" catchall-template:run - "if" if:run - "when" when:run - "unless" unless:run - "switch" switch:run - "sieve" sieve:run - "partition" partition:run - "gate" gate:run - "input-aliases" input-aliases:run - "fanout" fanout:run - "inverter" inverter:run - "feedback" feedback:run - "select" select:run - "block" block:run - "bundle" bundle:run - "effect" effect:run - "live?" live?:run - "rectify" rectify:run - "pass" pass:run - "foldl" foldl:run - "foldr" foldr:run - "loop" loop:run - "loop2" loop2:run - "apply" apply:run - "clos" clos:run)) +(flag (output-format #:param [output-format ""] fmt) + ("-f" + "--format" + "Output format to use, either 'json' or 'csv'. If none is specified, no output is generated.") + (output-format fmt)) +(flag (type #:param [report-type "all"] typ) + ("-t" + "--type" + "Type of report, either `local`, `nonlocal`, `loading` or `all` (default `all`)") + (report-type typ)) + +(flag (regression-file #:param [regression-file #f] reg-file) + ("-r" "--regression" "'Before' data to compute regression against") + (regression-file reg-file)) + +;; Note: much of this file is duplicated across local/report.rkt +;; and loading/report.rkt. It could be avoided if we had +;; "composition of commands", see: +;; https://github.com/countvajhula/cli/issues/3 (program (main) - ;; Note: could use try-order? with hash-keys if support is dropped for Racket 8.3 - (define fs (~>> (env) hash-keys (sort <))) - (define forms-data (for/list ([f (in-list fs)]) - (match-let ([(list name ms) ((hash-ref env f))]) - (hash 'name name 'unit "ms" 'value ms)))) - (define require-data (list (hash 'name "(require qi)" - 'unit "ms" - 'value (time-module-ms "qi")))) - (write-json (append forms-data require-data))) + (displayln "\nRunning local (forms) benchmarks and measuring module load time..." + (current-error-port)) + + (let* ([local-data (if (member? (report-type) (list "all" "local")) + (benchmark (selected)) + null)] + [nonlocal-data (if (member? (report-type) (list "all" "nonlocal")) + (n:benchmark "qi" (selected)) + null)] + [require-data (if (member? (report-type) (list "all" "loading")) + (list (profile-load "qi")) + null)] + [output (~ local-data nonlocal-data require-data)]) + (if (regression-file) + (let ([before (parse-benchmarks (parse-json-file (regression-file)))] + [after (parse-benchmarks output)]) + (format-output (compute-regression before after) + (output-format))) + (format-output output (output-format))))) + +;; To run benchmarks for a form interactively, use e.g.: +;; (run main #("-s" "fanout")) (run main) diff --git a/qi-sdk/profile/util.rkt b/qi-sdk/profile/util.rkt index 64720c827..27a0be0ef 100644 --- a/qi-sdk/profile/util.rkt +++ b/qi-sdk/profile/util.rkt @@ -3,28 +3,35 @@ (provide average measure check-value + check-value-medium-large + check-value-large + check-value-very-large check-list + check-large-list check-values check-two-values run-benchmark run-summary-benchmark - run-competitive-benchmark + run-nonlocal-benchmark (for-space qi only-if) - for/call) + for/call + write-csv + format-output) (require (only-in racket/list range second) + (only-in racket/function + curryr) (only-in adjutor values->list) - (only-in data/collection - cycle - take - in) - racket/function + csv-writing + json racket/format syntax/parse/define - (for-syntax racket/base) + (for-syntax racket/base + (only-in racket/string + string-trim)) qi) (define-flow average @@ -53,6 +60,12 @@ (set! i (remainder (add1 i) len)) (fn (vector-ref inputs i))))) +(define check-value-medium-large (curryr check-value #(100 200 300))) + +(define check-value-large (curryr check-value #(1000))) + +(define check-value-very-large (curryr check-value #(100000))) + ;; This uses the same list input each time. Not sure if that ;; may end up being cached at some level and thus obfuscate ;; the results? On the other hand, @@ -64,6 +77,12 @@ (for ([i how-many]) (fn vs)))) +(define (check-large-list fn how-many) + ;; call a function with a single list argument + (let ([vs (range 1000)]) + (for ([i how-many]) + (fn vs)))) + ;; This uses the same input values each time. See the note ;; above for check-list in this connection. (define (check-values fn how-many) @@ -84,10 +103,22 @@ ;; Run a single benchmarking function a specified number of times ;; and report the time taken. +;; TODO: this is very similar to run-nonlocal-benchmark and these +;; should be unified. (define-syntax-parse-rule (run-benchmark f-name runner n-times) #:with name (datum->syntax #'f-name - (symbol->string - (syntax->datum #'f-name))) + ;; this is because of the name collision between + ;; Racket functions and Qi forms, now that the latter + ;; are provided as identifiers in the qi binding space. + ;; Using a standard prefix (i.e. ~) in the naming and then + ;; detecting that, trimming it, here, is pretty hacky. + ;; One alternative could be to broaden the run-benchmark + ;; macro to support a name argument, but that seems like + ;; more work. It would be better to be able to introspect + ;; these somehow. + (string-trim (symbol->string + (syntax->datum #'f-name)) + "~")) (let ([ms (measure runner f-name n-times)]) (list name ms))) @@ -107,20 +138,30 @@ ;; Run different implementations of the same benchmark (e.g. a Racket vs a Qi ;; implementation) a specified number of times, and report the time taken ;; by each implementation. -(define-syntax-parse-rule (run-competitive-benchmark name runner f-name n-times) - #:with f-builtin (datum->syntax #'name - (string->symbol - (string-append "b:" - (symbol->string - (syntax->datum #'f-name))))) - #:with f-qi (datum->syntax #'name - (string->symbol - (string-append "q:" - (symbol->string - (syntax->datum #'f-name))))) - (begin - (displayln (~a name ":")) - (for ([f (list f-builtin f-qi)] - [label (list "λ" "☯")]) - (let ([ms (measure runner f n-times)]) - (displayln (~a label ": " ms " ms")))))) +(define (run-nonlocal-benchmark name runner f n-times) + (displayln (~a name ":") (current-error-port)) + (let ([ms (measure runner f n-times)]) + (displayln (~a ms " ms") (current-error-port)) + (hash 'name name 'unit "ms" 'value ms))) + +(define (write-csv data) + (~> (data) + △ + (>< (~> (-< (hash-ref 'name) + (hash-ref 'unit) + (hash-ref 'value)) + ▽)) + (-< '(name unit value) + _) + ▽ + display-table)) + +(define (format-output output fmt) + ;; Note: this is a case where declaring "constraints" on the CLI args + ;; would be useful, instead of using the ad hoc fallback `else` check here + ;; https://github.com/countvajhula/cli/issues/6 + (cond + [(equal? fmt "json") (write-json output)] + [(equal? fmt "csv") (write-csv output)] + [(equal? fmt "") (values)] + [else (error (~a "Unrecognized format: " fmt "!"))])) diff --git a/qi-test/info.rkt b/qi-test/info.rkt index 65d9a8e72..bd0a903de 100644 --- a/qi-test/info.rkt +++ b/qi-test/info.rkt @@ -6,5 +6,6 @@ (define build-deps '("rackunit-lib" "adjutor" "math-lib" - "qi-lib")) + "qi-lib" + "syntax-spec-v1")) (define clean '("compiled" "tests/compiled" "tests/private/compiled")) diff --git a/qi-test/tests/compiler.rkt b/qi-test/tests/compiler.rkt new file mode 100644 index 000000000..99a400d65 --- /dev/null +++ b/qi-test/tests/compiler.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +(provide tests) + +(require rackunit + rackunit/text-ui + (prefix-in semantics: "compiler/semantics.rkt") + (prefix-in rules: "compiler/rules.rkt") + (prefix-in util: "compiler/util.rkt")) + +(define tests + (test-suite + "compiler tests" + + semantics:tests + rules:tests + util:tests)) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/compiler/rules.rkt b/qi-test/tests/compiler/rules.rkt new file mode 100644 index 000000000..f033a5696 --- /dev/null +++ b/qi-test/tests/compiler/rules.rkt @@ -0,0 +1,526 @@ +#lang racket/base + +(provide tests) + +(require (for-template qi/flow/core/compiler + qi/flow/core/deforest) + rackunit + rackunit/text-ui + (only-in math sqr) + racket/string + (only-in racket/list + range) + syntax/parse/define) + +(define-syntax-parse-rule (test-normalize name a b ...+) + (begin + (test-equal? name + (syntax->datum + (normalize-pass a)) + (syntax->datum + (normalize-pass b))) + ...)) + +(define (deforested? exp) + (string-contains? (format "~a" exp) "cstream")) + + +(define tests + (test-suite + "Compiler rule tests" + + (test-suite + "deforestation" + ;; Note that these test deforestation in isolation + ;; without necessarily taking normalization (a preceding + ;; step in compilation) into account + + (test-suite + "general" + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-false (deforested? (syntax->datum + (deforest-rewrite + stx))) + "does not deforest single stream component in isolation")) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __) + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-false (deforested? (syntax->datum + (deforest-rewrite + stx))) + "does not deforest map in the head position")) + ;; (~>> values (filter odd?) (map sqr) values) + (let ([stx #'(thread + values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)) + values)]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "deforestation in arbitrary positions")) + (let ([stx #'(thread + values + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __)) + values)]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "deforestation in arbitrary positions"))) + + (test-suite + "transformers" + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "filter")) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (#%blanket-template + ((#%host-expression map) + (#%host-expression sqr) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "filter-map (two transformers)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression filter) + (#%host-expression odd?) + _)) + (#%fine-template + ((#%host-expression map) + (#%host-expression sqr) + _)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "fine-grained template forms"))) + + (test-suite + "producers" + (let ([stx #'(thread + (esc (#%host-expression range)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "range")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ 10)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ _ _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ _ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ 10 _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range _ 10 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 _ _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 _ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 _)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __ 10 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 __ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 1 __)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 10 __ 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range 0 __ 10 1)")) + (let ([stx #'(thread + (#%fine-template + ((#%host-expression range) + _ + _)) + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "(range __ 0 10 1)"))) + + (test-suite + "consumers" + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression odd?) + __)) + (esc (#%host-expression car)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "car")) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldl) + (#%host-expression string-append) + (#%host-expression "I") + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "foldl")) + (let ([stx #'(thread + (#%blanket-template + ((#%host-expression filter) + (#%host-expression string-upcase) + __)) + (#%blanket-template + ((#%host-expression foldr) + (#%host-expression string-append) + (#%host-expression "I") + __)))]) + (check-true (deforested? (syntax->datum + (deforest-rewrite + stx))) + "foldr")))) + + (test-suite + "normalization" + (test-normalize "pass-amp deforestation" + #'(thread + (pass f) + (amp g)) + #'(amp (if f g ground))) + (test-normalize "merge pass filters in sequence" + #'(thread (pass f) (pass g)) + #'(pass (and f g))) + (test-normalize "collapse deterministic conditionals" + #'(if #t f g) + #'f) + (test-normalize "collapse deterministic conditionals" + #'(if #f f g) + #'g) + (test-normalize "trivial threading is collapsed" + #'(thread f) + #'f) + (test-normalize "associative laws for ~>" + #'(thread f (thread g h) i) + #'(thread f g (thread h i)) + #'(thread (thread f g) h i) + #'(thread f g h i)) + (test-normalize "left and right identity for ~>" + #'(thread f _) + #'(thread _ f) + #'f) + + (test-normalize "line composition of identity flows" + #'(thread _ _ _) + #'(thread _ _) + #'(thread _) + #'_) + (test-normalize "amp under identity" + #'(amp _) + #'_) + (test-normalize "trivial tee junction" + #'(tee f) + #'f) + (test-normalize "merge adjacent gens in a tee junction" + #'(tee (gen a b) (gen c d)) + #'(tee (gen a b c d))) + (test-normalize "remove dead gen in a line" + #'(thread (gen a b) (gen c d)) + #'(thread (gen c d))) + (test-normalize "prism identities" + #'(thread collect sep) + #'_) + (test-normalize "redundant blanket template" + #'(#%blanket-template (f __)) + #'f) + ;; (test-normalize "values is collapsed inside ~>" + ;; #'(thread values f values) + ;; #'(thread f)) + (test-normalize "_ is collapsed inside ~>" + #'(thread _ f _) + #'(thread f))) + + (test-suite + "compilation sequences" + null))) + +(module+ main + (void (run-tests tests))) diff --git a/qi-test/tests/compiler/semantics.rkt b/qi-test/tests/compiler/semantics.rkt new file mode 100644 index 000000000..1663bae6d --- /dev/null +++ b/qi-test/tests/compiler/semantics.rkt @@ -0,0 +1,150 @@ +#lang racket/base + +(provide tests) + +(require qi + rackunit + rackunit/text-ui + (only-in math sqr) + (only-in racket/list range) + racket/function) + +(define tests + (test-suite + "Compiler preserves semantics" + + (test-suite + "deforestation" + (check-equal? ((☯ (~>> (filter odd?) (map sqr))) + (list 1 2 3 4 5)) + (list 1 9 25)) + (check-exn exn:fail? + (thunk + ((☯ (~> (map sqr) (map sqr))) + (list 1 2 3 4 5))) + "(map) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~> (filter odd?) (filter odd?))) + (list 1 2 3 4 5))) + "(filter) doforestation should only be done for right threading") + (check-exn exn:fail? + (thunk + ((☯ (~>> (filter odd?) (~> (foldr + 0)))) + (list 1 2 3 4 5))) + "(foldr) doforestation should only be done for right threading") + (check-equal? ((☯ (~>> values (filter odd?) (map sqr) values)) + (list 1 2 3 4 5)) + (list 1 9 25) + "optimizes subexpressions") + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldr + 0))) + (list 1 2 3 4 5)) + 35) + (check-equal? ((☯ (~>> (filter odd?) (map sqr) (foldl + 0))) + (list 1 2 3 4 5)) + 35) + (check-equal? ((☯ (~>> (map string-upcase) (foldr string-append "I"))) + (list "a" "b" "c")) + "ABCI") + (check-equal? ((☯ (~>> (map string-upcase) (foldl string-append "I"))) + (list "a" "b" "c")) + "CBAI") + (check-equal? ((☯ (~>> (range 10) (map sqr) car))) + 0) + (test-suite + "range (stream producer)" + ;; Semantic tests of the range producer that cover all combinations: + (test-equal? "~>>range [1-3] (10)" + (~>> (10) range (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>range [1-3] (10)" + (~> (10) range (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> range [1-3] (5 10)" + (~>> (5 10) range (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> range [1-3] (5 10)" + (~> (5 10) range (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> range [1-3] (5 10 3)" + (~>> (5 10 3) range (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> range [1-3] (5 10 3)" + (~> (5 10 3) range (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 10) [0-2] ()" + (~>> () (range 10) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~> (range 10) [0-2] ()" + (~> () (range 10) (~>> (filter odd?) (map sqr))) + '(1 9 25 49 81)) + (test-equal? "~>> (range 5) [0-2] (10)" + (~>> (10) (range 5) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 10) [0-2] (5)" + (~> (5) (range 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 3) [0-2] (5 10)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 5) [0-2] (10 3)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 5 10) [0-1] ()" + (~>> () (range 5 10) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~> (range 5 10) [0-1] ()" + (~> () (range 5 10) (~>> (filter odd?) (map sqr))) + '(25 49 81)) + (test-equal? "~>> (range 5 10) [0-1] (3)" + (~>> (3) (range 5 10) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~> (range 10 3) [0-1] (5)" + (~> (5) (range 10 3) (~>> (filter odd?) (map sqr))) + '(25)) + + (test-equal? "~>> (range 5 10 3) [0] ()" + (~>> () (range 5 10 3) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range _) [1] (10)" + (~>> (10) (range _) (filter odd?) (map sqr)) + '(1 9 25 49 81)) + (test-equal? "~>> (range _ _) [2] (5 10)" + (~>> (5 10) (range _ _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ _ _) [3] (5 10 3)" + (~>> (5 10 3) (range _ _ _) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 _) [1] (10)" + (~>> (10) (range 5 _) (filter odd?) (map sqr)) + '(25 49 81)) + (test-equal? "~>> (range _ 10) [1] (5)" + (~>> (5) (range _ 10) (filter odd?) (map sqr)) + '(25 49 81)) + + (test-equal? "~>> (range 5 _ _) [2] (10 3)" + (~>> (10 3) (range 5 _ _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 _) [2] (5 3)" + (~>> (5 3) (range _ 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ _ 3) [2] (5 10)" + (~>> (5 10) (range _ _ 3) (filter odd?) (map sqr)) + '(25)) + + (test-equal? "~>> (range 5 10 _) [1] (3)" + (~>> (3) (range 5 10 _) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range 5 _ 3) [1] (10)" + (~>> (10) (range 5 _ 3) (filter odd?) (map sqr)) + '(25)) + (test-equal? "~>> (range _ 10 3) [1] (5)" + (~>> (5) (range _ 10 3) (filter odd?) (map sqr)) + '(25)))))) + +(module+ main + (void (run-tests tests))) diff --git a/qi-test/tests/compiler/util.rkt b/qi-test/tests/compiler/util.rkt new file mode 100644 index 000000000..645469835 --- /dev/null +++ b/qi-test/tests/compiler/util.rkt @@ -0,0 +1,82 @@ +#lang racket/base + +(provide tests) + +(require qi/flow/core/util + rackunit + rackunit/text-ui + syntax/parse + (only-in racket/function + curryr)) + +(define-syntax-rule (test-syntax-equal? name a b) + (test-equal? name + (syntax->datum a) + (syntax->datum b))) + +(define tests + (test-suite + "Compiler utilities tests" + + (test-suite + "fixed point" + (check-equal? ((fix abs) -1) 1) + (check-equal? ((fix abs) -1) 1) + (let ([integer-div2 (compose floor (curryr / 2))]) + (check-equal? ((fix integer-div2) 10) + 0))) + (test-suite + "find-and-map/qi" + (test-syntax-equal? "top level" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a b c)) + #'(a q c)) + (test-syntax-equal? "nested" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a (b c) d)) + #'(a (q c) d)) + (test-syntax-equal? "multiple matches" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a b c b d)) + #'(a q c q d)) + (test-syntax-equal? "multiple nested matches" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a (b c) (b d))) + #'(a (q c) (q d))) + (test-syntax-equal? "no match" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a c d)) + #'(a c d)) + ;; TODO: review this, it does not transform multi-level matches. + ;; Are there cases where we would need this? + (test-syntax-equal? "matches at muliple levels" + (find-and-map/qi + (syntax-parser [((~datum a) b ...) #'(b ...)] + [_ #f]) + #'(a c (a d e))) + #'(c (a d e))) + (test-syntax-equal? "does not enter host expressions" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(a (#%host-expression (b c)) d)) + #'(a (#%host-expression (b c)) d)) + (test-syntax-equal? "toplevel host expression" + (find-and-map/qi + (syntax-parser [(~datum b) #'q] + [_ #f]) + #'(#%host-expression (b c))) + #'(#%host-expression (b c)))))) + +(module+ main + (void (run-tests tests))) diff --git a/qi-test/tests/expander.rkt b/qi-test/tests/expander.rkt new file mode 100644 index 000000000..272e81a5b --- /dev/null +++ b/qi-test/tests/expander.rkt @@ -0,0 +1,103 @@ +#lang racket/base + +(provide tests) + +(require (for-syntax racket/base + qi/flow/extended/syntax) + syntax/macro-testing + syntax-spec-v1 + racket/base + qi/flow/extended/expander + rackunit + rackunit/text-ui) + +(begin-for-syntax + (define (expand-flow stx) + ((nonterminal-expander closed-floe) stx))) + +;; TODO: these tests compare syntax as datums, but that's not sufficient +;; since the identifiers used may be bound differently which would affect +;; e.g. literal pattern matching. +;; To do it correctly, we need an alpha-equivalence predicate for Core Qi +;; that possibly delegates to a similar predicate for any Racket +;; subexpressions. This could be a predicate that syntax-spec could +;; infer, but it's unclear at this time. +(define tests + (test-suite + "expander tests" + + (test-true "basic expansion" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(~> sqr add1))) + '(thread (esc (#%host-expression sqr)) + (esc (#%host-expression add1)))))) + + (test-true "single core form (if)" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(if p c a))) + '(if (esc (#%host-expression p)) + (esc (#%host-expression c)) + (esc (#%host-expression a)))))) + + (test-true "mix of core forms" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(thread (amp a) + (relay b c) + (tee d e)))) + '(thread + (amp (esc (#%host-expression a))) + (relay (esc (#%host-expression b)) (esc (#%host-expression c))) + (tee (esc (#%host-expression d)) (esc (#%host-expression e))))))) + + (test-true "undecorated functions are escaped" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'f)) + '(esc (#%host-expression f))))) + + (test-true "literal is expanded to an explicit use of the gen core form" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'5)) + '(gen (#%host-expression 5))))) + + (test-true "fine template syntax expands to an explicit use of the #%fine-template core form" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(f _ a _ b))) + '(#%fine-template + ((#%host-expression f) + _ + (#%host-expression a) + _ + (#%host-expression b)))))) + + (test-true "blanket template syntax expands to an explicit use of the #%blanket-template core form" + (phase1-eval + (equal? (syntax->datum + (expand-flow #'(f a __ b))) + '(#%blanket-template + ((#%host-expression f) + (#%host-expression a) + __ + (#%host-expression b)))))) + + (test-true "expand chiral forms to a use of a blanket template" + (phase1-eval + (equal? (syntax->datum + (expand-flow + (datum->syntax #f + (map make-right-chiral + (syntax->list + #'(thread (f 1))))))) + '(thread (#%blanket-template + ((#%host-expression f) + (#%host-expression 1) + __)))))))) + +(module+ main + (void + (run-tests tests))) diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt index d61280422..dca0f75b7 100644 --- a/qi-test/tests/flow.rkt +++ b/qi-test/tests/flow.rkt @@ -10,7 +10,10 @@ racket/list racket/string racket/function - "private/util.rkt") + racket/format + (except-in "private/util.rkt" + add-two) + syntax/macro-testing) ;; used in the "language extension" tests for `qi:*` (define-syntax-rule (qi:square flo) @@ -31,9 +34,18 @@ (check-equal? (values->list ((☯))) null "empty flow with no inputs") (check-equal? ((☯) 0) 0 "empty flow with one input") (check-equal? (values->list ((☯) 1 2)) (list 1 2) "empty flow with multiple inputs") - (check-equal? ((☯ (const 3))) 3 "no arguments") + (check-equal? ((☯ (+ 3))) 3 "partial application with no runtime arguments") (check-equal? ((flow add1) 2) 3 "simple function") - (check-equal? ((flow (get-f 1)) 2) 3 "fully qualified function") + (check-exn exn:fail:contract? + (thunk ((flow (get-f 1)) 2)) + "fully qualified function is still treated as a partial application") + ;; As this is a syntax error, it can't be written as a unit test + ;; (check-exn exn:fail:contract? + ;; (thunk (flow (get-f))) + ;; "empty partial application isn't allowed") + (check-equal? ((flow (esc (get-f 1))) 2) + 3 + "fully qualified function used as a flow must still use esc") (check-equal? ((flow _) 5) 5 "identity flow") (check-equal? ((flow (~> _ ▽)) 5 6) (list 5 6) "identity flow")) (test-suite @@ -44,7 +56,13 @@ (check-equal? ((flow #"hi") 5) #"hi" "literal byte string") (check-equal? ((flow #px"hi") 5) #px"hi" "literal regexp") (check-equal? ((flow #rx"hi") 5) #rx"hi" "literal regexp") + (check-equal? ((flow #px#"hi") 5) #px#"hi" "bytestring literal regexp") + (check-equal? ((flow #rx#"hi") 5) #rx#"hi" "bytestring literal regexp") (check-equal? ((flow 'hi) 5) 'hi "literal symbol") + (check-equal? ((flow #(1 2 3)) 2) #(1 2 3) "literal vector") + (check-equal? ((flow #&3) 2) #&3 "literal box") + (check-equal? ((flow #&(1 2 3)) 2) #&(1 2 3) "literal collection in a box") + (check-equal? ((flow #s(dog "Fido")) 2) #s(dog "Fido") "literal prefab") (check-equal? ((flow '(+ 1 2)) 5) '(+ 1 2) "literal quoted list") (check-equal? ((flow `(+ 1 ,(* 2 3))) 5) '(+ 1 6) "literal quasiquoted list") (check-equal? (syntax->datum ((flow #'(+ 1 2)) 5)) '(+ 1 2) "Literal syntax quoted list")) @@ -109,7 +127,7 @@ (check-true ((☯ (and positive? (or integer? odd?))) - 5)) + 5)) (check-false ((☯ (and positive? (or (> 6) even?))) @@ -183,19 +201,19 @@ (test-suite "all?" (check-true ((☯ all?)) "design: should this produce no values instead?") - (check-true ((☯ all?) 3)) - (check-false ((☯ all?) #f)) - (check-true ((☯ all?) 3 5 7)) - (check-false ((☯ all?) 3 #f 5))) + (check-equal? ((☯ all?) 3) 3) + (check-equal? ((☯ all?) #f) #f) + (check-equal? ((☯ all?) 3 5 7) 7) + (check-equal? ((☯ all?) 3 #f 5) #f)) (test-suite "any?" (check-false ((☯ any?)) "design: should this produce no values instead?") - (check-true ((☯ any?) 3)) - (check-false ((☯ any?) #f)) - (check-true ((☯ any?) 3 5 7)) - (check-true ((☯ any?) 3 #f 5)) - (check-true ((☯ any?) #f #f 5)) - (check-false ((☯ any?) #f #f #f))) + (check-equal? ((☯ any?) 3) 3) + (check-equal? ((☯ any?) #f) #f) + (check-equal? ((☯ any?) 3 5 7) 3) + (check-equal? ((☯ any?) 3 #f 5) 3) + (check-equal? ((☯ any?) #f #f 5) 5) + (check-equal? ((☯ any?) #f #f #f) #f)) (test-suite "none?" (check-false ((☯ none?) 3)) @@ -254,6 +272,8 @@ (list 3 4 5))) (test-suite "escape hatch" + (check-equal? ((☯ (esc add1)) 2) 3) + (check-equal? ((☯ (esc (const 3)))) 3) (check-equal? ((☯ (esc (first (list + *)))) 3 7) 10 "normal racket expressions")) @@ -261,20 +281,20 @@ "elementary boolean gates" (test-suite "AND" - (check-false ((☯ AND) #f)) - (check-true ((☯ AND) 3)) - (check-true ((☯ AND) 3 5 7)) - (check-false ((☯ AND) 3 #f 5)) - (check-false ((☯ AND) #f #f 5)) - (check-false ((☯ AND) #f #f #f))) + (check-equal? ((☯ AND) #f) #f) + (check-equal? ((☯ AND) 3) 3) + (check-equal? ((☯ AND) 3 5 7) 7) + (check-equal? ((☯ AND) 3 #f 5) #f) + (check-equal? ((☯ AND) #f #f 5) #f) + (check-equal? ((☯ AND) #f #f #f) #f)) (test-suite "OR" - (check-false ((☯ OR) #f)) - (check-true ((☯ OR) 3)) - (check-true ((☯ OR) 3 5 7)) - (check-true ((☯ OR) 3 #f 5)) - (check-true ((☯ OR) #f #f 5)) - (check-false ((☯ OR) #f #f #f))) + (check-equal? ((☯ OR) #f) #f) + (check-equal? ((☯ OR) 3) 3) + (check-equal? ((☯ OR) 3 5 7) 3) + (check-equal? ((☯ OR) 3 #f 5) 3) + (check-equal? ((☯ OR) #f #f 5) 5) + (check-equal? ((☯ OR) #f #f #f) #f)) (test-suite "NOT" (check-false ((☯ NOT) 3)) @@ -329,10 +349,118 @@ (check-equal? ((☯ (~> ▽ △ string-append)) "a" "b" "c") "abc")))) + (test-suite + "bindings" + (check-equal? ((☯ (~> (as v) (+ v))) 3) + 3 + "binds a single value") + (check-equal? ((☯ (~> (as v w) (+ v w))) 3 4) + 7 + "binds multiple values") + (check-false ((☯ (~> (as v) live?)) 3) + "binding does not propagate the value") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 _ v))) 3) + 9 + "reference in a fine template") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 __ v))) 3) + 9 + "reference in a blanket template") + (check-equal? ((☯ (~> (-< (as v) + _) (+ 3 v))) 3) + 9 + "reference in a left-chiral partial application") + (check-equal? ((☯ (~>> (-< (as v) + _) (+ 3 v))) 3) + 9 + "reference in a right-chiral partial application") + (check-equal? ((☯ (~> (-< (~> list (as vs)) + +) + (~a "The sum of " vs " is " _))) + 1 2) + "The sum of (1 2) is 3" + "bindings are scoped to the outermost threading form") + (check-equal? ((☯ (~> (-< sqr (~> list (as S))) + (-< add1 (~>> list (append S) (as S))) + (-< _ (~>> list (append S) (as S))) + (list S))) + 5) + (list 26 (list 5 25 26)) + "binding to accumulate state") + (check-equal? ((☯ (~> (ε (as args)) (append args))) + (list 1 2 3)) + (list 1 2 3 1 2 3) + "idiom: bind as a side effect") + (check-equal? ((☯ (~> (as n) 5 (feedback n add1))) + 3) + 8 + "using a bound value in a flow specification") + (check-equal? ((☯ (~> (== (as n) _) sqr (+ n))) + 3 5) + 28 + "binding some but not all values using a relay") + (check-equal? (map (☯ (~> (as n) (+ n n))) + (list 1 3 5)) + (list 2 6 10) + "binding arguments without a lambda") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> sqr (list v) (as v) (gen v))) 3))) + "bindings cannot be referenced before being assigned") + (check-equal? ((☯ (~> (-< (as v) + (gen v)))) + 3) + 3 + "tee junction tines bind succeeding peers") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (-< (gen v) + (as v)))) + 3))) + "tee junction tines don't bind preceding peers") + (check-equal? ((☯ (switch [(~> sqr (ε (as v) #t)) + (gen v)])) + 3) + 9 + "switch conditions bind clauses") + (check-equal? ((☯ (switch + [(~> sqr (ε (as v) #f)) + (gen v)] + [(~> add1 (ε (as v) #t)) + (gen v)])) + 3) + 4 + "bindings in switch conditions shadow earlier conditions") + (check-exn exn:fail? + (thunk + (convert-compile-time-error + ((☯ (~> (switch [(~> sqr (ε (as v) #t)) + 0]) + (gen v))) + 3))) + "switch does not bind downstream") + (check-exn exn:fail? + (thunk (convert-compile-time-error + ((☯ (~> (or (ε (as v)) 5) (+ v))) + 3))) + "error is raised if identifier is not guaranteed to be bound downstream") + (let ([as (lambda (v) v)]) + (check-equal? ((☯ (~> (gen (as 3))))) + 3 + "Racket functions named `as` aren't clobbered") + (check-equal? ((☯ (~> (esc (lambda (v) (as v))))) 3) + 3 + "Racket functions named `as` aren't clobbered"))) + (test-suite "routing forms" (test-suite "~>" + (test-equal? "basic threading" + ((☯ (~> sqr add1)) + 3) + 10) (check-equal? ((☯ (~> add1 (* 2) number->string @@ -362,6 +490,10 @@ "p" "q") "pabqab" "threading without template") + (check-equal? ((☯ (~> (sort 3 1 2 #:key sqr))) + <) + (list 1 4 9) + "pre-supplied keyword arguments with left chirality") (check-equal? ((☯ (thread add1 (* 2) number->string @@ -395,14 +527,10 @@ "p" "q") "abpq" "right-threading without template") - (check-equal? ((☯ (~>> △ (sort < #:key identity))) + (check-equal? ((☯ (~>> △ (sort < #:key sqr))) (list 2 1 3)) - (list 1 2 3) - "right-threading with keyword arg pre-supplied") - (check-equal? ((☯ (~>> (sort <))) - #:key identity 2 1 3) - (list 1 2 3) - "right-threading with keyword arg at invocation time") + (list 1 4 9) + "pre-supplied keyword arguments with right chirality") ;; TODO: propagate threading side to nested clauses ;; (check-equal? (on ("p" "q") ;; (~>> (>< (string-append "a" "b")) @@ -428,6 +556,9 @@ "a")) (test-suite "-<" + (check-equal? ((☯ (~> -< ▽)) + 3 1 2) + (list 1 2 1 2 1 2)) (check-equal? ((☯ (~> (-< sqr add1) ▽)) 5) (list 25 6)) @@ -488,6 +619,9 @@ (thunk ((☯ (~> (== ⏚ add1) ▽)) 5 7 8)) "relay elements must be in one-to-one correspondence with input") + (check-equal? ((☯ (~> (gen sqr 1 2 3) == ▽))) + (list 1 4 9) + "relay when used as an identifier") ; TODO: review this (check-equal? ((☯ (~> (relay sqr add1) ▽)) 5 7) (list 25 8) @@ -578,10 +712,13 @@ (list "a" "b" "c")) "cba" "curried foldl") - (check-exn exn:fail? - (thunk ((☯ (+)) - 5 7 8)) - "function isn't curried when no arguments are provided")) + (check-equal? (((☯ (const 3)))) 3 "partial application with no arguments") + ;; As this is now a syntax error, it can't be written as a unit test + ;; (check-exn exn:fail? + ;; (thunk ((☯ (+)) + ;; 5 7 8)) + ;; "function isn't curried when no arguments are provided") + ) (test-suite "blanket template" (check-equal? ((☯ (+ __))) 0) @@ -593,9 +730,21 @@ "abc") (check-equal? ((☯ (string-append __ "c")) "a" "b") - "abc")) - (test-suite - "template with single argument" + "abc") + (check-equal? ((☯ (sort __ 1 2 #:key sqr)) + < 3) + (list 1 4 9) + "keyword arguments in a left chiral blanket template") + (check-equal? ((☯ (sort < 3 #:key sqr __)) + 1 2) + (list 1 4 9) + "keyword arguments in a right chiral blanket template") + (check-equal? ((☯ (sort < __ #:key sqr)) + 3 1 2) + (list 1 4 9) + "keyword arguments in a vindaloo blanket template")) + (test-suite + "fine template with single argument" (check-false ((☯ (apply > _)) (list 1 2 3))) (check-true ((☯ (apply > _)) @@ -614,13 +763,21 @@ (check-equal? ((☯ (foldl string-append "" _)) (list "a" "b" "c")) "cba" - "foldl in predicate")) + "foldl in predicate") + (check-equal? ((☯ (sort < 3 _ 2 #:key sqr)) + 1) + (list 1 4 9) + "keyword arguments in a fine template")) (test-suite - "template with multiple arguments" + "fine template with multiple arguments" (check-true ((☯ (< 1 _ 5 _ 10)) 3 7) "template with multiple arguments") (check-false ((☯ (< 1 _ 5 _ 10)) 3 5) - "template with multiple arguments")) + "template with multiple arguments") + (check-equal? ((☯ (sort < _ _ 2 #:key sqr)) + 3 1) + (list 1 4 9) + "keyword arguments in a fine template")) (test-suite "templating behavior is contained to intentional template syntax" (check-exn exn:fail:syntax? @@ -830,13 +987,13 @@ "short-circuiting")) (test-suite "sieve" - (check-equal? ((☯ (~> (sieve positive? add1 (const -1)) ▽)) + (check-equal? ((☯ (~> (sieve positive? add1 (gen -1)) ▽)) 1 -2) (list 2 -1)) (check-equal? ((☯ (~> (sieve positive? + (+ 2)) ▽)) 1 2 -3 4) (list 7 -1)) - (check-equal? ((☯ (~> (sieve positive? + (const 0)) ▽)) + (check-equal? ((☯ (~> (sieve positive? + (gen 0)) ▽)) 1 2 3 4) (list 10 0)) (check-equal? ((☯ (~> (sieve negative? ⏚ ⏚) ▽)) @@ -851,37 +1008,37 @@ 1 -3 5) (list 1 1 5 5 -3) "sieve with arity-increasing clause") - (check-equal? (~> (1 2 -3 4) - (-< (gen positive? + (☯ (+ 2))) _) - sieve - ▽) + (check-equal? ((☯ (~> (-< (gen positive? + (☯ (+ 2))) _) + sieve + ▽)) + 1 2 -3 4) (list 7 -1) "pure control form of sieve")) (test-suite - "partition" - (check-equal? ((flow (~> (partition) collect))) - (list) - "base partition case") - (check-equal? ((flow (partition [positive? +])) - -1 2 1 1 -2 2) - 6 - "partition composes ~> and pass") - (check-equal? ((flow (~> (partition [positive? +] - [zero? (-< count (gen "zero"))] - [negative? *]) collect)) - -1 0 2 1 1 -2 0 0 2) - (list 6 3 "zero" 2)) - (check-equal? ((flow (~> (partition [positive? +] - [zero? (-< count (gen "zero"))] - [negative? *]) collect)) - -1 2 1 1 -2 2) - (list 6 0 "zero" 2) - "some partition bodies have no inputs") - (check-equal? ((flow (~> (partition [(and positive? (> 1)) +] - [_ list]) collect)) - -1 2 1 1 -2 2) - (list 4 (list -1 1 1 -2)) - "partition bodies can be flows")) + "partition" + (check-equal? ((flow (~> (partition) collect))) + (list) + "base partition case") + (check-equal? ((flow (partition [positive? +])) + -1 2 1 1 -2 2) + 6 + "partition composes ~> and pass") + (check-equal? ((flow (~> (partition [positive? +] + [zero? (-< count (gen "zero"))] + [negative? *]) collect)) + -1 0 2 1 1 -2 0 0 2) + (list 6 3 "zero" 2)) + (check-equal? ((flow (~> (partition [positive? +] + [zero? (-< count (gen "zero"))] + [negative? *]) collect)) + -1 2 1 1 -2 2) + (list 6 0 "zero" 2) + "some partition bodies have no inputs") + (check-equal? ((flow (~> (partition [(and positive? (> 1)) +] + [_ list]) collect)) + -1 2 1 1 -2 2) + (list 4 (list -1 1 1 -2)) + "partition bodies can be flows")) (test-suite "gate" (check-equal? ((☯ (gate positive?)) @@ -927,31 +1084,32 @@ 9)) (test-suite "fanout" - (check-equal? (~> (5) (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽)) + 5) (list 5 5 5)) - (check-equal? (~> (2 3) (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽)) 2 3) (list 2 3 2 3 2 3)) - (check-equal? (~> (3 "a") fanout string-append) + (check-equal? ((☯ (~> fanout string-append)) 3 "a") "aaa" "control form of fanout") - (check-equal? (~> (3 "a" "b") fanout string-append) + (check-equal? ((☯ (~> fanout string-append)) 3 "a" "b") "ababab" "control form of fanout") - (check-equal? (~> (5) (fanout (add1 2)) ▽) + (check-equal? ((☯ (~> (fanout (add1 2)) ▽)) 5) (list 5 5 5) "arbitrary racket expressions and not just literals") (check-equal? (let ([n 3]) - (~> (5) (fanout n) ▽)) + ((☯ (~> (fanout n) ▽)) 5)) (list 5 5 5) "arbitrary racket expressions and not just literals") - (check-equal? (~> (2 3) (fanout 0) ▽) + (check-equal? ((☯ (~> (fanout 0) ▽)) 2 3) null "N=0 produces no values.") - (check-equal? (~> () (fanout 3) ▽) + (check-equal? ((☯ (~> (fanout 3) ▽))) null "No inputs produces no outputs.") (check-exn exn:fail:contract? - (thunk (~> (-1 3) fanout ▽)) + (thunk ((☯ (~> fanout ▽)) -1 3)) "Negative N signals an error.")) (test-suite "inverter" @@ -967,7 +1125,7 @@ 5) 625 "(feedback N flo)") - (check-equal? (~> (3 5) (feedback add1)) + (check-equal? ((☯ (~> (feedback add1))) 3 5) 8 "(feedback flo) consumes the first input as N") (check-equal? ((☯ (feedback 5 (then sqr) add1)) @@ -1011,7 +1169,7 @@ "pure control form of feedback")) (test-suite "group" - (check-equal? ((☯ (~> (group 0 (const 5) +) ▽)) + (check-equal? ((☯ (~> (group 0 (gen 5) +) ▽)) 1 2) (list 5 3)) (check-equal? ((☯ (~> (group 1 add1 sub1) ▽)) @@ -1165,16 +1323,16 @@ (check-true ((☯ live?) 3 4 5)) (check-true ((☯ live?) 5)) (check-false ((☯ live?))) - (check-true (~> (1 2) live?)) - (check-false (~> (1 2) ⏚ live?))) + (check-true ((☯ (~> live?)) 1 2)) + (check-false ((☯ (~> ⏚ live?)) 1 2))) (test-suite "rectify" - (check-equal? (~> (3 4 5) (rectify 'boo) ▽) (list 3 4 5)) - (check-equal? (~> (5) (rectify 'boo)) 5) - (check-equal? (~> () (rectify 'boo)) 'boo) - (check-equal? (~> (1 2) (rectify #f) ▽) (list 1 2)) - (check-equal? (~> (1 2) ⏚ (rectify #f)) #f))) + (check-equal? ((☯ (~> (rectify 'boo) ▽)) 3 4 5) (list 3 4 5)) + (check-equal? ((☯ (~> (rectify 'boo))) 5) 5) + (check-equal? ((☯ (~> (rectify 'boo)))) 'boo) + (check-equal? ((☯ (~> (rectify #f) ▽)) 1 2) (list 1 2)) + (check-equal? ((☯ (~> ⏚ (rectify #f))) 1 2) #f))) (test-suite "higher-order flows" @@ -1253,28 +1411,43 @@ sqr) ▽)) 1 2 3) (list 1 4 9)) - (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) - sqr - + - 0))) 1 2 3) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + sqr + + + 0)) 1 2 3) 14) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + (-< sqr sqr) + + + 0)) 1 2 3) + 28 + "loop with multi-valued map flow") (check-equal? ((☯ (~> (loop sqr) ▽)) 1 2 3) (list 1 4 9)) - (check-equal? ((☯ (~> (loop (~> ▽ (not null?)) - sqr - +))) 1 2 3) - 14)) + (check-equal? ((☯ (loop (~> ▽ (not null?)) + sqr + +)) 1 2 3) + 14) + (check-equal? ((☯ (~> (-< (gen (☯ (~> ▽ (not null?))) + sqr + + + (☯ 0)) + _) + loop)) + 1 2 3) + 14 + "identifier form of loop")) (test-suite "loop2" - (check-equal? ((☯ (~> (loop2 (~> 1> (not null?)) - sqr - cons))) + (check-equal? ((☯ (loop2 (~> 1> (not null?)) + sqr + cons)) (list 1 2 3) null) (list 9 4 1)) - (check-equal? ((☯ (~> (loop2 (~> 1> (not null?)) - sqr - +))) + (check-equal? ((☯ (loop2 (~> 1> (not null?)) + sqr + +)) (list 1 2 3) 0) 14)) @@ -1316,7 +1489,7 @@ "language extension" (test-suite "qi:" - (check-equal? (~> (2 3) + (qi:square sqr)) + (check-equal? ((☯ (~> + (qi:square sqr))) 2 3) 625))) (test-suite @@ -1375,7 +1548,64 @@ (check-equal? ((☯ (~> (pass positive?) +)) 1 -3 5) 6 - "runtime arity changes in threading form")))) + "runtime arity changes in threading form")) + + (test-suite + "nonlocal semantics" + ;; these are collected from counterexamples to candidate equivalences + ;; that turned up during code review. They ensure that some tempting + ;; "equivalences" that are not really equivalences are formally checked + (test-suite + "counterexamples" + (test-suite + "(~> (>< g) (pass f)) ─/→ (>< (~> g (if f _ ⏚)))" + (let () + (define-flow g (-< add1 sub1)) + (define-flow f positive?) + (define (f* x y) (= (sub1 x) (add1 y))) + (define (amp-pass g f) (☯ (~> (>< g) (pass f) ▽))) + (define (amp-if g f) (☯ (~> (>< (~> g (if f _ ground))) ▽))) + (test-equal? "amp-pass" + (apply (amp-pass g f) (range -3 4)) + (list 1 2 3 1 4 2)) + (test-exn "amp-pass" + exn:fail? + (thunk (apply (amp-pass g f*) (range -3 4)))) + (test-exn "amp-if" + exn:fail? + (thunk (apply (amp-if g f) (range -3 4)))) + (test-equal? "amp-if" + (apply (amp-if g f*) (range -3 4)) + (list -2 -4 -1 -3 0 -2 1 -1 2 0 3 1 4 2))) + (let () + (test-equal? "amp-pass" + ((☯ (~> (>< string->number) (pass _))) "a" "2" "c") + 2) + (test-equal? "amp-if" + ((☯ (~> (>< (if _ string->number ground)) ▽)) "a" "2" "c") + (list #f 2 #f)))) + (test-suite + "(~> (>< f) (>< g)) ─/→ (>< (~> f g))" + (test-equal? "amp-amp" + ((☯ (~> (>< (-< add1 sub1)) + (>< (-< sub1 add1)) + ▽)) + 3) + (list 3 5 1 3)) + (test-exn "merged amp" + exn:fail? + (thunk + ((☯ (>< (~> (-< add1 sub1) + (-< sub1 add1)))) + 3)))) + (test-suite + "(~> (== _ ...)) ─/→ _" + (test-exn "relay-_" + exn:fail? + (thunk + ((☯ (== _ _ _)) + 3))) + (test-equal? "relay-_" ((☯ _) 3) 3)))))) (module+ main (void (run-tests tests))) diff --git a/qi-test/tests/macro.rkt b/qi-test/tests/macro.rkt index 252bc6f97..a7a80df95 100644 --- a/qi-test/tests/macro.rkt +++ b/qi-test/tests/macro.rkt @@ -7,8 +7,7 @@ rackunit/text-ui (only-in math sqr) (only-in racket/function thunk) - (for-syntax syntax/parse - racket/base) + (for-syntax racket/base) syntax/parse/define "private/util.rkt") diff --git a/qi-test/tests/on.rkt b/qi-test/tests/on.rkt index cf08c6087..0fec5949f 100644 --- a/qi-test/tests/on.rkt +++ b/qi-test/tests/on.rkt @@ -6,8 +6,7 @@ rackunit rackunit/text-ui (only-in math sqr) - (only-in adjutor values->list) - racket/function) + (only-in adjutor values->list)) (define tests (test-suite @@ -21,7 +20,7 @@ (list 5 5) "no clauses, binary") (check-equal? (on () - (const 3)) + (gen 3)) 3 "no arguments")) (test-suite diff --git a/qi-test/tests/qi.rkt b/qi-test/tests/qi.rkt index 3b4705089..b471eb901 100644 --- a/qi-test/tests/qi.rkt +++ b/qi-test/tests/qi.rkt @@ -9,7 +9,8 @@ (prefix-in definitions: "definitions.rkt") (prefix-in macro: "macro.rkt") (prefix-in util: "util.rkt") - "private/util.rkt") + (prefix-in expander: "expander.rkt") + (prefix-in compiler: "compiler.rkt")) (define tests (test-suite @@ -21,7 +22,9 @@ threading:tests definitions:tests macro:tests - util:tests)) + util:tests + expander:tests + compiler:tests)) (module+ test (void diff --git a/qi-test/tests/threading.rkt b/qi-test/tests/threading.rkt index f1489b9d2..1af68e1ec 100644 --- a/qi-test/tests/threading.rkt +++ b/qi-test/tests/threading.rkt @@ -6,8 +6,7 @@ rackunit rackunit/text-ui (only-in math sqr) - (only-in adjutor values->list) - racket/function) + (only-in adjutor values->list)) (define tests (test-suite @@ -16,8 +15,8 @@ "Edge/base cases" (check-equal? (values->list (~> ())) null) (check-equal? (values->list (~>> ())) null) - (check-equal? (~> () (const 5)) 5) - (check-equal? (~>> () (const 5)) 5) + (check-equal? (~> () (gen 5)) 5) + (check-equal? (~>> () (gen 5)) 5) (check-equal? (~> (4)) 4) (check-equal? (~>> (4)) 4) (check-equal? (values->list (~> (4 5 6))) '(4 5 6)) diff --git a/qi-test/tests/util.rkt b/qi-test/tests/util.rkt index c3fd81232..9e0510a9c 100644 --- a/qi-test/tests/util.rkt +++ b/qi-test/tests/util.rkt @@ -14,12 +14,11 @@ (test-suite "report-syntax-error" (check-exn exn:fail:syntax? - (thunk (report-syntax-error 'dummy - (list 1 2 3) - "blah: blah" - "Use it" - "like" - "this")))))) + (thunk (report-syntax-error #'(dummy 1 2 3) + "blah: blah" + "Use it" + "like" + "this")))))) (module+ main (void (run-tests tests)))