suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

schemify: clean up unnecessary lets in interpreter

Browse Source 
Collapse `let` with unused binding to `begin`, and then
collapse resulting nested `begin`s.
This commit is contained in:
Matthew Flatt 2020-03-17 15:30:39 -06:00
parent b69c1208b7
commit 3390896a59
1 changed files with 58 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
racket/src/schemify/interpret.rkt
View File

@ -236,21 +236,37 @@
(define new-body (add-boxes/remove-unused c-body ids mutated body-env stk-i)) (define new-body (add-boxes/remove-unused c-body ids mutated body-env stk-i))
(define pos (stack->pos stack-depth stk-i #:nonuse? #t)) (define pos (stack->pos stack-depth stk-i #:nonuse? #t))
(stack-info-forget! stk-i stack-depth pos len) (stack-info-forget! stk-i stack-depth pos len)
(define new-rhss (list->vector (define new-rhss (compile-list rhss env stack-depth stk-i #f mutated))
(compile-list rhss env stack-depth stk-i #f mutated)))
(or (or
;; Merge nested `let`s into a `let*` to reduce vector nesting ;; Merge nested `let`s into a `let*` to reduce vector nesting
(cond (cond
[(null? new-rhss) new-body]
[(vector? new-body) [(vector? new-body)
(interp-match (interp-match
new-body new-body
[#(let ,pos2 ,rhss2 ,b) [#(let ,pos2 ,rhss2 ,b)
(vector 'let* (list pos pos2) (list new-rhss rhss2) b)] (vector 'let* (list pos pos2) (list (list->vector new-rhss) rhss2) b)]
[#(let* ,poss ,rhsss ,b) [#(let* ,poss ,rhsss ,b)
(vector 'let* (cons pos poss) (cons new-rhss rhsss) b)] (vector 'let* (cons pos poss) (cons (list->vector new-rhss) rhsss) b)]
[#(clear ,poss ,e)
;; Check check the `let`-bounding bindings are immediately cleared,
;; in which case they're unused
(let loop ([pos pos] [poss poss] [rhss new-rhss])
(cond
[(null? rhss)
;; bindings are unused
(let ([e (if (null? poss)
e
(vector 'clear poss e))])
;; Use `beginl` instead of `begin` to encourage further collapsing
(vector 'beginl (append new-rhss (begins->list e))))]
[(null? poss) #f]
[(eqv? pos (car poss))
(loop (add1 pos) (cdr poss) (cdr rhss))]
[else #f]))]
[#() #f])] [#() #f])]
[else #f]) [else #f])
(vector 'let pos new-rhss new-body))] (vector 'let pos (list->vector new-rhss) new-body))]
[`(letrec . ,_) (compile-letrec e env stack-depth stk-i tail? mutated)] [`(letrec . ,_) (compile-letrec e env stack-depth stk-i tail? mutated)]
[`(letrec* . ,_) (compile-letrec e env stack-depth stk-i tail? mutated)] [`(letrec* . ,_) (compile-letrec e env stack-depth stk-i tail? mutated)]
[`(begin . ,vs) [`(begin . ,vs)
@ -580,6 +596,28 @@
(box name) (box name)
name)) name))
(define (begins->list e)
;; Convert an expression to a list of expressions, trying to
;; flatten `begin`s.
(cond
[(vector? e)
(interp-match
e
[#(beginl ,es) es]
[#(begin)
(define len (sub1 (vector*-length e)))
(cond
[(len . < . 4)
(let loop ([i 1])
(cond
[(= i len)
(begins->list (vector*-ref e i))]
[else (cons (vector*-ref e i)
(loop (add1 i)))]))]
[else (list e)])]
[#() (list e)])]
[else (list e)]))
(with-deterministic-gensym (with-deterministic-gensym
(start linklet-e))) (start linklet-e)))
@ -782,6 +820,17 @@
(case-lambda (case-lambda
[(new-stack val) (loop (fx+ i 1) new-stack)] [(new-stack val) (loop (fx+ i 1) new-stack)]
[(new-stack . vals) (loop (fx+ i 1) new-stack)]))]))] [(new-stack . vals) (loop (fx+ i 1) new-stack)]))]))]
[#(beginl ,bs)
(let loop ([bs bs] [stack stack])
(cond
[(null? (cdr bs))
(interpret (car bs) stack return-mode)]
[else
(call-with-values
(lambda () (interpret (car bs) stack))
(case-lambda
[(new-stack val) (loop (cdr bs) new-stack)]
[(new-stack . vals) (loop (cdr bs) new-stack)]))]))]
[#(begin0 ,b0) [#(begin0 ,b0)
(define last (fx- (vector*-length b) 1)) (define last (fx- (vector*-length b) 1))
(call-with-values (call-with-values
@ -1036,7 +1085,10 @@
(let ([z y]) (let ([z y])
(vector x z)))) (vector x z))))
(define g (case-lambda (define g (case-lambda
[() no] [() (let ([unused (g)])
(let ([also-unused (g)])
(begin
(list (g no)))))]
[ys [ys
(vector x ys)]))) (vector x ys)])))
(define h (lambda (t x y a b) (define h (lambda (t x y a b)