#lang plai (require redex/reduction-semantics) ;; Step 1: the original a-normalization program. (define-type context [let-ctxt (x var?) (b L4-e?) (k context?)] [if-ctxt (t L4-e?) (e L4-e?) (k context?)] [fun-ctxt (a L4-e?) (k context?)] [arg-ctxt (f val?) (k context?)] [no-ctxt]) ;; find : L3e context -> L2e (define (find e k) (match e [`(,f ,a) (find f (fun-ctxt a k))] [`(let ([,x ,r]) ,b) (find r (let-ctxt x b k))] [`(if ,c ,t ,e) (find c (if-ctxt t e k))] [(? val?) (fill e k)])) ;; fill : d context -> L2e (define (fill d k+) (type-case context k+ [fun-ctxt (a k) (if (val? d) (find a (arg-ctxt d k)) (let ([x (fresh-var)]) `(let ([,x ,d]) ,(find a (arg-ctxt x k)))))] [arg-ctxt (f k) (if (val? d) (fill `(,f ,d) k) (let ([x (fresh-var)]) `(let ([,x ,d]) ,(fill `(,f ,x) k))))] [let-ctxt (x b k) `(let ([,x ,d]) ,(find b k))] [if-ctxt (t e k) (if (val? d) `(if ,d ,(find t k) ,(find e k)) (let ([x (fresh-var)]) `(let ([,x ,d]) (if ,x ,(find t k) ,(find e k)))))] [no-ctxt () d])) (define (norm e) (find e (no-ctxt))) (define-language L3 (p (e (l (x ...) e) ...)) ;; a main expression followed by function definitions (d (biop v v) (pred v) (v v ...) (new-array v v) (new-tuple v ...) (aref v v) (aset v v v) (alen v) (print v) (make-closure l v) (closure-proc v) (closure-vars v) v) (e d (let ([x d]) e) (if v e e)) (v x l num) (x (side-condition (name x variable-not-otherwise-mentioned) (variable? (term x)))) (l (side-condition (name x (variable-prefix :)) (regexp-match #rx"^:[a-zA-Z_0-9]*\$" (symbol->string (term x))))) (biop + - * cmpop) (cmpop < <= =) (pred number? a?) (num (side-condition number_1 (32-bit-int? (term number_1))))) (define-extended-language L4 L3 (e x l (biop e e) (pred e) (let ([x e]) e) (if e e e) (new-array e e) (new-tuple e ...) (aref e e) (aset e e e) (alen e) (e e ...) (begin e e) (print e) (make-closure l e) (closure-proc e) (closure-vars e) num)) (define (variable? x) (and (not (label? x)) (not (real-register? x)))) (define (label? x) (and (symbol? x) (regexp-match #rx"^:" (symbol->string x)))) (define (real-register? x) (member x '(eax ebx ecx edx esi edi esp ebp))) (define (32-bit-int? x) (and (integer? x) (<= (- (expt 2 31)) x) (< x (expt 2 31)))) (define (var? x) (symbol? x)) (define (val? x) (or (symbol? x) (number? x))) (define L4-e? (redex-match L4 e)) (define count 0) (define (fresh-var) (set! count (+ count 1)) (string->symbol (format "x_~a" count))) (print-only-errors #t) (test (norm '((a b) (c d))) '(let ([x_1 (a b)]) (let ([x_2 (c d)]) (x_1 x_2)))) (test (norm '(f (if a b c))) '(if a (f b) (f c))) (test (norm '(if (a b) c d)) '(let ([x_3 (a b)]) (if x_3 c d))) (test (norm '(f (let ([x (a b)]) x))) '(let ([x (a b)]) (f x)))