Skip to content

Commit

Permalink
fix compiler tests by adding chirality
Browse files Browse the repository at this point in the history
  • Loading branch information
@countvajhula
countvajhula committed Oct 1, 2023
1 parent 17c3bc5 commit 7f67806
Show file tree
Hide file tree
Showing 5 changed files with 89 additions and 73 deletions.
5 changes: 4 additions & 1 deletion Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -124,6 +124,9 @@ test-macro:
test-util:
racket -y $(PACKAGE-NAME)-test/tests/util.rkt

test-compiler:
racket -y $(PACKAGE-NAME)-test/tests/compiler.rkt

test-probe:
raco test -exp $(PACKAGE-NAME)-probe

Expand Down Expand Up @@ -193,4 +196,4 @@ performance-report:
performance-regression-report:
@racket $(PACKAGE-NAME)-sdk/profile/report.rkt -r $(REF)

.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report
.PHONY: help install remove build build-docs build-all clean check-deps test test-flow test-on test-threading test-switch test-definitions test-macro test-util test-compiler test-probe test-with-errortrace errortrace errortrace-flow errortrace-on errortrace-threading errortrace-switch errortrace-definitions errortrace-macro errortrace-util errortrace-probe docs cover coverage-check coverage-report cover-coveralls profile-local profile-loading profile-selected-forms profile-competitive profile-nonlocal profile performance-report performance-regression-report
4 changes: 2 additions & 2 deletions qi-lib/flow/core/compiler.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -161,7 +161,7 @@
[((~datum thread) _0:non-fusable ... f:fusable-list-operation ...+ _1 ...)
#:with fused (generate-fused-operation (syntax->list #'(f ...)))
#'(thread _0 ... fused _1 ...)]
[_ #f]))
[_ this-syntax]))

(define ((fix f) init-val)
;; may need to be modified to handle #f as a special terminator
Expand All @@ -174,7 +174,7 @@
;; Note: deforestation happens only for threading,
;; and the normalize pass strips the threading form
;; if it contains only one expression, so this would not be hit.
(find-and-map/qi deforest-rewrite
(find-and-map/qi (fix deforest-rewrite)
stx))

(define (normalize-pass stx)
Expand Down
3 changes: 2 additions & 1 deletion qi-lib/flow/extended/syntax.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,8 @@
blanket-template-form
fine-template-form
partial-application-form
any-stx)
any-stx
make-right-chiral)

(require syntax/parse
"../aux-syntax.rkt"
Expand Down
144 changes: 77 additions & 67 deletions qi-test/tests/compiler.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,8 @@
(provide tests)

(require (for-template qi/flow/core/compiler)
(only-in qi/flow/extended/syntax
make-right-chiral)
rackunit
rackunit/text-ui
(only-in math sqr))
Expand All @@ -14,73 +16,81 @@
(test-suite
"deforestation"
;; (~>> values (filter odd?) (map sqr) values)
(check-equal? (syntax->datum
(deforest-rewrite
#'(thread (#%partial-application
((#%host-expression filter)
(#%host-expression odd?))))))
'(thread
(esc
(λ (lst)
((cstream->list (inline-compose1 (filter-cstream-next odd?) list->cstream-next)) lst))))
"deforestation of map -- note this tests the rule in isolation; with normalization this would never be necessary")
(check-equal? (syntax->datum
(deforest-rewrite
#'(thread (#%partial-application
((#%host-expression map)
(#%host-expression sqr))))))
'(thread
(esc
(λ (lst)
((cstream->list (inline-compose1 (map-cstream-next sqr) list->cstream-next)) lst))))
"deforestation of filter -- note this tests the rule in isolation; with normalization this would never be necessary")
(check-equal? (syntax->datum
(deforest-rewrite
#'(thread values
(#%partial-application
((#%host-expression filter)
(#%host-expression odd?)))
(#%partial-application
((#%host-expression map)
(#%host-expression sqr)))
values)))
'(thread
values
(esc
(λ (lst)
((cstream->list
(inline-compose1
(map-cstream-next
sqr)
(filter-cstream-next
odd?)
list->cstream-next))
lst)))
values)
"deforestation in arbitrary positions")
(check-equal? (syntax->datum
(deforest-rewrite
#'(thread (#%partial-application
((#%host-expression map)
(#%host-expression string-upcase)))
(#%partial-application
((#%host-expression foldl)
(#%host-expression string-append)
(#%host-expression "I"))))))
'(thread
values
(esc
(λ (lst)
((cstream->list
(inline-compose1
(map-cstream-next
sqr)
(filter-cstream-next
odd?)
list->cstream-next))
lst)))
values)
"deforestation in arbitrary positions"))
(let ([stx (make-right-chiral
#'(#%partial-application
((#%host-expression filter)
(#%host-expression odd?))))])
(check-equal? (syntax->datum
(deforest-rewrite
#`(thread #,stx)))
'(thread
(esc
(λ (lst)
((cstream->list (inline-compose1 (filter-cstream-next odd?) list->cstream-next)) lst))))
"deforestation of map -- note this tests the rule in isolation; with normalization this would never be necessary"))
(let ([stx (make-right-chiral
#'(#%partial-application
((#%host-expression map)
(#%host-expression sqr))))])
(check-equal? (syntax->datum
(deforest-rewrite
#`(thread #,stx)))
'(thread
(esc
(λ (lst)
((cstream->list (inline-compose1 (map-cstream-next sqr) list->cstream-next)) lst))))
"deforestation of filter -- note this tests the rule in isolation; with normalization this would never be necessary"))
(let ([stx (map make-right-chiral
(syntax->list
#'(values
(#%partial-application
((#%host-expression filter)
(#%host-expression odd?)))
(#%partial-application
((#%host-expression map)
(#%host-expression sqr)))
values)))])
(check-equal? (syntax->datum
(deforest-rewrite
#`(thread #,@stx)))
'(thread
values
(esc
(λ (lst)
((cstream->list
(inline-compose1
(map-cstream-next
sqr)
(filter-cstream-next
odd?)
list->cstream-next))
lst)))
values)
"deforestation in arbitrary positions"))
(let ([stx (map make-right-chiral
(syntax->list
#'((#%partial-application
((#%host-expression map)
(#%host-expression string-upcase)))
(#%partial-application
((#%host-expression foldl)
(#%host-expression string-append)
(#%host-expression "I"))))))])
(check-equal? (syntax->datum
(deforest-rewrite
#`(thread #,@stx)))
'(thread
(esc
(λ (lst)
((foldl-cstream
string-append
"I"
(inline-compose1
(map-cstream-next
string-upcase)
list->cstream-next))
lst))))
"deforestation in arbitrary positions")))
(test-suite
"fixed point"
null)))
Expand Down
6 changes: 4 additions & 2 deletions qi-test/tests/qi.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,8 @@
(prefix-in threading: "threading.rkt")
(prefix-in definitions: "definitions.rkt")
(prefix-in macro: "macro.rkt")
(prefix-in util: "util.rkt"))
(prefix-in util: "util.rkt")
(prefix-in compiler: "compiler.rkt"))

(define tests
(test-suite
Expand All @@ -20,7 +21,8 @@
threading:tests
definitions:tests
macro:tests
util:tests))
util:tests
compiler:tests))

(module+ test
(void
Expand Down

0 comments on commit 7f67806

Please sign in to comment.