#lang plai-typed (require plai-typed/s-exp-match) ;; Convert `interp`- and `continue`-time structures ;; to explicit allocation via `malloc`, where a tag ;; on each allocated record indicates the variant. (define-type ExprC [numC (n : number)] [plusC (lhs : ExprC) (rhs : ExprC)] [multC (lhs : ExprC) (rhs : ExprC)] [idC (name : symbol)] [lamC (n : symbol) (body : ExprC)] [appC (fun-expr : ExprC) (arg-expr : ExprC)] [if0C (tst : ExprC) (thn : ExprC) (els : ExprC)]) #| (define-type ExprD 8 [numD (n : number)] 9 [plusD (lhs : ExprD) (rhs : ExprD)] 10 [multD (lhs : ExprD) (rhs : ExprD)] 11 [atD (pos : number)] 12 [lamD (body : ExprD)] 13 [appD (fun-expr : ExprD) (arg-expr : ExprD)] 14 [if0D (tst : ExprD) (thn : ExprD) (els : ExprD)]) |# #| (define-type Value 15 [numV (n : number)] 16 [closV (body : ExprD) (env : Env)]) |# (define mt-env empty) (define extend-env cons) (define-type BindingC [bindC (name : symbol)]) (define-type-alias EnvC (listof BindingC)) #| (define-type Cont 0 [doneK] 1 [addSecondK (r : ExprD) (env : Env) (k : Cont)] 2 [doAddK (v1 : Value) (k : Cont)] 3 [multSecondK (r : ExprD) (env : Env) (k : Cont)] 4 [doMultK (v1 : Value) (k : Cont)] 5 [appArgK (arg-expr : ExprD) (env : Env) (k : Cont)] 6 [doAppK (fun-val : Value) (k : Cont)] 7 [doIf0K (then-expr : ExprD) (else-expr : ExprD) (env : Env) (k : Cont)]) |# #| 17 cons for env |# (module+ test (print-only-errors true)) ;; ---------------------------------------- ;; Allocation (define memory (make-vector 1500 0)) (define ptr 0) (define (incptr n) (begin (set! ptr (+ ptr n)) (- ptr n))) (define (malloc1 tag a) (begin (vector-set! memory ptr tag) (vector-set! memory (+ ptr 1) a) (incptr 2))) (define (malloc2 tag a b) (begin (vector-set! memory ptr tag) (vector-set! memory (+ ptr 1) a) (vector-set! memory (+ ptr 2) b) (incptr 3))) (define (malloc3 tag a b c) (begin (vector-set! memory ptr tag) (vector-set! memory (+ ptr 1) a) (vector-set! memory (+ ptr 2) b) (vector-set! memory (+ ptr 3) c) (incptr 4))) (define (malloc4 tag a b c d) (begin (vector-set! memory ptr tag) (vector-set! memory (+ ptr 1) a) (vector-set! memory (+ ptr 2) b) (vector-set! memory (+ ptr 3) c) (vector-set! memory (+ ptr 4) d) (incptr 5))) (define (ref n d) (vector-ref memory (+ n d))) ;; ---------------------------------------- (define (parse [s : s-expression]) : ExprC (cond [(s-exp-match? `NUMBER s) (numC (s-exp->number s))] [(s-exp-match? `SYMBOL s) (idC (s-exp->symbol s))] [(s-exp-match? '{+ ANY ANY} s) (plusC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? '{* ANY ANY} s) (multC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? '{lambda {SYMBOL} ANY} s) (lamC (s-exp->symbol (first (s-exp->list (second (s-exp->list s))))) (parse (third (s-exp->list s))))] [(s-exp-match? '{ANY ANY} s) (appC (parse (first (s-exp->list s))) (parse (second (s-exp->list s))))] [(s-exp-match? '{if0 ANY ANY ANY} s) (if0C (parse (second (s-exp->list s))) (parse (third (s-exp->list s))) (parse (fourth (s-exp->list s))))] [else (error 'parse "invalid input")])) (module+ test (test (parse '3) (numC 3)) (test (parse `x) (idC 'x)) (test (parse '{+ 1 2}) (plusC (numC 1) (numC 2))) (test (parse '{* 1 2}) (multC (numC 1) (numC 2))) (test (parse '{lambda {x} x}) (lamC 'x (idC 'x))) (test (parse '{1 2}) (appC (numC 1) (numC 2))) (test (parse '{if0 0 1 2}) (if0C (numC 0) (numC 1) (numC 2))) (test/exn (parse '{}) "invalid input")) ;; ---------------------------------------- (define (compile a-fae env) (type-case ExprC a-fae [numC (n) (malloc1 8 n)] [plusC (l r) (malloc2 9 (compile l env) (compile r env))] [multC (l r) (malloc2 10 (compile l env) (compile r env))] [idC (name) (malloc1 11 (locate name env))] [lamC (n body-expr) (malloc1 12 (compile body-expr (extend-env (bindC n) env)))] [appC (fun-expr arg-expr) (malloc2 13 (compile fun-expr env) (compile arg-expr env))] [if0C (test-expr then-expr else-expr) (malloc3 14 (compile test-expr env) (compile then-expr env) (compile else-expr env))])) (define (locate name env) (cond [(empty? env) (error 'locate "free variable")] [else (if (symbol=? name (bindC-name (first env))) 0 (+ 1 (locate name (rest env))))])) ;; ---------------------------------------- (define expr-reg 0) (define env-reg 0) ;; interp : ExprC Env Cont -> Value (define (interp) (case (ref expr-reg 0) [(8) ; num (begin (set! v-reg (malloc1 15 (ref expr-reg 1))) (continue))] [(9) ; add (begin (set! k-reg (malloc3 1 (ref expr-reg 2) env-reg k-reg)) (set! expr-reg (ref expr-reg 1)) (interp))] [(10) ; mult (begin (set! k-reg (malloc3 3 (ref expr-reg 2) env-reg k-reg)) (set! expr-reg (ref expr-reg 1)) (interp))] [(11) ; id (begin (set! env2-reg env-reg) (set! v-reg (ref expr-reg 1)) (env-ref))] [(12) ; lam (begin (set! v-reg (malloc2 16 (ref expr-reg 1) env-reg)) (continue))] [(13) ; app (begin (set! k-reg (malloc3 5 (ref expr-reg 2) env-reg k-reg)) (set! expr-reg (ref expr-reg 1)) (interp))] [(14) ; if0 (begin (set! k-reg (malloc4 7 (ref expr-reg 2) (ref expr-reg 3) env-reg k-reg)) (set! expr-reg (ref expr-reg 1)) (interp))])) (define k-reg 0) (define v-reg 0) ;; continue : Cont Value -> void (define (continue) (case (ref k-reg 0) [(0) ; mtk v-reg] [(1) ; addSecondK (begin (set! expr-reg (ref k-reg 1)) (set! env-reg (ref k-reg 2)) (set! k-reg (malloc2 2 v-reg (ref k-reg 3))) (interp))] [(2) ; doAddK (begin (set! v-reg (num+ (ref k-reg 1) v-reg)) (set! k-reg (ref k-reg 2)) (continue))] [(3) ; multSecondK (begin (set! expr-reg (ref k-reg 1)) (set! env-reg (ref k-reg 2)) (set! k-reg (malloc2 4 v-reg (ref k-reg 3))) (interp))] [(4) ; doMultK (begin (set! v-reg (num* (ref k-reg 1) v-reg)) (set! k-reg (ref k-reg 2)) (continue))] [(5) ; appArgK (begin (set! expr-reg (ref k-reg 1)) (set! env-reg (ref k-reg 2)) (set! k-reg (malloc2 6 v-reg (ref k-reg 3))) (interp))] [(6) ; doAppK (begin (set! expr-reg (ref (ref k-reg 1) 1)) (set! env-reg (malloc2 17 v-reg (ref (ref k-reg 1) 2))) (set! k-reg (ref k-reg 2)) (interp))] [(7) ; doIfK (begin (if (numzero? v-reg) (set! expr-reg (ref k-reg 1)) (set! expr-reg (ref k-reg 2))) (set! env-reg (ref k-reg 3)) (set! k-reg (ref k-reg 4)) (interp))])) ;; num-op : (number number -> number) -> (Value Value -> Value) (define (num-op op) (lambda (x y) (malloc1 15 (op (ref x 1) (ref y 1))))) (define num+ (num-op +)) (define num* (num-op *)) (define (numzero? x) (zero? (ref x 1))) (define env2-reg 0) (define (env-ref) (if (zero? v-reg) (begin (set! v-reg (ref env2-reg 1)) (continue)) (begin (set! env2-reg (ref env2-reg 2)) (set! v-reg (- v-reg 1)) (env-ref)))) ;; ---------------------------------------- (define (init-k) (malloc1 0 0)) (define (interpx a env k) (begin (set! expr-reg a) (set! env-reg env) (set! k-reg k) (interp))) (define (numV x) (malloc1 15 x)) (define empty-env (malloc1 0 0)) (define (vtest a b) (test (ref a 1) (ref b 1))) (module+ test (vtest (interpx (compile (parse '10) mt-env) empty-env (init-k)) (numV 10)) (vtest (interpx (compile (parse '{+ 10 7}) mt-env) empty-env (init-k)) (numV 17)) (vtest (interpx (compile (parse '{* 10 7}) mt-env) empty-env (init-k)) (numV 70)) (vtest (interpx (compile (parse '{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) empty-env (init-k)) (numV 30)) (vtest (interpx (compile (parse `x) (extend-env (bindC 'x) mt-env)) (malloc2 17 (numV 10) empty-env) (init-k)) (numV 10)) (vtest (interpx (compile (parse `{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) empty-env (init-k)) (numV 30)) (vtest (interpx (compile (parse '{{lambda {x} {{lambda {f} {+ {f 1} {{lambda {x} {f 2}} 3}}} {lambda {y} {+ x y}}}} 0}) mt-env) empty-env (init-k)) (numV 3)) (vtest (interpx (compile (parse '{if0 0 1 2}) mt-env) empty-env (init-k)) (numV 1)) (vtest (interpx (compile (parse '{if0 1 1 2}) mt-env) empty-env (init-k)) (numV 2)) (vtest (interpx (compile (parse '{{lambda {mkrec} {{lambda {fib} ;; Call fib on 4: {fib 4}} ;; Create recursive fib: {mkrec {lambda {fib} ;; Fib: {lambda {n} {if0 n 1 {if0 {+ n -1} 1 {+ {fib {+ n -1}} {fib {+ n -2}}}}}}}}}} ;; mkrec: {lambda {body-proc} {{lambda {fX} {fX fX}} {lambda {fX} {body-proc {lambda {x} {{fX fX} x}}}}}}}) mt-env) empty-env (init-k)) (numV 5)) (test/exn (compile (parse `x) mt-env) "free variable"))