Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
164 changes: 102 additions & 62 deletions qi-lib/flow/compiler.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -63,8 +63,10 @@
#'(disjoin (qi0->racket onex) ...)]
[((~datum not) onex:clause)
#'(negate (qi0->racket onex))]
[((~datum gen))
#'*->1]
[((~datum gen) ex:expr ...)
#'(λ _ (values ex ...))]
#'(thunk* (values ex ...))]
[(~or* (~datum NOT) (~datum !))
#'not]
[(~or* (~datum AND) (~datum &))
Expand All @@ -91,7 +93,7 @@
;;; Core routing elements

[(~or* (~datum ⏚) (~datum ground))
#'(qi0->racket (select))]
#'*->1]
[((~or* (~datum ~>) (~datum thread)) onex:clause ...)
#`(compose . #,(reverse
(syntax->list
Expand All @@ -101,15 +103,15 @@
#'(qi0->racket (~> ▽ reverse △))]
[((~or* (~datum ==) (~datum relay)) onex:clause ...)
#'(relay (qi0->racket onex) ...)]
[((~or* (~datum ==*) (~datum relay*)))
#'1->1]
[((~or* (~datum ==*) (~datum relay*)) onex:clause)
#'(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))
...)))]
#'(tee (qi0->racket onex) ...)]
[e:select-form (select-parser #'e)]
[e:block-form (block-parser #'e)]
[((~datum bundle) (n:number ...)
Expand Down Expand Up @@ -303,11 +305,15 @@ the DSL.
"list?"
_)))]
[(_ onex:clause)
#'(λ (v . vs)
((qi0->racket (~> △ (>< (apply (qi0->racket onex) _ vs)))) v))]))
#'(let ([compiled-sep-flow
(λ (v . vs)
((qi0->racket (~> △ (>< (apply (qi0->racket onex) _ vs))))
v))])
compiled-sep-flow)]))

(define (select-parser stx)
(syntax-parse stx
[(_) #'*->1]
[(_ n:number ...) #'(qi0->racket (-< (esc (arg n)) ...))]
[(_ arg ...) ; error handling catch-all
(report-syntax-error 'select
Expand All @@ -333,16 +339,18 @@ the DSL.
(qi0->racket remainder-onex)
n)]
[_:id
#'(λ (n selection-flo remainder-flo . vs)
(apply (qi0->racket (group n selection-flo remainder-flo)) vs))]
#'(let ([compiled-group-flow
(λ (n selection-flo remainder-flo . vs)
(apply (qi0->racket (group n selection-flo remainder-flo)) vs))])
compiled-group-flow)]
[(_ arg ...) ; error handling catch-all
(report-syntax-error 'group
(syntax->datum #'(arg ...))
"(group <number> <selection qi0->racket> <remainder qi0->racket>)")]))

(define (switch-parser stx)
(syntax-parse stx
[(_) #'(qi0->racket _)]
[(_) #'values]
[(_ ((~or* (~datum divert) (~datum %))
condition-gate:clause
consequent-gate:clause))
Expand Down Expand Up @@ -411,10 +419,12 @@ the DSL.
#'(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))]
#'(let ([compiled-sieve-flow
(λ (condition sonex ronex . args)
(apply (qi0->racket (-< (~> (pass condition) sonex)
(~> (pass (not condition)) ronex)))
args))])
compiled-sieve-flow)]
[(_ arg ...) ; error handling catch-all
(report-syntax-error 'sieve
(syntax->datum #'(arg ...))
Expand All @@ -435,14 +445,16 @@ the DSL.
[(_ 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)))]
#'(let ([compiled-try-flow
(λ 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)))])
compiled-try-flow)]
[(_ arg ...)
(report-syntax-error 'try
(syntax->datum #'(arg ...))
Expand Down Expand Up @@ -473,32 +485,44 @@ the DSL.
(syntax-parse stx
[(_ consequent:clause
alternative:clause)
#'(λ (f . args)
(if (apply f args)
(apply (qi0->racket consequent) args)
(apply (qi0->racket alternative) args)))]
#'(let ([compiled-if-flow
(λ (f . args)
(if (apply f args)
(apply (qi0->racket consequent) args)
(apply (qi0->racket alternative) args)))])
compiled-if-flow)]
[(_ condition:clause
consequent:clause
alternative:clause)
#'(λ args
(if (apply (qi0->racket condition) args)
(apply (qi0->racket consequent) args)
(apply (qi0->racket alternative) args)))]))
#'(let ([compiled-if-flow
(λ args
(if (apply (qi0->racket condition) args)
(apply (qi0->racket consequent) args)
(apply (qi0->racket alternative) args)))])
compiled-if-flow)]))

