+ (define (call-with-failure-thunk exp proc)
+ (match exp
+ (($ <call> _ _ ()) (proc exp))
+ (($ <primcall> _ _ ()) (proc exp))
+ (($ <const>) (proc exp))
+ (($ <void>) (proc exp))
+ (($ <lexical-ref>) (proc exp))
+ (_
+ (let ((t (gensym "failure-")))
+ (record-new-temporary! 'failure t 2)
+ (make-let
+ src (list 'failure) (list t)
+ (list
+ (make-lambda
+ #f '()
+ (make-lambda-case #f '() #f #f #f '() '() exp #f)))
+ (proc (make-call #f (make-lexical-ref #f 'failure t)
+ '())))))))
+ (define (simplify-conditional c)
+ (match c
+ ;; Swap the arms of (if (not FOO) A B), to simplify.
+ (($ <conditional> src ($ <primcall> _ 'not (pred))
+ subsequent alternate)
+ (simplify-conditional
+ (make-conditional src pred alternate subsequent)))
+ ;; Special cases for common tests in the predicates of chains
+ ;; of if expressions.
+ (($ <conditional> src
+ ($ <conditional> src* outer-test inner-test ($ <const> _ #f))
+ inner-subsequent
+ alternate)
+ (let lp ((alternate alternate))
+ (match alternate
+ ;; Lift a common repeated test out of a chain of if
+ ;; expressions.
+ (($ <conditional> _ (? (cut tree-il=? outer-test <>))
+ other-subsequent alternate)
+ (make-conditional
+ src outer-test
+ (simplify-conditional
+ (make-conditional src* inner-test inner-subsequent
+ other-subsequent))
+ alternate))
+ ;; Likewise, but punching through any surrounding
+ ;; failure continuations.
+ (($ <let> let-src (name) (sym) ((and thunk ($ <lambda>))) body)
+ (make-let
+ let-src (list name) (list sym) (list thunk)
+ (lp body)))
+ ;; Otherwise, rotate AND tests to expose a simple
+ ;; condition in the front. Although this may result in
+ ;; lexically binding failure thunks, the thunks will be
+ ;; compiled to labels allocation, so there's no actual
+ ;; code growth.
+ (_
+ (call-with-failure-thunk
+ alternate
+ (lambda (failure)
+ (make-conditional
+ src outer-test
+ (simplify-conditional
+ (make-conditional src* inner-test inner-subsequent failure))
+ failure)))))))
+ (_ c)))