diff --git a/remove-complex-oper.scm b/remove-complex-oper.scm index 2ef3601..4d688fc 100644 --- a/remove-complex-oper.scm +++ b/remove-complex-oper.scm @@ -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,32 +111,36 @@ [`(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) diff --git a/test-remove-complex-opera.scm b/test-remove-complex-opera.scm index f56e4f7..12f1e54 100644 --- a/test-remove-complex-opera.scm +++ b/test-remove-complex-opera.scm @@ -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 ((x.1 1)) x.1))) + +(test-eq + (remove-complex-opera* (list-ref programs 6)) + `(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 6)) - `(program () (let ((tmp.2 (- 1))) (let ((tmp.1 tmp.2)) tmp.1)))) + (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))))