diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index 5c7bf3f15b..f13dbd43d8 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -19,6 +19,7 @@ "infer-known.rkt" "inline.rkt" "letrec.rkt" + "unnest-let.rkt" "infer-name.rkt" "ptr-ref-set.rkt" "literal.rkt" @@ -493,16 +494,18 @@ (and (or (known-copy? k) (known-literal? k)) (simple-mutated-state? (hash-ref mutated u-id #f)))) - (left-to-right/let (for/list ([id (in-list ids)] - #:unless (merely-a-copy? id)) - id) - (for/list ([id (in-list ids)] - [rhs (in-list rhss)] - #:unless (merely-a-copy? id)) - (schemify rhs 'fresh)) - (for/list ([body (in-list bodys)]) - (schemify/knowns new-knowns inline-fuel wcm-state body)) - prim-knowns knowns imports mutated simples)] + (unnest-let + (left-to-right/let (for/list ([id (in-list ids)] + #:unless (merely-a-copy? id)) + id) + (for/list ([id (in-list ids)] + [rhs (in-list rhss)] + #:unless (merely-a-copy? id)) + (schemify rhs 'fresh)) + (for/list ([body (in-list bodys)]) + (schemify/knowns new-knowns inline-fuel wcm-state body)) + prim-knowns knowns imports mutated simples) + prim-knowns knowns imports mutated simples)] [`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...) `(begin ,@(schemify-body rhss 'fresh) ,@(schemify-body bodys wcm-state))] [`(let-values ([,idss ,rhss] ...) ,bodys ...) @@ -510,12 +513,14 @@ (struct-convert-local v prim-knowns knowns imports mutated simples (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) #:unsafe-mode? unsafe-mode?)) - (left-to-right/let-values idss - (for/list ([rhs (in-list rhss)]) - (schemify rhs 'fresh)) - (schemify-body bodys wcm-state) - mutated - for-cify?))] + (unnest-let + (left-to-right/let-values idss + (for/list ([rhs (in-list rhss)]) + (schemify rhs 'fresh)) + (schemify-body bodys wcm-state) + mutated + for-cify?) + prim-knowns knowns imports mutated simples))] [`(letrec-values () ,bodys ...) (schemify `(begin . ,bodys) wcm-state)] [`(letrec-values ([() (values)]) ,bodys ...) @@ -534,13 +539,15 @@ (values rhs-knowns (hash-set knowns u-id (or k a-known-constant)))] [k (values (hash-set rhs-knowns u-id k) (hash-set body-knowns u-id k))] [else (values rhs-knowns body-knowns)]))) - (letrec-conversion - ids mutated for-cify? - `(letrec* ,(for/list ([id (in-list ids)] - [rhs (in-list rhss)]) - `[,id ,(schemify/knowns rhs-knowns inline-fuel 'fresh rhs)]) - ,@(for/list ([body (in-list bodys)]) - (schemify/knowns body-knowns inline-fuel wcm-state body))))] + (unnest-let + (letrec-conversion + ids mutated for-cify? + `(letrec* ,(for/list ([id (in-list ids)] + [rhs (in-list rhss)]) + `[,id ,(schemify/knowns rhs-knowns inline-fuel 'fresh rhs)]) + ,@(for/list ([body (in-list bodys)]) + (schemify/knowns body-knowns inline-fuel wcm-state body)))) + prim-knowns knowns imports mutated simples)] [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) (cond [(struct-convert-local v #:letrec? #t prim-knowns knowns imports mutated simples diff --git a/racket/src/schemify/unnest-let.rkt b/racket/src/schemify/unnest-let.rkt new file mode 100644 index 0000000000..b1da5c1a17 --- /dev/null +++ b/racket/src/schemify/unnest-let.rkt @@ -0,0 +1,102 @@ +#lang racket/base +(require "wrap.rkt" + "match.rkt" + "simple.rkt") + +(provide unnest-let) + +;; Rotate something like +;; +;; (let ([x (let ([y ]) +;; )]) +;; ) +;; +;; to +;; +;; (let ([y ]) +;; (let ([x ]) +;; ))) +;; +;; to better expose procedure bindings for the lifting phase. +;; +;; For `letrec*`, we rewrite to +;; +;; (letrec* ([y ] + ;; [x ]) +;; ) +;; +;; because might refer to `x`. We only do that when +;; and are immediate `lambda` forms, though, to avoid +;; pessimizing a set of mutually recursive functions. + +(define (unnest-let e prim-knowns knowns imports mutated simples) + (match e + [`(,let-id (,binds ...) . ,body) + (cond + [(or (eq? let-id 'let) + (eq? let-id 'letrec*)) + (let loop ([binds binds] + [accum-binds '()] + [wraps '()] + [convert? #f]) + (cond + [(null? binds) + (if (not convert?) + e + (let loop ([wraps wraps] [e `(,let-id ,(reverse accum-binds) . ,body)]) + (cond + [(null? wraps) e] + [else + (loop (cdr wraps) + `(,(caar wraps) ,(cdar wraps) ,e))])))] + [else + (match (car binds) + [`[,id (,nest-let-id ([,ids ,rhss] ...) + ,body)] + (cond + [(not (or (eq? let-id 'let) + (immediate-lambda? body))) + e] + [(and (or (eq? 'let nest-let-id) + (eq? 'letrec* nest-let-id)) + (for/and ([rhs (in-list rhss)]) + (and (or (eq? 'let let-id) + (immediate-lambda? rhs)) + (simple? rhs prim-knowns knowns imports mutated simples)))) + (match (car binds) + [`[,_ (,_ ,inner-binds ,_)] + (cond + [(eq? 'let let-id) + ;; let: can lift out + (loop (cdr binds) + (cons `[,id ,body] accum-binds) + (cons (cons nest-let-id + inner-binds) + wraps) + #t)] + [else + ;; letrec: need to keep in same set of bindings + (loop (cdr binds) + (cons `[,id ,body] (append inner-binds accum-binds)) + wraps + #t)])])] + [else (loop (cdr binds) + (cons (car binds) accum-binds) + wraps + convert?)])] + [`[,_ ,rhs] + (if (or (eq? let-id 'let) + (immediate-lambda? rhs)) + (loop (cdr binds) + (cons (car binds) accum-binds) + wraps + convert?) + e)])]))] + [else e])] + [`,_ e])) + +(define (immediate-lambda? e) + (match e + [`(lambda . ,_) #t] + [`(case-lambda . ,_) #t] + [`,_ #f]))