(define (fanout-parser stx)
(syntax-parse stx
[_:id #'repeat-values]
[(_ 0) #'*->1]
[(_ 1) #'values]
Copy link
Copy Markdown
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not able to verify the original behavior here at the moment, but does this PR modify the behavior of any edge cases, e.g. (fanout 0) or (gen), or (relay)? If it does, it would be great to add tests for these cases. For cases like (fanout 0) and (fanout 1) we would need tests even if the behavior hasn't changed since it would now hit different code that needs to be covered by tests (unfortunately the coverage check on PRs doesn't work at the moment, but you can run make cover to generate a coverage report locally).

Copy link
Copy Markdown
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This PR doesn't modify the original behavior, I will write more tests later.

[(_ 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))))]))
#`(let ([compiled-fanout-flow
(λ args
(apply values
(append #,@(make-list (syntax->datum #'n) 'args))))])
compiled-fanout-flow)]
[(_ e:expr)
#'(let ([n e])
(case n
[(0) *->1]
[(1) values]
[else
(procedure-rename
(curry repeat-values n)
'compiled-fanout-flow)]))]))

(define (feedback-parser stx)
(syntax-parse stx
Expand All @@ -510,9 +534,10 @@ the DSL.
(qi0->racket thenex))]
[(_ ((~datum while) tilex:clause)
((~datum then) thenex:clause))
#'(λ (f . args)
(apply (qi0->racket (feedback (while tilex) (then thenex) f))
args))]
#'(let ([compiled-feedback-flow
(λ (f . args)
(apply (qi0->racket (feedback (while tilex) (then thenex) f)) args))])
compiled-feedback-flow)]
[(_ ((~datum while) tilex:clause) onex:clause)
#'(qi0->racket (feedback (while tilex) (then _) onex))]
[(_ ((~datum while) tilex:clause))
Expand All @@ -523,17 +548,23 @@ the DSL.
#'(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))]
#'(let ([compiled-feedback-flow
(λ (f . args)
(apply (qi0->racket (feedback n (then thenex) f)) args))])
compiled-feedback-flow)]
[(_ n:expr onex:clause)
#'(qi0->racket (feedback n (then _) onex))]
[(_ onex:clause)
#'(λ (n . args)
(apply (qi0->racket (feedback n onex)) args))]
#'(let ([compiled-feedback-flow
(λ (n . args)
(apply (qi0->racket (feedback n onex)) args))])
compiled-feedback-flow)]
[_:id
#'(λ (n flo . args)
(apply (qi0->racket (feedback n flo))
args))]))
#'(let ([compiled-feedback-flow
(λ (n flo . args)
(apply (qi0->racket (feedback n flo))
args))])
compiled-feedback-flow)]))

(define (side-effect-parser stx)
(syntax-parse stx
Expand All @@ -549,7 +580,9 @@ the DSL.
[_:id
#'map-values]
[(_ onex:clause)
#'(curry map-values (qi0->racket onex))]
#'(procedure-rename
(curry map-values (qi0->racket onex))
'compiled-amp-flow)]
[(_ onex0:clause onex:clause ...)
(report-syntax-error
'amp
Expand All @@ -562,7 +595,9 @@ the DSL.
[_:id
#'filter-values]
[(_ onex:clause)
#'(curry filter-values (qi0->racket onex))]))
#'(procedure-rename
(curry filter-values (qi0->racket onex))
'compiled-pass-flow)]))

(define (fold-left-parser stx)
(syntax-parse stx
Expand Down Expand Up @@ -607,18 +642,23 @@ the DSL.
(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)))]
#`(let ([compiled-clos-flow
(λ (f . args)
(apply #,(if (and chirality (eq? chirality 'right))
#'curryr #'curry)
f args))])
compiled-clos-flow)]
[(_ 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))))]))
#`(let ([compiled-clos-flow
(λ args
(qi0->racket
(~>
#,(if (and chirality (eq? chirality 'right))
#'(-< _ (~> (gen args) △))
#'(-< (~> (gen args) △) _))
onex)))])
compiled-clos-flow)]))

