diff --git a/qi-lib/flow/core/compiler/deforest/cps.rkt b/qi-lib/flow/core/compiler/deforest/cps.rkt index 65072bcd7..59ccc7d94 100644 --- a/qi-lib/flow/core/compiler/deforest/cps.rkt +++ b/qi-lib/flow/core/compiler/deforest/cps.rkt @@ -8,7 +8,8 @@ "../../../extended/util.rkt" syntax/srcloc racket/syntax-srcloc - "fusion.rkt") + "fusion.rkt" + "../../private/form-property.rkt") "templates.rkt" racket/performance-hint racket/match @@ -207,29 +208,30 @@ ;; fused sequence. And runtime checks for consumers are in ;; their respective implementation procedure. (with-syntax (((rt ...) (reverse (attribute t.state)))) - #`(esc - (#,((attribute p.curry) ctx (attribute p.name)) - (contract p.contract - (p.prepare - (lambda (state) - (define cstate (inline-consing state rt ...)) - cstate) - (#,@#'c.end - (inline-compose1 [t.next t.f - '#,(prettify-flow-syntax ctx) - '#,(build-source-location-vector - (syntax-srcloc ctx)) - ] ... - p.next - ) - '#,(prettify-flow-syntax ctx) - '#,(build-source-location-vector - (syntax-srcloc ctx)))) - p.name - '#,(prettify-flow-syntax ctx) - #f - '#,(build-source-location-vector - (syntax-srcloc ctx))))))])) + (attach-form-property + #`(esc + (#,((attribute p.curry) ctx (attribute p.name)) + (contract p.contract + (p.prepare + (lambda (state) + (define cstate (inline-consing state rt ...)) + cstate) + (#,@#'c.end + (inline-compose1 [t.next t.f + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)) + ] ... + p.next + ) + '#,(prettify-flow-syntax ctx) + '#,(build-source-location-vector + (syntax-srcloc ctx)))) + p.name + '#,(prettify-flow-syntax ctx) + #f + '#,(build-source-location-vector + (syntax-srcloc ctx)))))))])) ) diff --git a/qi-lib/flow/core/compiler/deforest/fusion.rkt b/qi-lib/flow/core/compiler/deforest/fusion.rkt index 6f2ccf43d..46448995c 100644 --- a/qi-lib/flow/core/compiler/deforest/fusion.rkt +++ b/qi-lib/flow/core/compiler/deforest/fusion.rkt @@ -8,7 +8,8 @@ "syntax.rkt" "../../passes.rkt" "../../strategy.rkt" - (for-template "../../passes.rkt")) + (for-template "../../passes.rkt") + "../../private/form-property.rkt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The actual fusion generator implementation @@ -22,46 +23,47 @@ (define (make-deforest-rewrite generate-fused-operation) (lambda (stx) - (syntax-parse stx - [((~datum thread) _0:non-fusable ... - p:fsp-syntax - ;; There can be zero transformers here: - t:fst-syntax ... - c:fsc-syntax - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - t1:fst-syntax0 - t:fst-syntax ... - c:fsc-syntax - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream t1 t ... c)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - p:fsp-syntax - ;; Must be 1 or more transformers here: - t:fst-syntax ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(p t ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - [((~datum thread) _0:non-fusable ... - f1:fst-syntax0 - f:fst-syntax ...+ - _1 ...) - #:with fused (generate-fused-operation - (syntax->list #'(list->cstream f1 f ... cstream->list)) - stx) - #'(thread _0 ... fused _1 ...)] - ;; return the input syntax unchanged if no rules - ;; are applicable - [_ stx]))) + (attach-form-property + (syntax-parse stx + [((~datum thread) _0:non-fusable ... + p:fsp-syntax + ;; There can be zero transformers here: + t:fst-syntax ... + c:fsc-syntax + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + t1:fst-syntax0 + t:fst-syntax ... + c:fsc-syntax + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream t1 t ... c)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + p:fsp-syntax + ;; Must be 1 or more transformers here: + t:fst-syntax ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(p t ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + [((~datum thread) _0:non-fusable ... + f1:fst-syntax0 + f:fst-syntax ...+ + _1 ...) + #:with fused (generate-fused-operation + (syntax->list #'(list->cstream f1 f ... cstream->list)) + stx) + #'(thread _0 ... fused _1 ...)] + ;; return the input syntax unchanged if no rules + ;; are applicable + [_ stx])))) ;; This syntax is actively used only once as it is intended to be used ;; by alternative implementations. Currently only the CPS