From 30eb35b99cc899156c5a38b06d706f5ea566df0a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 Dec 2020 16:32:19 -0700 Subject: [PATCH] cs & schemify: improve folding of `procedure?` and `procedure-arity-includes?` --- .../tests/racket/optimize.rktl | 468 ++-- racket/src/cs/rumble/procedure.ss | 5 +- racket/src/cs/schemified/schemify.scm | 2225 +++++++++-------- racket/src/schemify/infer-known.rkt | 63 +- racket/src/schemify/lambda.rkt | 80 + racket/src/schemify/optimize.rkt | 55 +- 6 files changed, 1517 insertions(+), 1379 deletions(-) create mode 100644 racket/src/schemify/lambda.rkt diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 8020e1351b..8d7d18ae34 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -161,6 +161,8 @@ [`(,es ...) (for/list ([e (in-list es)]) (loop e env))] + [`(,e1 . ,e2) + (cons (loop e1 env) (loop e2 env))] [else (hash-ref env s s)]))))) @@ -1001,8 +1003,7 @@ (let ([l (list (random))]) (list (unsafe-car l) (unsafe-cdr l)))))) -(test-comp #:except 'chez-scheme ;; `procedure?` is not primitive - '(lambda (w z) +(test-comp '(lambda (w z) (let ([l (if w (lambda () w) (lambda () z))]) @@ -1750,16 +1751,14 @@ (+ y 1)))) -(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough - '(let () +(test-comp '(let () (define (f x) (procedure-specialize (lambda (y) (+ x y)))) ((f 10) 12)) '22) -(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough - '(let () +(test-comp '(let () (define (f x) (procedure-specialize (lambda (y) (+ x y)))) @@ -2314,11 +2313,9 @@ '(procedure? add1)) (test-comp '(lambda () #t) '(lambda () (procedure? add1))) -(test-comp #:except 'chez-scheme - #t +(test-comp #t '(procedure? (lambda (x) x))) -(test-comp #:except 'chez-scheme - '(lambda () #t) +(test-comp '(lambda () #t) '(lambda () (procedure? (lambda (x) x)))) (test-comp #f '(pair? (lambda (x) x))) @@ -2330,8 +2327,7 @@ 88)) '(let ([f (lambda (x) x)]) (list f))) -(test-comp #:except 'chez-scheme - '(let ([f (lambda (x) x)]) +(test-comp '(let ([f (lambda (x) x)]) (list f f @@ -2354,13 +2350,11 @@ (test-comp '(lambda (x) #f) '(lambda (x) (pair? (if x car cdr)))) -(test-comp #:except 'chez-scheme - '(lambda (x) #t) +(test-comp '(lambda (x) #t) '(lambda (x) (procedure? (if x car cdr)))) (test-comp '(lambda (x) #t) '(lambda (x) (fixnum? (if x 2 3)))) -(test-comp #:except 'chez-scheme - '(lambda (x) #f) +(test-comp '(lambda (x) #f) '(lambda (x) (procedure? (if x 2 3)))) (test-comp '(lambda () @@ -2503,69 +2497,72 @@ (define (q x) (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10)))))))))))))) -(unless (eq? 'chez-scheme (system-type 'vm)) ; procedures are not primitivee - (let ([check (lambda (proc arities non-arities) - (test-comp `(procedure? ,proc) - #t) - (test-comp `(module m racket/base - (define f ,proc) - (print (procedure? f))) - `(module m racket/base - (define f ,proc) - (print #t))) - (test-comp `(procedure-arity-includes? ,proc -1) - #t - #f) - (test-comp `(procedure-arity-includes? ,proc -1) - #f - #f) - (for-each - (lambda (a) - (test-comp `(procedure-arity-includes? ,proc ,a) - #t) - (test-comp `(module m racket/base - (define f ,proc) - (print (procedure-arity-includes? f ,a))) - `(module m racket/base - (define f ,proc) - (print #t)))) - arities) - (for-each - (lambda (a) - (test-comp `(procedure-arity-includes? ,proc ,a) - #f) - (test-comp `(module m racket/base - (define f ,proc) - (print (procedure-arity-includes? f ,a))) - `(module m racket/base - (define f ,proc) - (print #f)))) - non-arities))]) - (check '(lambda (x) x) '(1) '(0 2 3)) - (check '(lambda (x y) x) '(2) '(0 1 3)) - (check '(lambda (x . y) x) '(1 2 3) '(0)) - (check '(case-lambda [() 1] [(x y) x]) '(0 2) '(1 3)) - (check '(lambda (x [y #f]) y) '(1 2) '(0 3)) - (check 'integer? '(1) '(0 2 3)) - (check 'cons '(2) '(0 1 3)) - (check 'list '(0 1 2 3) '())) +(let ([check (lambda (proc arities non-arities) + (test-comp `(procedure? ,proc) + #t) + (test-comp `(module m racket/base + (define f ,proc) + (print (procedure? f))) + `(module m racket/base + (define f ,proc) + (print #t))) + (test-comp `(procedure-arity-includes? ,proc -1) + #t + #f) + (test-comp `(procedure-arity-includes? ,proc -1) + #f + #f) + (for-each + (lambda (a) + (test-comp `(procedure-arity-includes? ,proc ,a) + #t) + (test-comp `(module m racket/base + (define f ,proc) + (print (procedure-arity-includes? f ,a))) + `(module m racket/base + (define f ,proc) + (print #t)))) + arities) + (for-each + (lambda (a) + (test-comp `(procedure-arity-includes? ,proc ,a) + #f) + (test-comp `(module m racket/base + (define f ,proc) + (print (procedure-arity-includes? f ,a))) + `(module m racket/base + (define f ,proc) + (print #f)))) + non-arities))]) + (check '(lambda (x) x) '(1) '(0 2 3)) + (check '(lambda (x y) x) '(2) '(0 1 3)) + (check '(lambda (x . y) x) '(1 2 3) '(0)) + (check '(case-lambda [() 1] [(x y) x]) '(0 2) '(1 3)) + (check '(lambda (x [y #f]) y) '(1 2) '(0 3)) + (check 'integer? '(1) '(0 2 3)) + (check 'cons '(2) '(0 1 3)) + (check 'list '(0 1 2 3) '())) +(unless (eq? 'chez-scheme (system-type 'vm)) ; procedures are not primitivee (test-comp '(lambda () (primitive? car)) - '(lambda () #t)) - (test-comp '(lambda () (procedure-arity-includes? car 1)) - '(lambda () #t)) - (test-comp '(lambda () (procedure-arity-includes? car 2)) - '(lambda () #f)) - (test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1)) - '(lambda () (random) #t)) - (test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2)) - '(lambda () (random) #f)) - (test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1)) - '(lambda () #t) - #f) - (test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2)) - '(lambda () #f) - #f)) + '(lambda () #t))) + +(test-comp '(lambda () (procedure-arity-includes? car 1)) + '(lambda () #t)) +(test-comp '(lambda () (procedure-arity-includes? car 2)) + '(lambda () #f)) +(test-comp #:except 'chez-scheme ; schemify only recognizes immediate identifiers + '(lambda () (procedure-arity-includes? (begin (random) car) 1)) + '(lambda () (random) #t)) +(test-comp #:except 'chez-scheme ; schemify only recognizes immediate identifiers + '(lambda () (procedure-arity-includes? (begin (random) car) 2)) + '(lambda () (random) #f)) +(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1)) + '(lambda () #t) + #f) +(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2)) + '(lambda () #f) + #f) (test-comp '(lambda () (let ([l '(1 2)]) @@ -2693,7 +2690,7 @@ (test-implies 'k:true-object? 'boolean?) ) -(test-comp #:except 'chez-scheme +(test-comp #:except 'chez-scheme ; list-pair? is not primitive enough for cptypes '(lambda (z) (when (and (list? z) (pair? z)) @@ -2748,7 +2745,6 @@ (not (not z))) #t))) - (let ([test-reduce (lambda (pred-name expr [val #t]) (test-comp `(list ',pred-name (,pred-name ,expr)) @@ -2757,19 +2753,21 @@ (list ',pred-name e e (,pred-name e))) `(let ([e ,expr]) (list ',pred-name e e ,val))))]) - (test-reduce 'list? 0 #f) - (test-reduce 'list? ''()) - (test-reduce 'list? ''(1)) - (test-reduce 'list? ''(1 2)) - #;(test-reduce 'list? ''(1 . 2) #f) - (test-reduce 'list? '(list)) - (test-reduce 'list? '(list 1)) - (test-reduce 'list? '(list 1 2)) - #;(test-reduce 'list? '(cons 1 2) #f) - (test-reduce 'list? '(cons 1 null)) - (test-reduce 'list? '(cons 1 (list 2 3))) - (test-reduce 'list? '(cdr (list 1 2))) - (test-reduce 'list? '(cdr (list 1))) + + (unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet specialize `list?` + (test-reduce 'list? 0 #f) + (test-reduce 'list? ''()) + (test-reduce 'list? ''(1)) + (test-reduce 'list? ''(1 2)) + #;(test-reduce 'list? ''(1 . 2) #f) + (test-reduce 'list? '(list)) + (test-reduce 'list? '(list 1)) + (test-reduce 'list? '(list 1 2)) + #;(test-reduce 'list? '(cons 1 2) #f) + (test-reduce 'list? '(cons 1 null)) + (test-reduce 'list? '(cons 1 (list 2 3))) + (test-reduce 'list? '(cdr (list 1 2))) + (test-reduce 'list? '(cdr (list 1)))) (test-reduce 'null? 0 #f) (test-reduce 'null? ''()) @@ -2815,24 +2813,25 @@ (test-reduce 'k:list-pair? '(cdr (list 1)) #f)) ) -(test-comp '(lambda (z) - (when (and (list? z) (pair? z)) - (list? (cdr z)))) - '(lambda (z) - (when (and (list? z) (pair? z)) - #t))) -(test-comp '(lambda (z) - (when (list? z) - (list? (unsafe-cdr z)))) - '(lambda (z) - (when (list? z) - #t))) -(test-comp '(lambda (z) - (when (list? z) - (list? (cdr z)))) - '(lambda (z) - (when (list? z) - (begin (cdr z) #t)))) +(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet specialize `list?` + (test-comp '(lambda (z) + (when (and (list? z) (pair? z)) + (list? (cdr z)))) + '(lambda (z) + (when (and (list? z) (pair? z)) + #t))) + (test-comp '(lambda (z) + (when (list? z) + (list? (unsafe-cdr z)))) + '(lambda (z) + (when (list? z) + #t))) + (test-comp '(lambda (z) + (when (list? z) + (list? (cdr z)))) + '(lambda (z) + (when (list? z) + (begin (cdr z) #t))))) (let ([test-bin (lambda (bin-name) @@ -2844,48 +2843,50 @@ (test-bin 'eq?) (test-bin 'eqv?)) -(for ([middle (in-list (list '(random) ; known immediate - '(read)))] ; could capture continuation? - [default-same? (in-list (list #t - #f))]) - (let ([test-move - (lambda (expr [same? default-same?]) - (test-comp `(lambda (z) - (let ([x ,expr]) - (let ([y ,middle]) - (list y x)))) - `(lambda (z) - (list ,middle ,expr)) - same?))]) - (test-move '(cons 1 2)) - (test-move '(mcons 1 2)) - (test-move '(list 1)) - (test-move '(list 1 2)) - (test-move '(list 1 2 3)) - (test-move '(list* 1 2)) - (test-move '(list* 1 2 3)) - (test-move '(vector 1)) - (test-move '(vector 1 2)) - (test-move '(vector 1 2 3)) - (test-move '(box 2)) - (test-move '(box-immutable 2)) - (test-move '(cons 1 2 3) #f) - (test-move '(mcons 1 2 3) #f) - (test-move '(box 1 2) #f) - (test-move '(box-immutable 1 2) #f) - (test-move '(quote (1 2)) #t))) - -;; Check move in to `else` branch where `then` -;; branch might capture a continuation -(test-comp `(lambda (z) - (let ([x (cons 1 2)]) +(unless (eq? 'chez-scheme (system-type 'vm)) + (for ([middle (in-list (list '(random) ; known immediate + '(read)))] ; could capture continuation? + [default-same? (in-list (list #t + #f))]) + (let ([test-move + (lambda (expr [same? default-same?]) + (test-comp `(lambda (z) + (let ([x ,expr]) + (let ([y ,middle]) + (list y x)))) + `(lambda (z) + (list ,middle ,expr)) + same?))]) + (test-move '(cons 1 2)) + (test-move '(mcons 1 2)) + (test-move '(list 1)) + (test-move '(list 1 2)) + (test-move '(list 1 2 3)) + (test-move '(list* 1 2)) + (test-move '(list* 1 2 3)) + (test-move '(vector 1)) + (test-move '(vector 1 2)) + (test-move '(vector 1 2 3)) + (test-move '(box 2)) + (test-move '(box-immutable 2)) + (test-move '(cons 1 2 3) #f) + (test-move '(mcons 1 2 3) #f) + (test-move '(box 1 2) #f) + (test-move '(box-immutable 1 2) #f) + (test-move '(quote (1 2)) #t))) + + ;; Check move in to `else` branch where `then` + ;; branch might capture a continuation + (test-comp `(lambda (z) + (let ([x (cons 1 2)]) + (if z + (read) + x))) + `(lambda (z) (if z (read) - x))) - `(lambda (z) - (if z - (read) - (cons 1 2)))) + (cons 1 2))))) + ;; But not after the merge: (test-comp `(lambda (z) (let ([x (cons 1 2)]) @@ -2911,9 +2912,11 @@ (,unsafe-op x) (cdr x)))) (test-comp `(lambda (x) - (list (,op x) (,op x))) + (let ([a (,op x)]) + (list a (,op x)))) `(lambda (x) - (list (,op x) (,unsafe-op x))) + (let ([a (,op x)]) + (list a (,unsafe-op x)))) savetype) (test-comp `(lambda (x) (if (and (,pred x) @@ -2932,22 +2935,23 @@ (test-use-unsafe 'pair? 'cdr 'unsafe-cdr) (test-use-unsafe 'mpair? 'mcar 'unsafe-mcar) (test-use-unsafe 'mpair? 'mcdr 'unsafe-mcdr) - (test-use-unsafe 'box? 'unbox 'unsafe-unbox) - (test-use-unsafe 'vector? 'vector-length 'unsafe-vector-length) + (unless (eq? 'chez-scheme (system-type 'vm)) ; impersonators currently get in the way + (test-use-unsafe 'box? 'unbox 'unsafe-unbox) + (test-use-unsafe 'vector? 'vector-length 'unsafe-vector-length)) (test-use-unsafe 'string? 'string-length 'unsafe-string-length) (test-use-unsafe 'bytes? 'bytes-length 'unsafe-bytes-length) (test-use-unsafe/savetype 'fixnum? 'bitwise-not 'unsafe-fxnot #f) - (test-use-unsafe/savetype 'fixnum? 'fxnot 'unsafe-fxnot #f)) + (test-use-unsafe/savetype 'fixnum? 'fxnot 'unsafe-fxnot (not (eq? 'racket (system-type 'vm))))) (let ([test-use-unsafe-fxbinary (lambda (op unsafe-op) (test-comp `(lambda (vx vy) - (let ([x (vector-length vx)] - [y (vector-length vy)]) + (let ([x (string-length vx)] + [y (string-length vy)]) (,op x y))) `(lambda (vx vy) - (let ([x (vector-length vx)] - [y (vector-length vy)]) + (let ([x (string-length vx)] + [y (string-length vy)]) (,unsafe-op x y)))) (test-comp `(lambda (x y) (when (and (fixnum? x) (fixnum? y)) @@ -2968,13 +2972,14 @@ (test-use-unsafe-fxbinary 'fxior 'unsafe-fxior) (test-use-unsafe-fxbinary 'fxxor 'unsafe-fxxor) - (test-use-unsafe-fxbinary '= 'unsafe-fx=) - (test-use-unsafe-fxbinary '< 'unsafe-fx<) - (test-use-unsafe-fxbinary '> 'unsafe-fx>) - (test-use-unsafe-fxbinary '<= 'unsafe-fx<=) - (test-use-unsafe-fxbinary '>= 'unsafe-fx>=) - (test-use-unsafe-fxbinary 'min 'unsafe-fxmin) - (test-use-unsafe-fxbinary 'max 'unsafe-fxmax) + (unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't currently convert to fixnum ops + (test-use-unsafe-fxbinary '= 'unsafe-fx=) + (test-use-unsafe-fxbinary '< 'unsafe-fx<) + (test-use-unsafe-fxbinary '> 'unsafe-fx>) + (test-use-unsafe-fxbinary '<= 'unsafe-fx<=) + (test-use-unsafe-fxbinary '>= 'unsafe-fx>=) + (test-use-unsafe-fxbinary 'min 'unsafe-fxmin) + (test-use-unsafe-fxbinary 'max 'unsafe-fxmax)) (test-use-unsafe-fxbinary 'fx= 'unsafe-fx=) (test-use-unsafe-fxbinary 'fx< 'unsafe-fx<) @@ -2984,52 +2989,55 @@ (test-use-unsafe-fxbinary 'fxmin 'unsafe-fxmin) (test-use-unsafe-fxbinary 'fxmax 'unsafe-fxmax)) -(test-comp '(lambda (vx) - (let ([x (vector-length vx)]) +(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't currently convert to fixnum ops + (test-comp '(lambda (vx) + (let ([x (string-length vx)]) (zero? x))) - '(lambda (vx) - (let ([x (vector-length vx)]) - (unsafe-fx= x 0)))) -(test-comp '(lambda (x) - (when (fixnum? x) - (zero? x))) - '(lambda (x) - (when (fixnum? x) - (unsafe-fx= x 0)))) -(test-comp '(lambda (x) - (when (and (fixnum? x) (zero? (random 2))) - (zero? x))) - '(lambda (x) - (when (and (fixnum? x) (zero? (random 2))) - (unsafe-fx= x 0)))) + '(lambda (vx) + (let ([x (string-length vx)]) + (unsafe-fx= x 0)))) + (test-comp '(lambda (x) + (when (fixnum? x) + (zero? x))) + '(lambda (x) + (when (fixnum? x) + (unsafe-fx= x 0)))) + (test-comp '(lambda (x) + (when (and (fixnum? x) (zero? (random 2))) + (zero? x))) + '(lambda (x) + (when (and (fixnum? x) (zero? (random 2))) + (unsafe-fx= x 0))))) -;test special case for bitwise-and and fixnum? -(test-comp '(lambda (x) - (let ([y (bitwise-and x 2)]) - (list y y (fixnum? y)))) - '(lambda (x) - (let ([y (bitwise-and x 2)]) - (list y y #t)))) -(test-comp '(lambda (x) - (let ([y (bitwise-and x 2)]) - (fixnum? x))) - '(lambda (x) - (let ([y (bitwise-and x 2)]) - #t)) - #f) +(unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't currently convert to fixnum ops + ;test special case for bitwise-and and fixnum? + (test-comp '(lambda (x) + (let ([y (bitwise-and x 2)]) + (list y y (fixnum? y)))) + '(lambda (x) + (let ([y (bitwise-and x 2)]) + (list y y #t)))) + (test-comp '(lambda (x) + (let ([y (bitwise-and x 2)]) + (fixnum? x))) + '(lambda (x) + (let ([y (bitwise-and x 2)]) + #t)) + #f)) -;; Make sure that `bitwise-and` is known to return a fixnum for non-negative -;; fixnum arguments but not for a negative one +(unless (eq? 'chez-scheme (system-type 'vm)) ; no literal specializations right now + ;; Make sure that `bitwise-and` is known to return a fixnum for non-negative + ;; fixnum arguments but not for a negative one -(test-comp '(lambda (x) - (bitwise-ior (bitwise-and x 7) 1)) - '(lambda (x) - (unsafe-fxior (bitwise-and x 7) 1))) -(test-comp '(lambda (x) - (bitwise-ior (bitwise-and x -7) 1)) - '(lambda (x) - (unsafe-fxior (bitwise-and x -7) 1)) - #f) + (test-comp '(lambda (x) + (bitwise-ior (bitwise-and x 7) 1)) + '(lambda (x) + (unsafe-fxior (bitwise-and x 7) 1))) + (test-comp '(lambda (x) + (bitwise-ior (bitwise-and x -7) 1)) + '(lambda (x) + (unsafe-fxior (bitwise-and x -7) 1)) + #f)) (test-comp `(lambda (x) @@ -3044,26 +3052,37 @@ (cdr x))) #f) -;; + fold to fixnum overflow, fx+ doesn't -(test-comp `(module m racket/base - (+ (sub1 (expt 2 30)) (sub1 (expt 2 30)))) - `(module m racket/base - (- (expt 2 31) 2))) -(test-comp `(module m racket/base - (require racket/fixnum) - (fx+ (sub1 (expt 2 30)) (sub1 (expt 2 30)))) - `(module m racket/base - (require racket/fixnum) - (- (expt 2 31) 2)) - #f) +(let ([width (case (system-type 'vm) + [(chez-scheme) + ;; Need machine-specific fixnum bound: + (case (system-type 'word) + [(32) 29] + [(64) 60])] + [else + ;; Racket compiles independent of current machine: + 30])]) + ;; + fold to fixnum overflow, fx+ doesn't + (test-comp `(module m racket/base + (+ (sub1 (expt 2 ,width)) (sub1 (expt 2 ,width)))) + `(module m racket/base + (- (expt 2 ,(+ width 1)) 2))) + (test-comp `(module m racket/base + (require racket/fixnum) + (fx+ (sub1 (expt 2 ,width)) (sub1 (expt 2 ,width)))) + `(module m racket/base + (require racket/fixnum) + (- (expt 2 ,(+ width 1)) 2)) + #f)) ;; Propagate type implications from RHS: (test-comp '(lambda (x) (let ([y (car x)]) - (list (cdr x) y (car x) y))) + (let ([a (cdr x)]) + (list a y (car x) y)))) '(lambda (x) - (let ([y (car x)]) - (list (unsafe-cdr x) y (unsafe-car x) y)))) + (let ([y (car x)]) + (let ([a (unsafe-cdr x)]) + (list a y (unsafe-car x) y))))) ;; don't duplicate an operation by moving it into a lambda': (test-comp '(lambda (x) @@ -3103,7 +3122,8 @@ (f) (list x)) #f) -(test-comp '(lambda (f x) +(test-comp #:except 'chez-scheme + '(lambda (f x) (let ([y (list x)]) (random) y)) diff --git a/racket/src/cs/rumble/procedure.ss b/racket/src/cs/rumble/procedure.ss index 4ab3dcc6be..ec7e13e4d4 100644 --- a/racket/src/cs/rumble/procedure.ss +++ b/racket/src/cs/rumble/procedure.ss @@ -31,7 +31,10 @@ (define (procedure? v) (or (#%procedure? v) (and (record? v) - (not (eq? (struct-property-ref prop:procedure (record-rtd v) none) none))))) + (#%$app/no-inline struct-procedure? v)))) + +(define (struct-procedure? v) + (not (eq? (struct-property-ref prop:procedure (record-rtd v) none) none))) (define/who (procedure-specialize proc) (check who procedure? proc) diff --git a/racket/src/cs/schemified/schemify.scm b/racket/src/cs/schemified/schemify.scm index 499affea13..70dd6eaa52 100644 --- a/racket/src/cs/schemified/schemify.scm +++ b/racket/src/cs/schemified/schemify.scm @@ -9219,6 +9219,962 @@ seen_1)))) (register!_0 q_1)))))))))))))))) (check-register_0 q_0 hash2610)))) +(define lambda?.1 + (|#%name| + lambda? + (lambda (simple?1_0 v3_0) + (begin + (let ((hd_0 + (let ((p_0 (unwrap v3_0))) + (if (pair? p_0) (unwrap (car p_0)) #f)))) + (if (if (eq? 'lambda hd_0) #t #f) + #t + (if (if (eq? 'case-lambda hd_0) #t #f) + #t + (if (if (eq? 'let-values hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (if (let ((a_3 (car p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 + (let ((a_2 (car p_1))) + (let ((a_3 (car (unwrap a_2)))) a_3)))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) + a_2)))) + (let ((id_1 id_0)) + (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) + (let-lambda?.1 simple?1_0 id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'letrec-values hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (if (let ((a_3 (car p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap + '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 + (let ((a_2 (car p_1))) + (let ((a_3 (car (unwrap a_2)))) + a_3)))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) + a_2)))) + (let ((id_1 id_0)) + (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) + (let-lambda?.1 simple?1_0 id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'let hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 (let ((a_2 (car p_1))) a_2))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) + a_2)))) + (let ((id_1 id_0)) + (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args + (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) + (let-lambda?.1 simple?1_0 id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'letrec* hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap + '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 (let ((a_2 (car p_1))) a_2))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) + a_2)))) + (let ((id_1 id_0)) + (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args + (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) + (let-lambda?.1 simple?1_0 id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'let-values hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((d_1 (cdr (unwrap d_0)))) + (let ((a_0 (car (unwrap d_1)))) a_0))))) + (if (not simple?1_0) (lambda?.1 #f body_0) #f)) + (if (if (eq? 'letrec-values hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((d_1 (cdr (unwrap d_0)))) + (let ((a_0 (car (unwrap d_1)))) a_0))))) + (if (not simple?1_0) (lambda?.1 #f body_0) #f)) + (if (if (eq? 'begin hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_1))))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((a_0 (car (unwrap d_0)))) a_0)))) + (lambda?.1 simple?1_0 body_0)) + (if (if (eq? 'begin hd_0) #t #f) + (let ((bodys_0 + (let ((d_0 (cdr (unwrap v3_0)))) d_0))) + (if (not simple?1_0) + (letrec* + ((loop_0 + (|#%name| + loop + (lambda (bodys_1) + (begin + (if (null? (cdr bodys_1)) + (let ((temp31_0 (car bodys_1))) + (lambda?.1 simple?1_0 temp31_0)) + (loop_0 (cdr bodys_1)))))))) + (loop_0 bodys_0)) + #f)) + (if (if (eq? 'values hd_0) + (let ((a_0 (cdr (unwrap v3_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_1))))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v3_0)))) + (let ((a_0 (car (unwrap d_0)))) a_0)))) + (lambda?.1 simple?1_0 body_0)) + #f)))))))))))))))) +(define let-lambda?.1 + (|#%name| + let-lambda? + (lambda (simple?5_0 id7_0 rhs8_0 body9_0) + (begin + (let ((or-part_0 + (if (begin-unsafe + (let ((app_0 (unwrap id7_0))) (eq? app_0 (unwrap body9_0)))) + (lambda?.1 simple?5_0 rhs8_0) + #f))) + (if or-part_0 + or-part_0 + (if (not simple?5_0) (lambda?.1 simple?5_0 body9_0) #f))))))) +(define extract-lambda + (lambda (v_0) + (let ((hd_0 + (let ((p_0 (unwrap v_0))) (if (pair? p_0) (unwrap (car p_0)) #f)))) + (if (if (eq? 'lambda hd_0) #t #f) + (values v_0 #t) + (if (if (eq? 'case-lambda hd_0) #t #f) + (values v_0 #t) + (if (if (eq? 'let-values hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (if (let ((a_3 (car p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 + (let ((a_2 (car p_1))) + (let ((a_3 (car (unwrap a_2)))) a_3)))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) a_2)))) + (let ((id_1 id_0)) (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) (extract-let-lambda #f id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'letrec-values hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (if (let ((a_3 (car p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 + (let ((a_2 (car p_1))) + (let ((a_3 (car (unwrap a_2)))) a_3)))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) + a_2)))) + (let ((id_1 id_0)) (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) (extract-let-lambda #t id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'let hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 (let ((a_2 (car p_1))) a_2))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) + a_2)))) + (let ((id_1 id_0)) + (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) + (extract-let-lambda #f id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'letrec* hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (if (let ((a_1 (car p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (if (let ((a_2 (car p_1))) + (let ((p_2 (unwrap a_2))) + (if (pair? p_2) + (let ((a_3 (cdr p_2))) + (let ((p_3 (unwrap a_3))) + (if (pair? p_3) + (let ((a_4 (cdr p_3))) + (begin-unsafe + (let ((app_0 + (unwrap '()))) + (eq? + app_0 + (unwrap a_4))))) + #f))) + #f))) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f) + #f))) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f) + #f))) + #f) + (call-with-values + (lambda () + (let ((d_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap d_0))) + (call-with-values + (lambda () + (let ((a_0 (car p_0))) + (let ((a_1 (car (unwrap a_0)))) + (let ((p_1 (unwrap a_1))) + (let ((id_0 (let ((a_2 (car p_1))) a_2))) + (let ((rhs_0 + (let ((d_1 (cdr p_1))) + (let ((a_2 (car (unwrap d_1)))) + a_2)))) + (let ((id_1 id_0)) + (values id_1 rhs_0)))))))) + (case-lambda + ((id_0 rhs_0) + (let ((body_0 + (let ((d_1 (cdr p_0))) + (let ((a_0 (car (unwrap d_1)))) a_0)))) + (let ((id_1 id_0) (rhs_1 rhs_0)) + (values id_1 rhs_1 body_0)))) + (args + (raise-binding-result-arity-error 2 args))))))) + (case-lambda + ((id_0 rhs_0 body_0) + (extract-let-lambda #t id_0 rhs_0 body_0)) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'let-values hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((d_1 (cdr (unwrap d_0)))) + (let ((a_0 (car (unwrap d_1)))) a_0))))) + (extract-lambda* body_0)) + (if (if (eq? 'letrec-values hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((d_1 (cdr (unwrap d_0)))) + (let ((a_0 (car (unwrap d_1)))) a_0))))) + (extract-lambda* body_0)) + (if (if (eq? 'let hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((d_1 (cdr (unwrap d_0)))) + (let ((a_0 (car (unwrap d_1)))) a_0))))) + (extract-lambda* body_0)) + (if (if (eq? 'letrec* hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (let ((p_1 (unwrap a_1))) + (if (pair? p_1) + (let ((a_2 (cdr p_1))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_2))))) + #f))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((d_1 (cdr (unwrap d_0)))) + (let ((a_0 (car (unwrap d_1)))) a_0))))) + (extract-lambda* body_0)) + (if (if (eq? 'begin hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_1))))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((a_0 (car (unwrap d_0)))) a_0)))) + (extract-lambda body_0)) + (if (if (eq? 'begin hd_0) #t #f) + (let ((bodys_0 + (let ((d_0 (cdr (unwrap v_0)))) d_0))) + (letrec* + ((loop_0 + (|#%name| + loop + (lambda (bodys_1) + (begin + (if (null? (cdr bodys_1)) + (extract-lambda* (car bodys_1)) + (loop_0 (cdr bodys_1)))))))) + (loop_0 bodys_0))) + (if (if (eq? 'values hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_1))))) + #f))) + #f) + (let ((body_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((a_0 (car (unwrap d_0)))) + a_0)))) + (extract-lambda body_0)) + (error 'match "failed ~e" v_0))))))))))))))))) +(define extract-let-lambda + (lambda (rec?_0 id_0 rhs_0 body_0) + (if (begin-unsafe + (let ((app_0 (unwrap id_0))) (eq? app_0 (unwrap body_0)))) + (if rec?_0 (extract-lambda* rhs_0) (extract-lambda rhs_0)) + (extract-lambda* body_0)))) +(define extract-lambda* + (lambda (v_0) + (call-with-values + (lambda () (extract-lambda v_0)) + (case-lambda + ((lam_0 inlinable?_0) (values lam_0 #f)) + (args (raise-binding-result-arity-error 2 args)))))) +(define lambda-arity-mask + (lambda (v_0) + (let ((hd_0 + (let ((p_0 (unwrap v_0))) (if (pair? p_0) (unwrap (car p_0)) #f)))) + (if (if (eq? 'lambda hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) (if (pair? p_0) #t #f))) + #f) + (let ((args_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((a_0 (car (unwrap d_0)))) a_0)))) + (args-arity-mask args_0)) + (if (if (eq? 'case-lambda hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (if (wrap-list? a_0) + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (result_0 lst_0) + (begin + (if (not (begin-unsafe (null? (unwrap lst_0)))) + (let ((v_1 + (if (begin-unsafe (pair? (unwrap lst_0))) + (wrap-car lst_0) + lst_0))) + (let ((rest_0 + (if (begin-unsafe + (pair? (unwrap lst_0))) + (wrap-cdr lst_0) + null))) + (let ((v_2 v_1)) + (let ((result_1 + (let ((result_1 + (let ((p_0 (unwrap v_2))) + (if (pair? p_0) #t #f)))) + (values result_1)))) + (if (if (not + (let ((x_0 (list v_2))) + (not result_1))) + #t + #f) + (for-loop_0 result_1 rest_0) + result_1))))) + result_0)))))) + (for-loop_0 #t a_0))) + #f)) + #f) + (let ((argss_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((argss_0 + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (argss_0 lst_0) + (begin + (if (not + (begin-unsafe (null? (unwrap lst_0)))) + (let ((v_1 + (if (begin-unsafe + (pair? (unwrap lst_0))) + (wrap-car lst_0) + lst_0))) + (let ((rest_0 + (if (begin-unsafe + (pair? (unwrap lst_0))) + (wrap-cdr lst_0) + null))) + (let ((v_2 v_1)) + (let ((argss_1 + (let ((argss_1 + (let ((argss39_0 + (let ((a_0 + (car + (unwrap + v_2)))) + a_0))) + (cons + argss39_0 + argss_0)))) + (values argss_1)))) + (for-loop_0 argss_1 rest_0))))) + argss_0)))))) + (for-loop_0 null d_0))))) + (reverse$1 argss_0))))) + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (mask_0 lst_0) + (begin + (if (pair? lst_0) + (let ((args_0 (unsafe-car lst_0))) + (let ((rest_0 (unsafe-cdr lst_0))) + (let ((mask_1 + (let ((mask_1 + (bitwise-ior + mask_0 + (args-arity-mask args_0)))) + (values mask_1)))) + (for-loop_0 mask_1 rest_0)))) + mask_0)))))) + (for-loop_0 0 argss_0)))) + (error 'match "failed ~e" v_0)))))) +(define args-arity-mask + (lambda (args_0) + (if (begin-unsafe (null? (unwrap args_0))) + 1 + (if (begin-unsafe (pair? (unwrap args_0))) + (arithmetic-shift (args-arity-mask (wrap-cdr args_0)) 1) + -1)))) (define try-fold-primitive (lambda (orig-prim-sym_0 orig-k_0 exps_0 prim-knowns_0 primitives_0) (let ((prim-sym_0 @@ -9436,36 +10392,39 @@ (let ((e_0 (let ((d_0 (cdr (unwrap v_0)))) (let ((a_0 (car (unwrap d_0)))) a_0)))) - (let ((u_0 (unwrap e_0))) - (if (symbol? u_0) - (let ((k_0 - (begin-unsafe - (call-with-values - (lambda () - (find-known+import - u_0 - prim-knowns_0 - knowns_0 - imports_0 - mutated_0)) - (case-lambda - ((k_0 im_0) k_0) - (args - (raise-binding-result-arity-error 2 args))))))) - (if (known-procedure? k_0) #t v_0)) - v_0))) + (if (lambda?.1 #f e_0) + (call-with-values + (lambda () (extract-lambda e_0)) + (case-lambda + ((lam_0 inlinable?_0) + (if inlinable?_0 #t (list* 'begin e_0 '(#t)))) + (args (raise-binding-result-arity-error 2 args)))) + (let ((u_0 (unwrap e_0))) + (if (symbol? u_0) + (let ((k_0 + (begin-unsafe + (call-with-values + (lambda () + (find-known+import + u_0 + prim-knowns_0 + knowns_0 + imports_0 + mutated_0)) + (case-lambda + ((k_0 im_0) k_0) + (args + (raise-binding-result-arity-error + 2 + args))))))) + (if (known-procedure? k_0) #t v_0)) + v_0)))) (if (if (eq? 'procedure-arity-includes? hd_0) (let ((a_0 (cdr (unwrap v_0)))) (let ((p_0 (unwrap a_0))) (if (pair? p_0) (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) + (let ((p_1 (unwrap a_1))) (if (pair? p_1) #t #f))) #f))) #f) (call-with-values @@ -9473,124 +10432,165 @@ (let ((d_0 (cdr (unwrap v_0)))) (let ((p_0 (unwrap d_0))) (let ((e_0 (let ((a_0 (car p_0))) a_0))) - (let ((n_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((e_1 e_0)) (values e_1 n_0))))))) + (call-with-values + (lambda () + (let ((d_1 (cdr p_0))) + (let ((p_1 (unwrap d_1))) + (let ((n_0 (let ((a_0 (car p_1))) a_0))) + (let ((opt_0 (let ((d_2 (cdr p_1))) d_2))) + (let ((n_1 n_0)) (values n_1 opt_0))))))) + (case-lambda + ((n_0 opt_0) + (let ((e_1 e_0)) (values e_1 n_0 opt_0))) + (args + (raise-binding-result-arity-error 2 args)))))))) (case-lambda - ((e_0 n_0) - (let ((u_0 (unwrap e_0))) - (let ((u-n_0 (unwrap n_0))) - (if (if (symbol? u_0) - (exact-nonnegative-integer? n_0) - #f) - (let ((k_0 - (begin-unsafe - (call-with-values - (lambda () - (find-known+import - u_0 - prim-knowns_0 - knowns_0 - imports_0 - mutated_0)) - (case-lambda - ((k_0 im_0) k_0) - (args - (raise-binding-result-arity-error - 2 - args))))))) - (if (if (known-procedure? k_0) + ((e_0 n_0 opt_0) + (let ((u-n_0 (unwrap n_0))) + (if (if (exact-nonnegative-integer? n_0) + (let ((or-part_0 (null? opt_0))) + (if or-part_0 + or-part_0 + (if (null? (cdr opt_0)) + (literal? (car opt_0)) + #f))) + #f) + (if (lambda?.1 #f e_0) + (call-with-values + (lambda () (extract-lambda e_0)) + (case-lambda + ((lam_0 inlinable?_0) + (let ((inc?_0 + (bitwise-bit-set? + (lambda-arity-mask lam_0) + n_0))) + (if inlinable?_0 + inc?_0 + (list 'begin e_0 inc?_0)))) + (args (raise-binding-result-arity-error 2 args)))) + (let ((u_0 (unwrap e_0))) + (if (symbol? u_0) + (let ((k_0 + (begin-unsafe + (call-with-values + (lambda () + (find-known+import + u_0 + prim-knowns_0 + knowns_0 + imports_0 + mutated_0)) + (case-lambda + ((k_0 im_0) k_0) + (args + (raise-binding-result-arity-error + 2 + args))))))) + (if (known-procedure? k_0) (bitwise-bit-set? (known-procedure-arity-mask k_0) u-n_0) - #f) - #t - v_0)) - v_0)))) - (args (raise-binding-result-arity-error 2 args)))) - (if (let ((p_0 (unwrap v_0))) (if (pair? p_0) #t #f)) - (call-with-values - (lambda () - (let ((p_0 (unwrap v_0))) - (let ((rator_0 (let ((a_0 (car p_0))) a_0))) - (let ((rands_0 (let ((d_0 (cdr p_0))) d_0))) - (let ((rator_1 rator_0)) - (values rator_1 rands_0)))))) - (case-lambda - ((rator_0 rands_0) - (let ((u-rator_0 (unwrap rator_0))) - (let ((k_0 - (if (symbol? u-rator_0) - (hash-ref prim-knowns_0 u-rator_0 #f) - #f))) - (let ((c1_0 - (if k_0 - (if (let ((or-part_0 - (known-procedure/folding? k_0))) - (if or-part_0 - or-part_0 - (let ((or-part_1 - (known-procedure/pure/folding? - k_0))) - (if or-part_1 - or-part_1 - (known-procedure/has-unsafe/folding? - k_0))))) - (if (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (pair? lst_0) - (let ((rand_0 - (unsafe-car lst_0))) - (let ((rest_0 - (unsafe-cdr - lst_0))) - (let ((result_1 - (let ((result_1 - (literal? - rand_0))) - (values - result_1)))) - (if (if (not - (let ((x_0 - (list - rand_0))) - (not - result_1))) - #t - #f) - (for-loop_0 - result_1 - rest_0) - result_1)))) - result_0)))))) - (for-loop_0 #t rands_0))) - (try-fold-primitive - u-rator_0 - k_0 - rands_0 - prim-knowns_0 - primitives_0) - #f) - #f) + v_0)) + v_0))) + v_0))) + (args (raise-binding-result-arity-error 3 args)))) + (if (if (eq? 'procedure-specialize hd_0) + (let ((a_0 (cdr (unwrap v_0)))) + (let ((p_0 (unwrap a_0))) + (if (pair? p_0) + (let ((a_1 (cdr p_0))) + (begin-unsafe + (let ((app_0 (unwrap '()))) + (eq? app_0 (unwrap a_1))))) + #f))) + #f) + (let ((e_0 + (let ((d_0 (cdr (unwrap v_0)))) + (let ((a_0 (car (unwrap d_0)))) a_0)))) + (if (lambda?.1 #f e_0) e_0 v_0)) + (if (let ((p_0 (unwrap v_0))) (if (pair? p_0) #t #f)) + (call-with-values + (lambda () + (let ((p_0 (unwrap v_0))) + (let ((rator_0 (let ((a_0 (car p_0))) a_0))) + (let ((rands_0 (let ((d_0 (cdr p_0))) d_0))) + (let ((rator_1 rator_0)) + (values rator_1 rands_0)))))) + (case-lambda + ((rator_0 rands_0) + (let ((u-rator_0 (unwrap rator_0))) + (let ((k_0 + (if (symbol? u-rator_0) + (hash-ref prim-knowns_0 u-rator_0 #f) #f))) - (if c1_0 (car c1_0) v_0))))) - (args (raise-binding-result-arity-error 2 args)))) - (let ((u_0 (unwrap v_0))) - (if (symbol? u_0) - (let ((k_0 (hash-ref-either knowns_0 imports_0 u_0))) - (if (if (known-literal? k_0) - (simple-mutated-state? - (hash-ref mutated_0 u_0 #f)) - #f) - (wrap-literal (known-literal-value k_0)) - v_0)) - v_0))))))))))) + (let ((c1_0 + (if k_0 + (if (let ((or-part_0 + (known-procedure/folding? k_0))) + (if or-part_0 + or-part_0 + (let ((or-part_1 + (known-procedure/pure/folding? + k_0))) + (if or-part_1 + or-part_1 + (known-procedure/has-unsafe/folding? + k_0))))) + (if (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (result_0 lst_0) + (begin + (if (pair? lst_0) + (let ((rand_0 + (unsafe-car + lst_0))) + (let ((rest_0 + (unsafe-cdr + lst_0))) + (let ((result_1 + (let ((result_1 + (literal? + rand_0))) + (values + result_1)))) + (if (if (not + (let ((x_0 + (list + rand_0))) + (not + result_1))) + #t + #f) + (for-loop_0 + result_1 + rest_0) + result_1)))) + result_0)))))) + (for-loop_0 #t rands_0))) + (try-fold-primitive + u-rator_0 + k_0 + rands_0 + prim-knowns_0 + primitives_0) + #f) + #f) + #f))) + (if c1_0 (car c1_0) v_0))))) + (args (raise-binding-result-arity-error 2 args)))) + (let ((u_0 (unwrap v_0))) + (if (symbol? u_0) + (let ((k_0 (hash-ref-either knowns_0 imports_0 u_0))) + (if (if (known-literal? k_0) + (simple-mutated-state? + (hash-ref mutated_0 u_0 #f)) + #f) + (wrap-literal (known-literal-value k_0)) + v_0)) + v_0)))))))))))) (define optimize* (lambda (v_0 prim-knowns_0 @@ -9743,14 +10743,14 @@ formalss_2 bodys_1)))))) (case-lambda - ((formalss1_0 - bodys2_0) + ((formalss4_0 + bodys5_0) (values (cons - formalss1_0 + formalss4_0 formalss_0) (cons - bodys2_0 + bodys5_0 bodys_0))) (args (raise-binding-result-arity-error @@ -10396,14 +11396,14 @@ idss_2 rhss_1)))))) (case-lambda - ((idss3_0 - rhss4_0) + ((idss6_0 + rhss7_0) (values (cons - idss3_0 + idss6_0 idss_0) (cons - rhss4_0 + rhss7_0 rhss_0))) (args (raise-binding-result-arity-error @@ -13320,933 +14320,6 @@ (lambda (k_0) (let ((or-part_0 (not k_0))) (if or-part_0 or-part_0 (eq? k_0 a-known-constant))))) -(define lambda?.1 - (|#%name| - lambda? - (lambda (simple?18_0 v20_0) - (begin - (let ((hd_0 - (let ((p_0 (unwrap v20_0))) - (if (pair? p_0) (unwrap (car p_0)) #f)))) - (if (if (eq? 'lambda hd_0) #t #f) - #t - (if (if (eq? 'case-lambda hd_0) #t #f) - #t - (if (if (eq? 'let-values hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (if (let ((a_3 (car p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 - (let ((a_2 (car p_1))) - (let ((a_3 (car (unwrap a_2)))) a_3)))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) - a_2)))) - (let ((id_1 id_0)) - (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) - (let-lambda?.1 simple?18_0 id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'letrec-values hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (if (let ((a_3 (car p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 - (let ((a_2 (car p_1))) - (let ((a_3 (car (unwrap a_2)))) - a_3)))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) - a_2)))) - (let ((id_1 id_0)) - (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) - (let-lambda?.1 simple?18_0 id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'let hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 (let ((a_2 (car p_1))) a_2))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) - a_2)))) - (let ((id_1 id_0)) - (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args - (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) - (let-lambda?.1 simple?18_0 id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'letrec* hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap - '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 (let ((a_2 (car p_1))) a_2))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) - a_2)))) - (let ((id_1 id_0)) - (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args - (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) - (let-lambda?.1 simple?18_0 id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'let-values hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((d_1 (cdr (unwrap d_0)))) - (let ((a_0 (car (unwrap d_1)))) a_0))))) - (if (not simple?18_0) (lambda?.1 #f body_0) #f)) - (if (if (eq? 'letrec-values hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((d_1 (cdr (unwrap d_0)))) - (let ((a_0 (car (unwrap d_1)))) a_0))))) - (if (not simple?18_0) (lambda?.1 #f body_0) #f)) - (if (if (eq? 'begin hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_1))))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((a_0 (car (unwrap d_0)))) a_0)))) - (lambda?.1 simple?18_0 body_0)) - (if (if (eq? 'values hd_0) - (let ((a_0 (cdr (unwrap v20_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_1))))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v20_0)))) - (let ((a_0 (car (unwrap d_0)))) a_0)))) - (lambda?.1 simple?18_0 body_0)) - #f))))))))))))))) -(define let-lambda?.1 - (|#%name| - let-lambda? - (lambda (simple?22_0 id24_0 rhs25_0 body26_0) - (begin - (let ((or-part_0 - (if (begin-unsafe - (let ((app_0 (unwrap id24_0))) - (eq? app_0 (unwrap body26_0)))) - (lambda?.1 simple?22_0 rhs25_0) - #f))) - (if or-part_0 - or-part_0 - (if (not simple?22_0) (lambda?.1 simple?22_0 body26_0) #f))))))) -(define extract-lambda - (lambda (v_0) - (let ((hd_0 - (let ((p_0 (unwrap v_0))) (if (pair? p_0) (unwrap (car p_0)) #f)))) - (if (if (eq? 'lambda hd_0) #t #f) - (values v_0 #t) - (if (if (eq? 'case-lambda hd_0) #t #f) - (values v_0 #t) - (if (if (eq? 'let-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (if (let ((a_3 (car p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 - (let ((a_2 (car p_1))) - (let ((a_3 (car (unwrap a_2)))) a_3)))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) a_2)))) - (let ((id_1 id_0)) (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) (extract-let-lambda #f id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'letrec-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (if (let ((a_3 (car p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 - (let ((a_2 (car p_1))) - (let ((a_3 (car (unwrap a_2)))) a_3)))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) - a_2)))) - (let ((id_1 id_0)) (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) (extract-let-lambda #t id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'let hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 (let ((a_2 (car p_1))) a_2))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) - a_2)))) - (let ((id_1 id_0)) - (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) - (extract-let-lambda #f id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'letrec* hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (if (let ((a_1 (car p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (if (let ((a_2 (car p_1))) - (let ((p_2 (unwrap a_2))) - (if (pair? p_2) - (let ((a_3 (cdr p_2))) - (let ((p_3 (unwrap a_3))) - (if (pair? p_3) - (let ((a_4 (cdr p_3))) - (begin-unsafe - (let ((app_0 - (unwrap '()))) - (eq? - app_0 - (unwrap a_4))))) - #f))) - #f))) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f) - #f))) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f) - #f))) - #f) - (call-with-values - (lambda () - (let ((d_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap d_0))) - (call-with-values - (lambda () - (let ((a_0 (car p_0))) - (let ((a_1 (car (unwrap a_0)))) - (let ((p_1 (unwrap a_1))) - (let ((id_0 (let ((a_2 (car p_1))) a_2))) - (let ((rhs_0 - (let ((d_1 (cdr p_1))) - (let ((a_2 (car (unwrap d_1)))) - a_2)))) - (let ((id_1 id_0)) - (values id_1 rhs_0)))))))) - (case-lambda - ((id_0 rhs_0) - (let ((body_0 - (let ((d_1 (cdr p_0))) - (let ((a_0 (car (unwrap d_1)))) a_0)))) - (let ((id_1 id_0) (rhs_1 rhs_0)) - (values id_1 rhs_1 body_0)))) - (args - (raise-binding-result-arity-error 2 args))))))) - (case-lambda - ((id_0 rhs_0 body_0) - (extract-let-lambda #t id_0 rhs_0 body_0)) - (args (raise-binding-result-arity-error 3 args)))) - (if (if (eq? 'let-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((d_1 (cdr (unwrap d_0)))) - (let ((a_0 (car (unwrap d_1)))) a_0))))) - (extract-lambda* body_0)) - (if (if (eq? 'letrec-values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((d_1 (cdr (unwrap d_0)))) - (let ((a_0 (car (unwrap d_1)))) a_0))))) - (extract-lambda* body_0)) - (if (if (eq? 'let hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((d_1 (cdr (unwrap d_0)))) - (let ((a_0 (car (unwrap d_1)))) a_0))))) - (extract-lambda* body_0)) - (if (if (eq? 'letrec* hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (let ((p_1 (unwrap a_1))) - (if (pair? p_1) - (let ((a_2 (cdr p_1))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_2))))) - #f))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((d_1 (cdr (unwrap d_0)))) - (let ((a_0 (car (unwrap d_1)))) a_0))))) - (extract-lambda* body_0)) - (if (if (eq? 'begin hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_1))))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((a_0 (car (unwrap d_0)))) a_0)))) - (extract-lambda body_0)) - (if (if (eq? 'values hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) - (if (pair? p_0) - (let ((a_1 (cdr p_0))) - (begin-unsafe - (let ((app_0 (unwrap '()))) - (eq? app_0 (unwrap a_1))))) - #f))) - #f) - (let ((body_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((a_0 (car (unwrap d_0)))) a_0)))) - (extract-lambda body_0)) - (error 'match "failed ~e" v_0)))))))))))))))) -(define extract-let-lambda - (lambda (rec?_0 id_0 rhs_0 body_0) - (if (begin-unsafe - (let ((app_0 (unwrap id_0))) (eq? app_0 (unwrap body_0)))) - (if rec?_0 (extract-lambda* rhs_0) (extract-lambda rhs_0)) - (extract-lambda* body_0)))) -(define extract-lambda* - (lambda (v_0) - (call-with-values - (lambda () (extract-lambda v_0)) - (case-lambda - ((lam_0 inlinable?_0) (values lam_0 #f)) - (args (raise-binding-result-arity-error 2 args)))))) -(define lambda-arity-mask - (lambda (v_0) - (let ((hd_0 - (let ((p_0 (unwrap v_0))) (if (pair? p_0) (unwrap (car p_0)) #f)))) - (if (if (eq? 'lambda hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (let ((p_0 (unwrap a_0))) (if (pair? p_0) #t #f))) - #f) - (let ((args_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((a_0 (car (unwrap d_0)))) a_0)))) - (args-arity-mask args_0)) - (if (if (eq? 'case-lambda hd_0) - (let ((a_0 (cdr (unwrap v_0)))) - (if (wrap-list? a_0) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (result_0 lst_0) - (begin - (if (not (begin-unsafe (null? (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe (pair? (unwrap lst_0))) - (wrap-car lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? (unwrap lst_0))) - (wrap-cdr lst_0) - null))) - (let ((v_2 v_1)) - (let ((result_1 - (let ((result_1 - (let ((p_0 (unwrap v_2))) - (if (pair? p_0) #t #f)))) - (values result_1)))) - (if (if (not - (let ((x_0 (list v_2))) - (not result_1))) - #t - #f) - (for-loop_0 result_1 rest_0) - result_1))))) - result_0)))))) - (for-loop_0 #t a_0))) - #f)) - #f) - (let ((argss_0 - (let ((d_0 (cdr (unwrap v_0)))) - (let ((argss_0 - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (argss_0 lst_0) - (begin - (if (not - (begin-unsafe (null? (unwrap lst_0)))) - (let ((v_1 - (if (begin-unsafe - (pair? (unwrap lst_0))) - (wrap-car lst_0) - lst_0))) - (let ((rest_0 - (if (begin-unsafe - (pair? (unwrap lst_0))) - (wrap-cdr lst_0) - null))) - (let ((v_2 v_1)) - (let ((argss_1 - (let ((argss_1 - (let ((argss62_0 - (let ((a_0 - (car - (unwrap - v_2)))) - a_0))) - (cons - argss62_0 - argss_0)))) - (values argss_1)))) - (for-loop_0 argss_1 rest_0))))) - argss_0)))))) - (for-loop_0 null d_0))))) - (reverse$1 argss_0))))) - (begin - (letrec* - ((for-loop_0 - (|#%name| - for-loop - (lambda (mask_0 lst_0) - (begin - (if (pair? lst_0) - (let ((args_0 (unsafe-car lst_0))) - (let ((rest_0 (unsafe-cdr lst_0))) - (let ((mask_1 - (let ((mask_1 - (bitwise-ior - mask_0 - (args-arity-mask args_0)))) - (values mask_1)))) - (for-loop_0 mask_1 rest_0)))) - mask_0)))))) - (for-loop_0 0 argss_0)))) - (error 'match "failed ~e" v_0)))))) -(define args-arity-mask - (lambda (args_0) - (if (begin-unsafe (null? (unwrap args_0))) - 1 - (if (begin-unsafe (pair? (unwrap args_0))) - (arithmetic-shift (args-arity-mask (wrap-cdr args_0)) 1) - -1)))) (define add-begin-unsafe (lambda (lam_0) (reannotate @@ -14346,10 +14419,10 @@ argss_2 bodys_1)))))) (case-lambda - ((argss63_0 bodys64_0) + ((argss26_0 bodys27_0) (values - (cons argss63_0 argss_0) - (cons bodys64_0 bodys_0))) + (cons argss26_0 argss_0) + (cons bodys27_0 bodys_0))) (args (raise-binding-result-arity-error 2 diff --git a/racket/src/schemify/infer-known.rkt b/racket/src/schemify/infer-known.rkt index 6a7eb7c2bd..8940a255ac 100644 --- a/racket/src/schemify/infer-known.rkt +++ b/racket/src/schemify/infer-known.rkt @@ -11,6 +11,7 @@ "mutated-state.rkt" "optimize.rkt" "single-valued.rkt" + "lambda.rkt" "aim.rkt") (provide infer-known @@ -105,68 +106,6 @@ ;; ---------------------------------------- -;; Recognize forms that produce plain procedures; expression can be -;; pre- or post-schemify -(define (lambda? v #:simple? [simple? #f]) - (match v - [`(lambda . ,_) #t] - [`(case-lambda . ,_) #t] - [`(let-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] - [`(letrec-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] - [`(let ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] - [`(letrec* ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] - [`(let-values ,_ ,body) (and (not simple?) (lambda? body))] - [`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))] - [`(begin ,body) (lambda? body #:simple? simple?)] - [`(values ,body) (lambda? body #:simple? simple?)] - [`,_ #f])) - -(define (let-lambda? id rhs body #:simple? simple?) - (or (and (wrap-eq? id body) (lambda? rhs #:simple? simple?)) - (and (not simple?) - (lambda? body #:simple? simple?)))) - -;; Extract procedure from a form on which `lambda?` produces true -(define (extract-lambda v) - (match v - [`(lambda . ,_) (values v #t)] - [`(case-lambda . ,_) (values v #t)] - [`(let-values ([(,id) ,rhs]) ,body) (extract-let-lambda #f id rhs body)] - [`(letrec-values ([(,id) ,rhs]) ,body) (extract-let-lambda #t id rhs body)] - [`(let ([,id ,rhs]) ,body) (extract-let-lambda #f id rhs body)] - [`(letrec* ([,id ,rhs]) ,body) (extract-let-lambda #t id rhs body)] - [`(let-values ,_ ,body) (extract-lambda* body)] - [`(letrec-values ,_ ,body) (extract-lambda* body)] - [`(let ,_ ,body) (extract-lambda* body)] - [`(letrec* ,_ ,body) (extract-lambda* body)] - [`(begin ,body) (extract-lambda body)] - [`(values ,body) (extract-lambda body)])) - -(define (extract-let-lambda rec? id rhs body) - (if (wrap-eq? id body) - (if rec? - (extract-lambda* rhs) - (extract-lambda rhs)) - (extract-lambda* body))) - -(define (extract-lambda* v) - (define-values (lam inlinable?) (extract-lambda v)) - (values lam #f)) - -(define (lambda-arity-mask v) - (match v - [`(lambda ,args . ,_) (args-arity-mask args)] - [`(case-lambda [,argss . ,_] ...) - (for/fold ([mask 0]) ([args (in-list argss)]) - (bitwise-ior mask (args-arity-mask args)))])) - -(define (args-arity-mask args) - (cond - [(wrap-null? args) 1] - [(wrap-pair? args) - (arithmetic-shift (args-arity-mask (wrap-cdr args)) 1)] - [else -1])) - (define (add-begin-unsafe lam) (reannotate lam diff --git a/racket/src/schemify/lambda.rkt b/racket/src/schemify/lambda.rkt new file mode 100644 index 0000000000..14a93f6834 --- /dev/null +++ b/racket/src/schemify/lambda.rkt @@ -0,0 +1,80 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt") + +(provide lambda? + extract-lambda + lambda-arity-mask) + +;; ---------------------------------------- + +;; Recognize forms that produce plain procedures; expression can be +;; pre- or post-schemify +(define (lambda? v #:simple? [simple? #f]) + (match v + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`(let-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] + [`(letrec-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] + [`(let ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] + [`(letrec* ([,id ,rhs]) ,body) (let-lambda? id rhs body #:simple? simple?)] + [`(let-values ,_ ,body) (and (not simple?) (lambda? body))] + [`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))] + [`(begin ,body) (lambda? body #:simple? simple?)] + [`(begin . ,bodys) (and (not simple?) + (let loop ([bodys bodys]) + (if (null? (cdr bodys)) + (lambda? (car bodys) #:simple? simple?) + (loop (cdr bodys)))))] + [`(values ,body) (lambda? body #:simple? simple?)] + [`,_ #f])) + +(define (let-lambda? id rhs body #:simple? simple?) + (or (and (wrap-eq? id body) (lambda? rhs #:simple? simple?)) + (and (not simple?) + (lambda? body #:simple? simple?)))) + +;; Extract procedure from a form on which `lambda?` produces true +(define (extract-lambda v) + (match v + [`(lambda . ,_) (values v #t)] + [`(case-lambda . ,_) (values v #t)] + [`(let-values ([(,id) ,rhs]) ,body) (extract-let-lambda #f id rhs body)] + [`(letrec-values ([(,id) ,rhs]) ,body) (extract-let-lambda #t id rhs body)] + [`(let ([,id ,rhs]) ,body) (extract-let-lambda #f id rhs body)] + [`(letrec* ([,id ,rhs]) ,body) (extract-let-lambda #t id rhs body)] + [`(let-values ,_ ,body) (extract-lambda* body)] + [`(letrec-values ,_ ,body) (extract-lambda* body)] + [`(let ,_ ,body) (extract-lambda* body)] + [`(letrec* ,_ ,body) (extract-lambda* body)] + [`(begin ,body) (extract-lambda body)] + [`(begin . ,bodys) (let loop ([bodys bodys]) + (if (null? (cdr bodys)) + (extract-lambda* (car bodys)) + (loop (cdr bodys))))] + [`(values ,body) (extract-lambda body)])) + +(define (extract-let-lambda rec? id rhs body) + (if (wrap-eq? id body) + (if rec? + (extract-lambda* rhs) + (extract-lambda rhs)) + (extract-lambda* body))) + +(define (extract-lambda* v) + (define-values (lam inlinable?) (extract-lambda v)) + (values lam #f)) + +(define (lambda-arity-mask v) + (match v + [`(lambda ,args . ,_) (args-arity-mask args)] + [`(case-lambda [,argss . ,_] ...) + (for/fold ([mask 0]) ([args (in-list argss)]) + (bitwise-ior mask (args-arity-mask args)))])) + +(define (args-arity-mask args) + (cond + [(wrap-null? args) 1] + [(wrap-pair? args) + (arithmetic-shift (args-arity-mask (wrap-cdr args)) 1)] + [else -1])) diff --git a/racket/src/schemify/optimize.rkt b/racket/src/schemify/optimize.rkt index a5d05933d4..993753f46d 100644 --- a/racket/src/schemify/optimize.rkt +++ b/racket/src/schemify/optimize.rkt @@ -6,6 +6,8 @@ "find-known.rkt" "mutated-state.rkt" "literal.rkt" + "lambda.rkt" + "simple.rkt" "fold.rkt") (provide optimize @@ -28,26 +30,47 @@ `,(not (unwrap t)) v)] [`(procedure? ,e) - (define u (unwrap e)) (cond - [(symbol? u) - (define k (find-known u prim-knowns knowns imports mutated)) - (if (known-procedure? k) - '#t - v)] - [else v])] - [`(procedure-arity-includes? ,e ,n) - (define u (unwrap e)) + [(lambda? e) + (define-values (lam inlinable?) (extract-lambda e)) + (if inlinable? + #t + `(begin ,e #t))] + [else + (define u (unwrap e)) + (cond + [(symbol? u) + (define k (find-known u prim-knowns knowns imports mutated)) + (if (known-procedure? k) + '#t + v)] + [else v])])] + [`(procedure-arity-includes? ,e ,n . ,opt) (define u-n (unwrap n)) (cond - [(and (symbol? u) - (exact-nonnegative-integer? n)) - (define k (find-known u prim-knowns knowns imports mutated)) - (if (and (known-procedure? k) - (bitwise-bit-set? (known-procedure-arity-mask k) u-n)) - '#t - v)] + [(and (exact-nonnegative-integer? n) + (or (null? opt) + (and (null? (cdr opt)) + (literal? (car opt))))) + (cond + [(lambda? e) + (define-values (lam inlinable?) (extract-lambda e)) + (define inc? (bitwise-bit-set? (lambda-arity-mask lam) n)) + (if inlinable? + inc? + `(begin ,e ,inc?))] + [else + (define u (unwrap e)) + (cond + [(symbol? u) + (define k (find-known u prim-knowns knowns imports mutated)) + (if (known-procedure? k) + (bitwise-bit-set? (known-procedure-arity-mask k) u-n) + v)] + [else v])])] [else v])] + [`(procedure-specialize ,e) + (if (lambda? e) e v)] [`(,rator . ,rands) (define u-rator (unwrap rator)) (define k (and (symbol? u-rator) (hash-ref prim-knowns u-rator #f)))