Make remove-complex-opera more sophisticate (maybe more useful?)
This commit is contained in:
Enrico Lumetti
parent
f1c4cb627b
commit
c1c29c0782
|
|
@ -4,6 +4,16 @@
|
|||
|
||||
(provide remove-complex-opera*)
|
||||
|
||||
; remove complex SUB-expressions:
|
||||
; of course complex expression are possible
|
||||
; but their argument can only be either
|
||||
; - number
|
||||
; - symbol
|
||||
; - `(read)
|
||||
; temporary variables are introduced to make this possible
|
||||
; with the caveat that a binding should never associate
|
||||
; an existing symbol to a temporary
|
||||
; (Invariant of rco-arg)
|
||||
(define (remove-complex-opera* p)
|
||||
(let ([uniq-res (uniquify p)])
|
||||
(match (cadr uniq-res)
|
||||
|
|
@ -23,6 +33,42 @@
|
|||
(let-binding (car binding) (cadr binding)
|
||||
(wrap-associations (cdr assoc-list) exp)))))
|
||||
|
||||
(define (substitute-var old-var var expr)
|
||||
(match expr
|
||||
[(? fixnum?) expr]
|
||||
[`(read) expr]
|
||||
[(? symbol?)
|
||||
(if (eq? old-var expr) var expr)]
|
||||
[`(- ,e) `(- ,(substitute-var old-var var e))]
|
||||
[`(+ ,e1 ,e2)
|
||||
(begin
|
||||
(define se1 (substitute-var old-var var e1))
|
||||
(define se2 (substitute-var old-var var e2))
|
||||
`(+ ,se1 ,se2))]
|
||||
[`(let ([,v ,e]) ,body)
|
||||
(begin
|
||||
(define se (substitute-var old-var var e))
|
||||
(define sbody (substitute-var old-var var body))
|
||||
`(let ([,v ,se]) ,sbody))]))
|
||||
|
||||
(define (change-assoc-key assoc-list old-key new-key)
|
||||
(if (empty? assoc-list)
|
||||
`()
|
||||
(let ([key (caar assoc-list)])
|
||||
(let ([new-pair (if (eq? key old-key)
|
||||
`(,new-key . ,(cdar assoc-list))
|
||||
(car assoc-list))])
|
||||
(cons new-pair (change-assoc-key (cdr assoc-list) old-key new-key))))))
|
||||
|
||||
(define (is-tmp exp tmpcount)
|
||||
(if (and (symbol? exp) (string-prefix? (symbol->string exp) "tmp."))
|
||||
(let ([tmpvalue (string->number (substring (symbol->string exp) 4))])
|
||||
(if (and tmpvalue (> tmpvalue tmpcount))
|
||||
#t
|
||||
#f))
|
||||
#f))
|
||||
|
||||
|
||||
(define (rco-exp exp tmpcount)
|
||||
(match exp
|
||||
[(? fixnum?) (values exp tmpcount)]
|
||||
|
|
@ -40,19 +86,24 @@
|
|||
(values (wrap-associations (append assoc-list1 assoc-list2)
|
||||
`(,op ,new-exp1 ,new-exp2)) new-tmpcount))]
|
||||
[`(let ([,var ,e]) ,body)
|
||||
(define-values (new-exp assoc-list exp-tmpcount) (rco-arg e tmpcount))
|
||||
(begin
|
||||
(define-values (exp-tmp assoc-list exp-tmpcount) (rco-arg e tmpcount))
|
||||
(define-values (new-body new-tmpcount) (rco-exp body exp-tmpcount))
|
||||
(values (wrap-associations assoc-list
|
||||
`(let ([,var ,new-exp]) ,new-body)) new-tmpcount)]))
|
||||
(define elide-tmp (or (is-tmp exp-tmp tmpcount)))
|
||||
(set! assoc-list
|
||||
(if (or elide-tmp (fixnum? exp-tmp))
|
||||
(change-assoc-key assoc-list exp-tmp var)
|
||||
(append assoc-list (list `(,var ,exp-tmp)))))
|
||||
(set! new-body
|
||||
(if (symbol? exp-tmp)
|
||||
(if elide-tmp (substitute-var exp-tmp var new-body) new-body)
|
||||
`(let ([,var ,exp-tmp]) ,new-body)))
|
||||
(values (wrap-associations assoc-list new-body)
|
||||
new-tmpcount))]))
|
||||
|
||||
(define (get-unique-symbol tmpcount)
|
||||
(string->symbol (format "tmp.~a" tmpcount)))
|
||||
|
||||
(define (let-unique-exp tmpcount value)
|
||||
(let-binding (get-unique-symbol tmpcount)
|
||||
exp
|
||||
(get-unique-symbol tmpcount)))
|
||||
|
||||
(define (rco-arg exp tmpcount)
|
||||
(match exp
|
||||
[(? fixnum?) (values exp '() tmpcount)]
|
||||
|
|
@ -60,33 +111,37 @@
|
|||
[`(read) (values exp '() tmpcount)]
|
||||
[`(- ,e)
|
||||
(begin
|
||||
(define-values (new-exp exp-tmpcount) (rco-exp e tmpcount))
|
||||
(define-values (new-exp assoc-list exp-tmpcount) (rco-arg e tmpcount))
|
||||
(define new-tmpcount (+ exp-tmpcount 1))
|
||||
(define tmpname (get-unique-symbol new-tmpcount))
|
||||
(set! assoc-list (append assoc-list (list `(,tmpname (- ,new-exp)))))
|
||||
(values tmpname
|
||||
`((,tmpname (- ,new-exp)))
|
||||
assoc-list
|
||||
new-tmpcount))]
|
||||
[`(,op ,e1 ,e2)
|
||||
#:when (or (eq? op `+) (eq? op `-))
|
||||
(begin
|
||||
(define-values (new-exp1 exp1-tmpcount) (rco-exp e1 tmpcount))
|
||||
(define-values (new-exp2 exp2-tmpcount) (rco-exp e2 exp1-tmpcount))
|
||||
(define-values (new-exp1 assoc-1 exp1-tmpcount) (rco-arg e1 tmpcount))
|
||||
(define-values (new-exp2 assoc-2 exp2-tmpcount) (rco-arg e2 exp1-tmpcount))
|
||||
(define assoc-list (append assoc-1 assoc-2))
|
||||
(define new-tmpcount (+ exp2-tmpcount 1))
|
||||
(define tmpname (get-unique-symbol new-tmpcount))
|
||||
(set! assoc-list (append assoc-list (list `(,tmpname (,op ,new-exp1 ,new-exp2)))))
|
||||
(values tmpname
|
||||
`((,tmpname (,op ,new-exp1 ,new-exp2)))
|
||||
assoc-list
|
||||
new-tmpcount))]
|
||||
[`(let ([,var ,rexp]) ,body)
|
||||
(begin
|
||||
(define-values (new-exp exp-tmpcount) (rco-exp rexp tmpcount))
|
||||
(define-values (new-body body-tmpcount) (rco-exp body exp-tmpcount))
|
||||
(define new-tmpcount (+ body-tmpcount 1))
|
||||
(define tmpname (get-unique-symbol new-tmpcount))
|
||||
(values tmpname
|
||||
`((,tmpname (let ([,var ,new-exp]) ,new-body)))
|
||||
(define-values (new-exp assoc-list-1 exp-tmpcount) (rco-arg rexp tmpcount))
|
||||
(define-values (body-tmp assoc-list new-tmpcount) (rco-arg body exp-tmpcount))
|
||||
(define new-assoc-list
|
||||
(if (not (is-tmp new-exp tmpcount))
|
||||
(cons `(,var ,new-exp) (append assoc-list-1 assoc-list))
|
||||
(change-assoc-key (append assoc-list-1 assoc-list) new-exp var)))
|
||||
(values body-tmp
|
||||
new-assoc-list
|
||||
new-tmpcount))]))
|
||||
|
||||
|
||||
;(require racket/trace)
|
||||
;(trace rco-exp)
|
||||
;(trace rco-arg)
|
||||
|
|
|
|||
|
|
@ -8,15 +8,29 @@
|
|||
(list
|
||||
`(program ()
|
||||
(- 20))
|
||||
`(program ()
|
||||
(- (- 20)))
|
||||
`(program ()
|
||||
(- (- (- 20))))
|
||||
`(program () (+ 3 (- 20)))
|
||||
`(program () (+ (+ 3 2) (+ 4 5)))
|
||||
`(program () (let ([x 1]) x))
|
||||
`(program () (let ([x (+ (- 2) 3)]) (+ x (+ 2 3))))
|
||||
`(program () (+ (let ([x (+ (- 1) 2)]) (+ x 2)) (+ 4 5)))
|
||||
`(program ()
|
||||
(let ([a 42])
|
||||
(let ([b a])
|
||||
b)))
|
||||
`(program () (let ([tmp (- 1)]) tmp))))
|
||||
`(program () (let ([tmp (- 1)]) tmp))
|
||||
`(program () (- (let ([x 1]) x)))
|
||||
`(program () (let ([x (let ([x 1]) x)]) (+ 2 x)))
|
||||
`(program ()
|
||||
(let ([y (let ([x 20])
|
||||
(+ x (let ([x 22]) x)))]) y))))
|
||||
|
||||
(for/list ([program programs] [env (build-list (length programs) (lambda (_) '()))])
|
||||
(test-eq ((interp-R1 env) program)
|
||||
((interp-R1 env) (remove-complex-opera* program))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 0))
|
||||
|
|
@ -24,39 +38,60 @@
|
|||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 1))
|
||||
`(program () (let ((tmp.1 (- 20))) (+ 3 tmp.1))))
|
||||
`(program () (let ([tmp.1 (- 20)]) (- tmp.1))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 2))
|
||||
`(program () (let ((tmp.1 (+ 3 2))) (let ((tmp.2 (+ 4 5))) (+ tmp.1 tmp.2)))))
|
||||
`(program () (let ([tmp.1 (- 20)]) (let ([tmp.2 (- tmp.1)]) (- tmp.2)))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 3))
|
||||
`(program ()
|
||||
(let ((tmp.1 (+ (- 2) 3)))
|
||||
(let ((x.1 tmp.1))
|
||||
(let ((tmp.2 (+ 2 3)))
|
||||
(+ x.1 tmp.2))))))
|
||||
`(program () (let ((tmp.1 (- 20))) (+ 3 tmp.1))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 4))
|
||||
`(program ()
|
||||
(let ((tmp.2
|
||||
(let ((x.1
|
||||
(let ((tmp.1 (- 1)))
|
||||
(+ tmp.1 2))))
|
||||
(+ x.1 2))))
|
||||
(let ((tmp.3 (+ 4 5)))
|
||||
(+ tmp.2 tmp.3)))))
|
||||
`(program () (let ((tmp.1 (+ 3 2))) (let ((tmp.2 (+ 4 5))) (+ tmp.1 tmp.2)))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 5))
|
||||
`(program () (let([a.1 42]) (let ([b.1 a.1]) b.1))))
|
||||
`(program ()
|
||||
(let ((x.1 1)) x.1)))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 6))
|
||||
`(program () (let ((tmp.2 (- 1))) (let ((tmp.1 tmp.2)) tmp.1))))
|
||||
`(program ()
|
||||
(let ((tmp.1 (- 2)))
|
||||
(let ((x.1 (+ tmp.1 3)))
|
||||
(let ((tmp.3 (+ 2 3)))
|
||||
(+ x.1 tmp.3))))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 7))
|
||||
`(program ()
|
||||
(let ((tmp.1 (- 1)))
|
||||
(let ((x.1 (+ tmp.1 2)))
|
||||
(let ((tmp.3 (+ x.1 2)))
|
||||
(let ((tmp.4 (+ 4 5)))
|
||||
(+ tmp.3 tmp.4)))))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 8))
|
||||
`(program () (let([a.1 42]) (let ([b.1 a.1]) b.1))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 9))
|
||||
`(program () (let ([tmp.1 (- 1)]) tmp.1)))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 10))
|
||||
`(program () (let ((x.1 1)) (- x.1))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 11))
|
||||
`(program () (let ((x.2 1)) (let ((x.1 x.2)) (+ 2 x.1)))))
|
||||
|
||||
(test-eq
|
||||
(remove-complex-opera* (list-ref programs 12))
|
||||
`(program () (let ((x.1 20)) (let ((x.2 22)) (let ((y.1 (+ x.1 x.2))) y.1)))))
|
||||
|
||||
|
||||
(for/list ([program programs] [env (build-list (length programs) (lambda (_) '()))])
|
||||
(test-eq ((interp-R1 env) program)
|
||||
((interp-R1 env) (remove-complex-opera* program))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue