126 lines
5.1 KiB
Scheme
126 lines
5.1 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/list)
|
|
(require scheme/match)
|
|
(require (file "utilities.scm"))
|
|
|
|
(provide reduce-variables
|
|
reduce-set!
|
|
propogate-set!
|
|
optimize-function)
|
|
|
|
(define (optimize-function simple-lambda-form)
|
|
((compose reduce-variables
|
|
reduce-set!
|
|
propogate-set!)
|
|
simple-lambda-form))
|
|
|
|
; Don't bind variables which aren't referenced.
|
|
(define (reduce-variables form)
|
|
(define (bind-fn recurse op vars . subforms)
|
|
(let* ([reduced-forms (map recurse subforms)]
|
|
[ref-vars (remove-duplicates (append-map free-variables reduced-forms))])
|
|
(define (referenced? var) (and (memq var ref-vars) #t))
|
|
`(%bind ,(filter referenced? vars)
|
|
,@reduced-forms)))
|
|
(map-form form #:bind bind-fn))
|
|
|
|
; Don't set variables which won't be accessed later.
|
|
(define (reduce-set! form)
|
|
(define (bind-fn recurse op vars . subforms)
|
|
(define (prepend-if-used subform after)
|
|
(if (and (pair? subform)
|
|
(eq? (first subform) '%set!)
|
|
(or (memq (second subform) vars)
|
|
(error "Setting unbound (constant) variable:" subform))
|
|
(not (value-used? (second subform) after)))
|
|
after
|
|
(cons subform after)))
|
|
`(%bind ,vars
|
|
,@(foldr prepend-if-used '() (map recurse subforms))))
|
|
(map-form form #:bind bind-fn))
|
|
|
|
(define (propogate-value variable value invalidates? forms)
|
|
(if (null? forms)
|
|
forms
|
|
(let* ([form (car forms)]
|
|
[after (cdr forms)]
|
|
[new-form (case (first form)
|
|
[(%set!) (if (eq? (third form) variable)
|
|
`(%set! ,(second form) ,value)
|
|
form)]
|
|
[else form])])
|
|
(if (or (and (eq? (first (car forms)) '%set!)
|
|
(eq? (second (car forms)) variable))
|
|
(invalidates? new-form))
|
|
(cons new-form after)
|
|
(cons new-form (propogate-value variable value invalidates? after))))))
|
|
|
|
; Simple values (literals, variables) can replace arguments as well as %set! values.
|
|
(define (propogate-simple-value variable value invalidates? forms)
|
|
(if (null? forms)
|
|
forms
|
|
(let* ([form (car forms)]
|
|
[after (cdr forms)]
|
|
[new-form (case (first form)
|
|
[(%set!)
|
|
(let ([set-value (if (eq? (third form) variable) value (third form))])
|
|
(if (simple-value? set-value)
|
|
`(%set! ,(second form) ,set-value)
|
|
`(%set! ,(second form)
|
|
(,(first set-value)
|
|
,@(subst variable value (cdr set-value))))))]
|
|
[else `(,(first form) ,@(subst variable value (cdr form)))])])
|
|
(if (or (and (eq? (first (car forms)) '%set!)
|
|
(eq? (second (car forms)) variable))
|
|
(invalidates? new-form))
|
|
(cons new-form after)
|
|
(cons new-form (propogate-simple-value variable value invalidates? after))))))
|
|
|
|
; When value of var2 is known, change (%set! var1 var2) to (%set! var1 value).
|
|
; Known values are:
|
|
; literals, always
|
|
; var, until (%set! var ...)
|
|
; (%unbox var), until (%set-box! ...) or (%set! var)
|
|
; (%car var), until (%set-car! ...) or (%set! var)
|
|
; (%cdr var), until (%set-cdr! ...) or (%set! var)
|
|
(define (propogate-set! form)
|
|
(define (bind-fn recurse op vars . subforms)
|
|
(define (prepend subform after)
|
|
(cons
|
|
subform
|
|
(match subform
|
|
[`(%set! ,var ,(? simple-value? value))
|
|
(propogate-simple-value var value
|
|
(lambda (form)
|
|
(and (eq? (first form) '%set!)
|
|
(eq? (second form) value)))
|
|
after)]
|
|
[`(%set! ,var ,(and value `(%unbox ,box-var)))
|
|
(propogate-value var value
|
|
(lambda (form)
|
|
(or (and (eq? (first form) '%set!)
|
|
(eq? (second form) box-var))
|
|
(eq? (first form) '%set-box!)))
|
|
after)]
|
|
[`(%set! ,var ,(and value `(%car ,pair-var)))
|
|
(propogate-value var value
|
|
(lambda (form)
|
|
(or (and (eq? (first form) '%set!)
|
|
(eq? (second form) pair-var))
|
|
(eq? (first form) '%set-car!)))
|
|
after)]
|
|
[`(%set! ,var ,(and value `(%cdr ,pair-var)))
|
|
(propogate-value var value
|
|
(lambda (form)
|
|
(or (and (eq? (first form) '%set!)
|
|
(eq? (second form) pair-var))
|
|
(eq? (first form) '%set-cdr!)))
|
|
after)]
|
|
[_ after])))
|
|
`(%bind ,vars
|
|
,@(foldr prepend '() (map recurse subforms))))
|
|
(map-form form #:bind bind-fn))
|
|
|
|
; vim:set sw=2 expandtab:
|