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

schemify: expose more functions to lifting

Browse Source 
This improvement affects the interpreter's implementation, for
example.
This commit is contained in:
Matthew Flatt 2019-12-22 08:34:02 -07:00
parent 73ed7141aa
commit 71fb5e0f6a
2 changed files with 132 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
racket/src/schemify/schemify.rkt
View File

@ -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

102
racket/src/schemify/unnest-let.rkt Normal file
View File

@ -0,0 +1,102 @@
#lang racket/base
(require "wrap.rkt"
"match.rkt"
"simple.rkt")
(provide unnest-let)
;; Rotate something like
;;
;; (let ([x (let ([y <simple>])
;; <rhs>)])
;; <body>)
;;
;; to
;;
;; (let ([y <simple>])
;; (let ([x <rhs>])
;; <body>)))
;;
;; to better expose procedure bindings for the lifting phase.
;;
;; For `letrec*`, we rewrite to
;;
;; (letrec* ([y <simple>]
;; [x <rhs>])
;; <body>)
;;
;; because <simple> might refer to `x`. We only do that when <simple>
;; and <rhs> 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]))