(define (literal-parser stx)
(syntax-parse stx
Expand Down
63 changes: 43 additions & 20 deletions qi-lib/flow/impl.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,10 @@
map-values
filter-values
partition-values
1->1
*->1
relay
tee
loom-compose
parity-xor
arg
Expand Down Expand Up @@ -40,22 +43,22 @@

;; 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])
(let ([n (or n (procedure-arity f))])
(define (loom-compose f g [n (procedure-arity f)])
(define compiled-group-flow
(λ args
(let ([num-args (length args)])
(if (< num-args n)
(if (= 0 num-args)
(values)
(error 'group (~a "Can't select "
n
" arguments from "
args)))
(let ([sargs (take args n)]
[rargs (drop args n)])
(apply values
(append (values->list (apply f sargs))
(values->list (apply g rargs))))))))))
(define num-args (length args))
(if (< num-args n)
(if (= 0 num-args)
(values)
(error 'group (~a "Can't select "
n
" arguments from "
args)))
(let-values ([(sargs rargs) (split-at args n)])
Copy link
Copy Markdown
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Nice 👌

Copy link
Copy Markdown
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm considering if it's necessary to optimize group:

(group 0 *->1 f)   ; f
(group 0 1->1 f)   ; f
(group +inf.0 f g) ; f
(group +inf.f f g) ; f

In addition, it seems that loom-compose does not need to use optional argument?

(apply values
(append (values->list (apply f sargs))
(values->list (apply g rargs))))))))
compiled-group-flow)

(define (parity-xor . args) (and (foldl xor #f args) #t))

Expand Down Expand Up @@ -165,7 +168,7 @@
[b (in-value (cdr c+b))]
[args (in-value (hash-ref by-cs c))])
(call-with-values (λ () (apply b args)) list)))
(apply values (apply append results)))
(apply values (append* results)))

