Add attach-form-property to both places needed by current deforestati…

…on (CPS) implementation.
dzoep · Jul 26, 2024 · 121b212 · 121b212
1 parent 9038ea0
commit 121b212
Show file tree

Hide file tree

Showing 2 changed files with 69 additions and 65 deletions.
diff --git 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
@@ -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