First Optimizations

Makefile

@@ -104,25 +104,25 @@ 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-probe:
 	raco test -exp $(PACKAGE-NAME)-probe

qi-lib/flow.rkt

@@ -5,7 +5,7 @@
          (all-from-out "flow/extended/expander.rkt")
          (all-from-out "flow/extended/forms.rkt"))
 
-(require syntax-spec
+(require syntax-spec-v1
          (for-syntax racket/base
                      syntax/parse
                      (only-in "private/util.rkt"

qi-lib/flow/core/compiler.rkt

@@ -1,6 +1,9 @@
 #lang racket/base
 
-(provide (for-syntax compile-flow))
+(provide (for-syntax compile-flow
+                     ;; TODO: only used in unit tests, maybe try
+                     ;; using a submodule to avoid providing these usually
+                     deforest-rewrite))
 
 (require (for-syntax racket/base
                      syntax/parse
@@ -14,14 +17,183 @@
          racket/undefined
          (prefix-in fancy: fancy-app))
 
+;; "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
   ;; note: this does not return compiled code but instead,
   ;; syntax whose expansion compiles the code
   (define (compile-flow stx)
     (process-bindings (optimize-flow stx)))
 
+  (define-syntax-class fusable-list-operation
+    #:attributes (f next)
+    #:datum-literals (#%host-expression #%partial-application)
+    (pattern (#%partial-application
+              ((#%host-expression (~literal map))
+               (#%host-expression f)))
+      #:attr next #'map-cstream-next)
+    (pattern (#%partial-application
+              ((#%host-expression (~literal filter))
+               (#%host-expression f)))
+      #:attr next #'filter-cstream-next))
+
+  (define-syntax-class fusable-fold-operation
+    #:attributes (op init end)
+    #:datum-literals (#%host-expression #%partial-application)
+    (pattern (#%partial-application
+              ((#%host-expression (~literal foldr))
+               (#%host-expression op)
+               (#%host-expression init)))
+      #:attr end #'(foldr-cstream op init)))
+
+  (define-syntax-class non-fusable
+    (pattern (~not _:fusable-list-operation)))
+
+  (define (generate-fused-operation ops)
+    (syntax-parse (reverse ops)
+      [(g:fusable-fold-operation op:fusable-list-operation ...)
+       #`(esc (λ (lst)
+                ((#,@#'g.end
+                  (inline-compose1 [op.next op.f] ...
+                                   list->cstream-next))
+                 lst)))]
+      [(op:fusable-list-operation ...)
+       #'(esc (λ (lst)
+                ((cstream->list
+                  (inline-compose1 [op.next op.f] ...
+                                   list->cstream-next))
+                 lst)))]))
+
+  (define (normalize-rewrites stx)
+    ;; TODO: the "active" components of the expansions should be
+    ;; optimized, i.e. they should be wrapped with a recursive
+    ;; call to the optimizer
+    (syntax-parse stx
+      ;; restorative optimization for "all"
+      [((~datum thread) ((~datum amp) onex) (~datum AND))
+       #`(esc (give (curry andmap #,(compile-flow #'onex))))]
+      ;; "deforestation" for values
+      ;; (~> (pass f) (>< g)) → (>< (if f g ⏚))
+      [((~datum thread) _0 ... ((~datum pass) f) ((~datum amp) g) _1 ...)
+       #'(thread _0 ... (amp (if f g ground)) _1 ...)]
+      ;; merge amps in sequence
+      [((~datum thread) _0 ... ((~datum amp) f) ((~datum amp) g) _1 ...)
+       #`(thread _0 ... #,(normalize-rewrites #'(amp (thread f g))) _1 ...)]
+      ;; merge pass filters in sequence
+      [((~datum thread) _0 ... ((~datum pass) f) ((~datum pass) g) _1 ...)
+       #'(thread _0 ... (pass (and f g)) _1 ...)]
+      ;; collapse deterministic conditionals
+      [((~datum if) (~datum #t) f g) #'f]
+      [((~datum if) (~datum #f) f g) #'g]
+      ;; trivial threading form
+      [((~datum thread) f)
+       #'f]
+      ;; associative laws for ~>
+      [((~datum thread) _0 ... ((~datum thread) f ...) _1 ...) ; note: greedy matching
+       #'(thread _0 ... f ... _1 ...)]
+      ;; left and right identity for ~>
+      [((~datum thread) _0 ... (~datum _) _1 ...)
+       #'(thread _0 ... _1 ...)]
+      ;; composition of identity flows is the identity flow
+      [((~datum thread) (~datum _) ...)
+       #'_]
+      ;; identity flows composed using a relay
+      [((~datum relay) (~datum _) ...)
+       #'_]
+      ;; amp and identity
+      [((~datum amp) (~datum _))
+       #'_]
+      ;; trivial tee junction
+      [((~datum tee) f)
+       #'f]
+      ;; merge adjacent gens
+      [((~datum tee) _0 ... ((~datum gen) a ...) ((~datum gen) b ...) _1 ...)
+       #'(tee _0 ... (gen a ... 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.
+      [((~datum thread) _0 ... (~datum collect) (~datum sep) _1 ...)
+       #'(thread _0 ... _1 ...)]
+      ;; Deforestation for lists
+      ;; TODO: propagate the syntax property instead
+      ;; (~> (filter f) (map g)) → (~> (foldr [f+g] ...)))
+      [((~datum thread) _0 ...
+                        ((~datum #%partial-application) ((~literal filter) g))
+                        ((~datum #%partial-application) ((~literal map) f))
+                        _1 ...)
+       #'(thread _0 ...
+                 (#%fine-template
+                  (foldr (λ (v vs)
+                           (if (g v)
+                               (cons (f v) vs)
+                               vs))
+                         null
+                         _))
+                 _1 ...)]
+      ;; (~> (map f) (filter g)) → (~> (foldr [f+g] ...)))
+      [((~datum thread) _0 ...
+                        ((~datum #%partial-application) ((~literal map) f))
+                        ((~datum #%partial-application) ((~literal filter) g))
+                        _1 ...)
+       #'(thread _0 ...
+                 (#%fine-template
+                  (foldr (λ (v vs)
+                           (let ([result (f v)])
+                             (if (g result)
+                                 (cons result vs)
+                                 vs)))
+                         null
+                         _))
+                 _1 ...)]
+      ;; return syntax unchanged if there are no known optimizations
+      [_ stx]))
+
+  ;; 0. "Qi-normal form"
+  ;; 1. deforestation pass
+  ;; 2. other passes ...
+  ;; e.g.:
+  ;; changing internal representation to lists from values - may affect passes
+  ;; passes as distinct stages is safe and interesting, a conservative start
+  ;; one challenge: traversing the syntax tree
+  (define (deforest-rewrite stx)
+    (syntax-parse stx
+      [((~datum thread) _0:non-fusable ...
+                        f:fusable-list-operation ...+
+                        g:fusable-fold-operation
+                        _1 ...)
+       #:with fused (generate-fused-operation (syntax->list #'(f ... g)))
+       #'(thread _0 ... fused _1 ...)]
+      [((~datum thread) _0:non-fusable ... f:fusable-list-operation ...+ _1 ...)
+       #:with fused (generate-fused-operation (attribute f))
+       #'(thread _0 ... fused _1 ...)]
+      [_ this-syntax]))
+
+  (define ((fix f) init-val)
+    (let ([new-val (f init-val)])
+      (if (eq? new-val init-val)
+          new-val
+          ((fix f) new-val))))
+
+  (define (deforest-pass stx)
+    (find-and-map/qi (fix deforest-rewrite)
+                     stx))
+
+  (define (normalize-pass stx)
+    (find-and-map/qi (fix normalize-rewrites)
+                     stx))
+
   (define (optimize-flow stx)
-    stx))
+    ;; (deforest-pass (normalize-pass stx))
+    (deforest-pass (normalize-pass stx))))
 
 ;; Transformation rules for the `as` binding form:
 ;;

qi-lib/flow/core/impl.rkt

@@ -19,7 +19,12 @@
          values->list
          feedback-times
          feedback-while
-         kw-helper)
+         kw-helper
+         cstream->list
+         list->cstream-next
+         map-cstream-next
+         filter-cstream-next
+         foldr-cstream)
 
 (require racket/match
          (only-in racket/function
@@ -29,7 +34,8 @@
          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))
@@ -121,6 +127,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)))
 
@@ -235,3 +243,44 @@
           (loop (values->list
                  (apply f args)))
           (apply then-f args)))))
+
+;; Stream fusion
+(begin-encourage-inline
+  (define-inline (cstream->list next)
+    (λ (state)
+      (let loop ([state state])
+        ((next (λ () null)
+               (λ (state) (loop state))
+               (λ (value state)
+                 (cons value (loop state))))
+         state))))
+
+  (define-inline (foldr-cstream op init next)
+    (λ (state)
+      (let loop ([state state])
+        ((next (λ () init)
+               (λ (state) (loop state))
+               (λ (value state)
+                 (op value (loop state))))
+         state))))
+
+  (define-inline (list->cstream-next done skip yield)
+    (λ (state)
+      (cond [(null? state) (done)]
+            [else (yield (car state) (cdr state))])))
+
+  (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)))))))

qi-lib/flow/extended/expander.rkt

@@ -12,7 +12,7 @@
                                 [sep △]
                                 [collect ▽])))
 
-(require syntax-spec
+(require syntax-spec-v1
          (for-syntax "../aux-syntax.rkt"
                      "syntax.rkt"
                      racket/base

qi-lib/info.rkt

@@ -4,9 +4,7 @@
 (define collection "qi")
 (define deps '("base"
                ("fancy-app" #:version "1.1")
-               ;; this git URL should be changed to a named package spec
-               ;; once syntax-spec is on the package index
-               "git://github.com/michaelballantyne/syntax-spec.git#main"))
+               "syntax-spec-v1"))
 (define build-deps '())
 (define clean '("compiled" "private/compiled"))
 (define pkg-authors '(countvajhula))

qi-sdk/profile/nonlocal/intrinsic.rkt

@@ -48,6 +48,8 @@
                #:when (member (bm-name spec) benchmarks-to-run))
       (let ([name (bm-name spec)]
             [exerciser (bm-exerciser spec)]
-            [f (eval (read (open-input-string (bm-name spec))) namespace)]
+            [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)))))