(define (->boolean v) (and v #t))
(define true. (thunk* #t))
Expand All @@ -186,6 +189,9 @@
(append (values->list (apply op vs))
(apply zip-with op (map rest seqs))))))

(define 1->1 (thunk (values)))
(define *->1 (thunk* (values)))
Copy link
Copy Markdown
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could you explain the notation here? It doesn't seem to indicate the number of values since the first is 0->0, and the second is N->0.

Copy link
Copy Markdown
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

These appear in error messages shown to the user:

> (~> (1 2 3) (relay))
; 1->1: arity mismatch;
;  the expected number of arguments does not match the given number
;   expected: 0
;   given: 3

Any reason not to use (procedure-rename ...) within relay, relay* and other forms using 1->1 and *->1 so that the name of the form used (e.g. relay in the above example) is reported to the user?

Copy link
Copy Markdown
Collaborator Author

@NoahStoryM NoahStoryM Oct 11, 2022

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could you explain the notation here? It doesn't seem to indicate the number of values since the first is 0->0, and the second is N->0.

Values can be regard as a kind of Cartesian Product, so that (values "a" "b" "c") can be marked as "a" × "b" × "c". In category theory 1 is the identity element of ×, which is (values) in racket.

*->1 : accepts any arguments and returns (values).
1->1 : accepts no value and returns (values).

On the one hand, I haven't thought of a better notation for (values). On the other hand, Qi seems to have a deep connection with category theory, so I think it makes sense to use the notation in category theory directly (and we can use + and 0 to represent covalues and the identity element of it).

Any reason not to use (procedure-rename ...) within relay, relay* and other forms using 1->1 and *->1 so that the name of the form used (e.g. relay in the above example) is reported to the user?

For example, *->1 is not only the identity element of -<, but also in qi:

> (eq? (☯ ⏚) (☯ (-<)))
#t

And if we rename these procedures, the equality will be lost.

Copy link
Copy Markdown
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thanks for clarifying! The correspondence to category theory and the duality between sum and product makes sense, but do you anticipate any particular advantage gained by having the eq? equivalence? In general since equality of functions is undecidable, I would be skeptical of code that employs logic based on checks for equivalence between functions based on their identities. Unless there are some specific benefits you have in mind, I would favor keeping the names recognizable in error messages to supporting an eq? equivalence. We can still have the actual functions named as 1->1 and *->1 as that would preserve the identity from the perspective of the codebase instead of having duplicate implementations in the different forms.

Copy link
Copy Markdown
Collaborator Author

@NoahStoryM NoahStoryM Oct 11, 2022

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

but do you anticipate any particular advantage gained by having the eq? equivalence? In general since equality of functions is undecidable, I would be skeptical of code that employs logic based on checks for equivalence between functions based on their identities.

Yes, in general functions are undecidable. But *->1 is special, it is the identity element of -< (a monoid), so it should have this property:

Welcome to Racket v8.6 [cs].
> (require qi)
> (define (f) 123)
> (eq? f (☯ (-< (-<) f)))
#t
> (eq? f (☯ (-< f (-<))))
#t

I prefer to preserve the properties of mathematical structures as much as possible.

Copy link
Copy Markdown
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, I agree that we should aim to preserve mathematical properties. Yet, eq? is not a mathematical relation but an implementation-dependent relation in the Scheme world. It doesn't assess equality based on properties of the objects being compared but based on arbitrary details of the implementation (e.g. memory location where the values may happen to be stored). As a result, I would say that we should avoid considering eq? behavior in our design process except in cases where it provides a compelling performance benefit in practice -- otherwise, better to think in terms of equal? (but even that is problematic -- the paper on egal? covers some of the issues but not all).

Aside from the specific choice of equality relation, in the present case, I feel the mathematical properties we'd like to preserve are:

((☯ (-< (-<) f)) arg ...) = (f arg ...) = ((☯ (-< f (-<))) arg ...)

That is, an operational equivalence in terms of the result of applying these functions to arguments. Since, for instance, we could have a totally different definition of *->1 which would also fulfill the monoid laws, but would not be eq? to the *->1 defined in the codebase. And in this case, there is nothing specific that we need to do in order to ensure the above relation holds, as (relay) and others would satisfy this relation even without being eq?.

Btw, I also meant that code in general should not do checks like (if (eq? f1 f2) ...) or even (if (equal? f1 f2) ...) or (if (member f1 (list f2 f3 f3)) where the fs are functions, since in the general case this is undecidable, and in special cases, it is implementation-specific and akin to a "hack" for performance. In this line of thinking, we should not encourage users writing code like (if (member (☯ (-<)) (list f ...)). Instead, we could simply apply the function to a relevant argument of interest, (if (= v (☯ (-<)) v) ...) without making a general statement that the function "is" the monoid identity.

Copy link
Copy Markdown
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

As a result, I would say that we should avoid considering eq? behavior in our design process except in cases where it provides a compelling performance benefit in practice.

I think eq? does provide performance benefit. Because in this way programmers can insert the identity functions anywhere without worrying about the performance overhead.

For example, I thought about simulating the limit in category theory by inserting procedures between the arguments of compose.

(define do (make-parameter values))
(~> f g h ...) ; = (~> f (do) g (do) h (do) ...)

But it affects the performance of qi's original code -- because it inserts valuess between all the function arguments of compose. This is what motivated me to submit this PR.

And on the other hand, I'm not sure if it's a good idea to rename the returned procedures in any case. If we rename (-<), how should we deal with (-< add1)? If we decide to rename add1, there seems to be 2 ways:

> ((procedure-rename add1 'compiled-tee-flow) 1 2 3)
compiled-tee-flow: arity mismatch;
 the expected number of arguments does not match the given number
  expected: 1
  given: 3
 [,bt for context]
> ((let ([compiled-tee-flow (lambda args (apply add1 args))]) compiled-tee-flow) 1 2 3)
add1: arity mismatch;
 the expected number of arguments does not match the given number
  expected: 1
  given: 3
 [,bt for context]

The 1st way might be consistent with the way you expect to rename *->1, and the 2nd way is consistent with the case that -< accepts more arguments:

> (~> (1 2 3) (-< add1 sub1))
add1: arity mismatch;
 the expected number of arguments does not match the given number
  expected: 1
  given: 3
 [,bt for context]

I'm not sure if renaming named functions (like add1, *->1) can make it easier for programmers to debug.

Copy link
Copy Markdown
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Related thoughts:

  • the idea that $\forall f g, (\forall x, f x = g x) \implies f = g$ is called extensionality (specifically functional extensionality, since the objects are functions). It derives from a general axiom of dependent functional extensionality (I believe in general extensional views are debated, but in this case it seems particularly useful).
  • In Racket, (eq? f f) when f is a lambda of some kind is guaranteed, and transitively any expression that evaluates to f is eq? to f. This means that you could (for example) make functions the keys of a hasheq. But I think this is probably broken under procedure-rename. OTOH, this is only useful when trying to dispatch on behavior from a set of procedures. I don't think the perf. benefit being discussed is the result of eq? but rather the result of not adding extraneous layers to the computation.


;; from mischief/function - requiring it runs aground
;; of some "name is protected" error while building docs, not sure why;
;; so including the implementation directly here for now
Expand All @@ -194,9 +200,26 @@
(lambda (ks vs f . xs)
(keyword-apply f ks vs xs))))

(define (relay . fs)
(λ args
(apply values (zip-with call fs args))))
(define relay
(case-lambda
[() 1->1]
[(f) (procedure-reduce-arity-mask f 2)]
[fs
(define (compiled-relay-flow . args)
(apply values (zip-with call fs args)))
compiled-relay-flow]))

(define (tee . fs)
(match (remq* (list *->1) fs)
['() *->1]
[`(,f) f]
[fs
(define (compiled-tee-flow . args)
(apply values
(append*
(for/list ([f (in-list fs)])
(values->list (apply f args))))))
compiled-tee-flow]))

(define (all? . args)
(and (for/and ([v (in-list args)]) v) #t))
Expand All @@ -208,7 +231,7 @@
(not (for/or ([v (in-list args)]) v)))

(define (repeat-values n . vs)
(apply values (apply append (make-list n vs))))
(apply values (append* (make-list n vs))))

(define (power n f)
(apply compose (make-list n f)))
Expand Down
Loading