diff --git a/Final/1.rkt b/Final/1.rkt new file mode 100644 index 0000000..d0b89f7 --- /dev/null +++ b/Final/1.rkt @@ -0,0 +1,112 @@ +#lang plait +(define-type Exp + [numE (val : Number)] + [plusE (l : Exp) (r : Exp)] + [varE (name : Symbol)] + [let1E (id : Symbol) (named-expr : Exp) (bound-body : Exp)] + [lamE (param : Symbol) (body : Exp)] + [callWith (id : Symbol) (bound-expr : Exp) (fun : Exp) (val : Exp)] + [appE (fun : Exp) (val : Exp)]) + +(define-type Value + [numV (n : Number)] + [lamV (arg : Symbol) (body : Exp) (env : Env)]) + +(define-type-alias Env (Hashof Symbol Value)) +(define mt-env (hash empty)) ;; "empty environment" + +(define (lookup (s : Symbol) (n : Env)) + (type-case (Optionof Value) (hash-ref n s) + [(none) (error s "not bound")] + [(some v) v])) + +(define (extend old-env new-name value) + (hash-set old-env new-name value)) + +(define (interp expr env) + (type-case Exp expr + [(numE n) (numV n)] + [(plusE l r) + (numV (+ (numV-n (interp l env)) (numV-n (interp r env))))] + [(let1E bound-id named-expr bound-body) + (interp bound-body (extend env bound-id (interp named-expr env)))] + [(varE name) (lookup name env)] + [(lamE bound-id bound-body) (lamV bound-id bound-body env)] + [(callWith with-id with-expr fun-expr arg-expr) ....] + [(appE fun-expr arg-expr) + (let ([fval (interp fun-expr env)]) + (type-case Value fval + [(lamV bound-id bound-body f-env) + (interp bound-body + (extend f-env bound-id (interp arg-expr env)))] + [else (error 'interp + (string-append "`call' expects a function, got: " + (to-string fval)))]))])) + +(module+ test + (print-only-errors #t) + (define (example body) + (let1E 'x (numE 3) + (let1E 'f (lamE 'y (plusE (varE 'x) (varE 'y))) + body))) + + + (test (interp (example (appE (varE 'f) (numE 4))) mt-env) + (numV 7)) + + (test (interp + (example (callWith 'x (numE 5) (varE 'f) (numE 4))) mt-env) + (numV 9)) + + (test (interp + (example + (let1E 'f (lamE 'x (varE 'x)) + (callWith 'x (numE 5) (varE 'f) (numE 4)))) + mt-env) + (numV 4)) + + (test (interp + (example + (let1E 'f (lamE 'y (varE 'x)) + (callWith 'x (numE 5) (varE 'f) (numE 4)))) + mt-env) + (numV 5)) + + (test + (interp (callWith 'y (numE 7) (lamE 'x (plusE (varE 'x) (varE 'y))) (numE 3)) + mt-env) + (numV 10)) + + (test/exn + (interp (callWith 'x (numE 7) (lamE 'x (plusE (varE 'x) (varE 'y))) (numE 3)) + mt-env) + "not bound") + + (test + (interp + (callWith 'x (numE 7) (lamE 'x (plusE (varE 'x) (varE 'x))) (numE 3)) + mt-env) + (numV 6)) + + (test + (interp + (let1E 'z (numE 7) + (callWith 'y (varE 'z) (lamE 'x (plusE (varE 'x) (varE 'y))) (numE 3))) + mt-env) + (numV 10)) + (test + (interp + (let1E 'f (lamE 'x (plusE (varE 'x) (varE 'y))) + (callWith 'y (numE 7) (varE 'f) (numE 3))) + mt-env) + (numV 10)) + (test + (interp + (let1E 'f (lamE 'x (plusE (varE 'x) (varE 'y))) + (let1E 'z (numE 7) (callWith 'y (varE 'z) (varE 'f) (numE 3)))) + mt-env) + (numV 10)) + + (test/exn (interp (appE (varE 'g) (numE 4)) mt-env) "not bound") + (test/exn (interp (example (appE (numE 4) (varE 'f))) mt-env) "function") + (test/exn (interp (example (callWith 'x (numE 5) (numE 4) (varE 'f))) mt-env) "function")) diff --git a/Final/2.rkt b/Final/2.rkt new file mode 100644 index 0000000..6e6b5b4 --- /dev/null +++ b/Final/2.rkt @@ -0,0 +1,242 @@ +#lang plait +(define-type Exp + [numE (n : Number)] + [plusE (lhs : Exp) (rhs : Exp)] + [minusE (lhs : Exp) (rhs : Exp)] [varE (name : Symbol)] + [lamE (param : Symbol) (body : Exp)] + [appE (fun-expr : Exp) (arg-expr : Exp)] + [errorE (msg : String)] ;; New + [if0E (test : Exp) (then : Exp) (else : Exp)] + ) + +(define-type Value + [numV (n : Number)] + [errorV (msg : String)] + [funV (param : Symbol) + (body : Exp) + (env : Env)]) + +(define-type Env + [emptyEnv] + [Extend (name : Symbol) + (value : Value) + (rest : Env)]) + +(define (lookup name env) + (type-case Env env + [(emptyEnv) (error 'lookup (string-append "no binding for" (to-string name)))] + [(Extend id val rest-env) + (if (eq? id name) + val + (lookup name rest-env))])) + + +(define-type Continuation + [emptyCont] + [plusSecondK (r : Exp) + (env : Env) + (k : Continuation)] + [doPlusK (v1 : Value) + (k : Continuation)] + [minusSecondK (r : Exp) + (env : Env) + (k : Continuation)] + [doMinusK (v1 : Value) + (k : Continuation)] + [appArgK (arg-expr : Exp) + (env : Env) + (k : Continuation)] + [doAppK (fun-val : Value) + (k : Continuation)] + [doIfK (then-expr : Exp) + (else-expr : Exp) + (env : Env) + (k : Continuation)] + ) + +(define (parse-error sx) + (error 'parse (string-append "parse error: " (to-string sx)))) + +(define (sx-ref sx n) (list-ref (s-exp->list sx) n)) + +(define (parse sx) + (local + [(define (px i) (parse (sx-ref sx i)))] + (cond + [(s-exp-number? sx) (numE (s-exp->number sx))] + [(s-exp-symbol? sx) (varE (s-exp->symbol sx))] + [(s-exp-match? `(let1 SYMBOL ANY ANY) sx) + (let* ([id (s-exp->symbol (sx-ref sx 1))] + [named (px 2)] + [body (px 3)]) + (appE (lamE id body) named))] + [(s-exp-match? `(lam (SYMBOL) ANY) sx) + (let* ([args (sx-ref sx 1)] + [varE (s-exp->symbol (sx-ref args 0))] + [body (px 2)]) + (lamE varE body))] + [(s-exp-match? `(error STRING) sx) (errorE (s-exp->string (sx-ref sx 1)))] + [(s-exp-match? `(error ANY) sx) (parse-error sx)] + [(s-exp-match? `(ANY ANY) sx) + (appE (px 0) (px 1))] + [(s-exp-list? sx) + (case (s-exp->symbol (sx-ref sx 0)) + [(+) (plusE (px 1) (px 2))] + [(-) (minusE (px 1) (px 2))] + [(if0) (if0E (px 1) (px 2) (px 3))] + [else (parse-error sx)])] + [else (parse-error sx)]))) + +(define (arith-op op val1 val2) + (local + [(define (numV->number v) + (type-case Value v + [(numV n) n] + [else (error 'arith-op + (string-append "expects a number, got: " (to-string v)))]))] + (numV (op (numV->number val1) + (numV->number val2))))) + +(define (numzero? x) + (zero? (numV-n x))) + +(define (interp expr env k) + (type-case Exp expr + [(numE n) (continue k (numV n))] + [(plusE l r) (interp l env (plusSecondK r env k))] + [(minusE l r) (interp l env (minusSecondK r env k))] + [(varE name) (continue k (lookup name env))] + [(errorE msg) (errorV msg)] + [(lamE param body-expr) + (continue k (funV param body-expr env))] + [(appE fun-expr arg-expr) + (interp fun-expr env (appArgK arg-expr env k))] + [(if0E test-expr then-expr else-expr) + (interp test-expr env (doIfK then-expr else-expr env k))] + + )) + +(define (continue [k : Continuation] [v : Value]) : Value + (type-case Continuation k + [(emptyCont) v] + [(plusSecondK r env next-k) + (interp r env (doPlusK v next-k))] + [(doPlusK v1 next-k) + (continue next-k (arith-op + v1 v))] + [(minusSecondK r env next-k) + (interp r env (doMinusK v next-k))] + [(doMinusK v1 next-k) + (continue next-k (arith-op - v1 v))] + [(appArgK arg-expr env next-k) + (interp arg-expr env (doAppK v next-k))] + [(doAppK fun-val next-k) + (interp (funV-body fun-val) + (Extend (funV-param fun-val) v (funV-env fun-val)) + next-k)] + [(doIfK then-expr else-expr env next-k) + (if (numzero? v) + (interp then-expr env next-k) + (interp else-expr env next-k))] + )) + +(module+ test + (define init-k (emptyCont)) + + (define (run s-exp) + (interp (parse s-exp) (emptyEnv) (emptyCont))) + + + (test (interp (numE 10) + (emptyEnv) + init-k) + (numV 10)) + (test (interp (plusE (numE 10) (numE 7)) + (emptyEnv) + init-k) + (numV 17)) + (test (interp (minusE (numE 10) (numE 7)) + (emptyEnv) + init-k) + (numV 3)) + (test (interp (appE (lamE 'x (plusE (varE 'x) (numE 12))) + (plusE (numE 1) (numE 17))) + (emptyEnv) + init-k) + (numV 30)) + (test (interp (varE 'x) + (Extend 'x (numV 10) (emptyEnv)) + init-k) + (numV 10)) + + (test (interp (appE (lamE 'x (plusE (varE 'x) (numE 12))) + (plusE (numE 1) (numE 17))) + (emptyEnv) + init-k) + (numV 30)) + + + (test/exn (interp (varE 'x) (emptyEnv) init-k) + "no binding") + + (test/exn + (run `{ {lam {x} {+ x y}} 0}) + "no binding") + + (test + (run + `{{lam {x} + {{lam {f} {f 2}} + {lam {y} {+ x y}}}} + 0}) + (numV 2)) + + + (test (run `{let1 f {lam {x} {+ x 1}} + {+ {f 2} {error "abort!"}}}) + (errorV "abort!")) + + (test (run `{{lam {x} + {{lam {f} + {+ {f 1} + {{lam {x} {f 2}} 3}}} + {lam {y} {+ x y}}}} + 0}) + (numV 3)) + + (test (interp (if0E (numE 0) + (numE 1) + (numE 2)) + (emptyEnv) + init-k) + (numV 1)) + (test (interp (if0E (numE 1) + (numE 0) + (numE 2)) + (emptyEnv) + init-k) + (numV 2)) + + (test (run + `{{lam {mkrec} + {{lam {fib} + ;; Call fib on 10: + {fib 10}} + ;; Create recursive fib: + {mkrec + {lam {fib} + ;; Fib: + {lam {n} + {if0 n + 1 + {if0 {- n 1} + {error "reached zero"} + {+ {fib {- n 1}} + {fib {- n 2}}}}}}}}}} + ;; mkrec: + {lam {body-proc} + {{lam {fX} + {fX fX}} + {lam {fX} + {body-proc {lam {x} {{fX fX} x}}}}}}}) + (errorV "reached zero")) + ) diff --git a/Final/3.rkt b/Final/3.rkt new file mode 100644 index 0000000..9b7de0c --- /dev/null +++ b/Final/3.rkt @@ -0,0 +1,388 @@ +#lang plai/gc2/collector +;; metadata size +(define METADATA-SIZE 2) + +;; where the start of the current "to space" is stored in the heap. +(define LOC:OFFSET 0) + +;; where the allocation pointer is stored in the heap +(define LOC:PTR 1) + +;; Start of the current "to space" +(define (off) (heap-ref LOC:OFFSET)) + +;; Offset into the current "to space" where free space starts. +(define (ptr) (heap-ref LOC:PTR)) + +;; How big are the semi-spaces? +(define (space-size) + (quotient (- (heap-size) METADATA-SIZE) 2)) + +;; All functions named gc:*, along with init-allocator, must be +;; implemented by any plai/gc2 collector. For their functionality and +;; interface see [1]. + +(define (init-allocator) + (heap-set! LOC:OFFSET METADATA-SIZE) + (heap-set! LOC:PTR 0)) + +(module+ test + (test (with-heap (make-vector 1000) (+ METADATA-SIZE (space-size) (space-size))) 1000) + (test (with-heap (make-vector 999) (+ METADATA-SIZE (space-size) (space-size))) 998)) + + +;; Define some syntax rules to make it easier to write tests + +;; Test if the last two expressions are equal. +;; Takes a vector for a heap + +(define-syntax (test/heap stx) + (syntax-case stx () + [(test/heap heap oper ... expected) + (syntax-protect + #`(with-heap heap + (init-allocator) + #,(syntax/loc stx + (test (begin oper ...) expected))))])) + +;; Test if one of the expressions before the last throws an exception +;; matching the last expression (a string). +;; Takes a vector for a heap +(define-syntax (test/heap/exn stx) + (syntax-case stx () + [(test/heap heap oper ... expected) + (syntax-protect + #`(with-heap heap + (init-allocator) + #,(syntax/loc stx + (test/exn (begin oper ...) expected))))])) + +(define (swap-spaces!) + ;; do nothing + (void)) + +(module+ test + + ;; Initially, allocations are in the left half. + (test/heap + (make-vector (+ 4 METADATA-SIZE) '?) + (gc:alloc-flat #f) + (current-heap) + #(2 2 flat #f ? ?)) + + ;; After calling swap-spaces!, allocations are in the right half + (test/heap + (make-vector (+ 4 METADATA-SIZE) '?) + (swap-spaces!) + (gc:alloc-flat #f) + (current-heap) + #(4 2 ? ? flat #f)) + + ;; Swapping twice is back to allocating in left + (test/heap + (make-vector (+ 4 METADATA-SIZE) '?) + (swap-spaces!) + (swap-spaces!) + (gc:alloc-flat #f) + (current-heap) + #(2 2 flat #f ? ?)) + ) + +;; malloc : size -> address +(define (malloc n) + (when (> (+ (ptr) n) (space-size)) + (gc!)) + (when (> (+ (ptr) n) (space-size)) + (error 'malloc "out of memory!")) + (heap-set! LOC:PTR (+ (ptr) n)) + (+ (heap-ref LOC:OFFSET) (- (ptr) n))) + +(define (gc!) + ;; do nothing + (void)) + +;; gc:alloc-flat : flat-value -> address +(define (gc:alloc-flat value) + (define addr (malloc 2)) + (heap-set! addr 'flat) + (heap-set! (+ addr 1) value) + addr) + +;; gc:flat? : address -> boolean +(define (gc:flat? address) + (equal? (heap-ref address) 'flat)) + +;; gc:deref : address -> flat-value +(define (gc:deref address) + (unless (gc:flat? address) + (error 'gc:deref "not a flat: ~a" address)) + (heap-ref (+ address 1))) + +;; gc:cons : root root -> address +(define (gc:cons root1 root2) + (define addr (malloc 3 root1 root2)) + (heap-set! addr 'cons) + (heap-set! (+ addr 1) (read-root root1)) + (heap-set! (+ addr 2) (read-root root2)) + addr) + +;; gc:cons? : address -> boolean +(define (gc:cons? address) + (equal? (heap-ref address) 'cons)) + +;; gc:first : address -> address +(define (gc:first address) + (unless (gc:cons? address) + (error 'gc:first "not a pair: ~a" address)) + (heap-ref (+ address 1))) + +;; gc:rest : address -> address +(define (gc:rest address) + (unless (gc:cons? address) + (error 'gc:rest "not a pair: ~a" address)) + (heap-ref (+ address 2))) + +;; gc:set-first! : address address -> void +(define (gc:set-first! address new-value-address) + (unless (gc:cons? address) + (error 'gc:set-first! "not a pair: ~a" address)) + (heap-set! (+ address 1) new-value-address)) + +;; gc:set-rest! : address address -> void +(define (gc:set-rest! address new-value-address) + (unless (gc:cons? address) + (error 'gc:set-rest! "not a pair: ~a" address)) + (heap-set! (+ address 2) new-value-address)) + +;; gc:closure : opaque-value (listof root) -> address +(define (gc:closure code-ptr free-vars) + (define n-vars (length free-vars)) + (define addr (malloc (+ 3 n-vars))) + (heap-set! addr 'clos) + (heap-set! (+ addr 1) code-ptr) + (heap-set! (+ addr 2) n-vars) + (for ([i (in-range n-vars)] + [fv (in-list free-vars)]) + (heap-set! (+ addr 3 i) (read-root fv))) + addr) + +;; gc:closure? : address -> boolean +(define (gc:closure? address) + (equal? (heap-ref address) 'clos)) + +;; gc:closure-code-ptr : address -> opaque-value +(define (gc:closure-code-ptr address) + (unless (gc:closure? address) + (error 'gc:closure-code-ptr "not a closure: ~a" address)) + (heap-ref (+ address 1))) + +;; gc:closure-env-ref : address integer -> address +(define (gc:closure-env-ref address i) + (unless (gc:closure? address) + (error 'gc:closure-env-ref "not a closure: ~a" address)) + (heap-ref (+ address 3 i))) + +(module+ test + ;; OOM + (test/heap/exn (make-vector METADATA-SIZE) + (gc:alloc-flat #f) + "out of memory") + + ;; OOM due to using only half of the heap + (test/heap/exn + (make-vector (+ 2 METADATA-SIZE)) + (gc:alloc-flat #f) + "out of memory") + + ;; dereferencing cons as flat + (test/heap/exn (make-vector 1000) + (let ([cons-addr + (gc:cons + (simple-root (gc:alloc-flat #f)) + (simple-root (gc:alloc-flat #t)))]) + (gc:deref cons-addr)) + "not a flat") + + ;; dereferencing flat as cons + (test/heap/exn (make-vector 1000) + (let ([flat-addr (gc:alloc-flat #f)]) + (gc:first flat-addr)) + "not a pair") + + ;; dereferencing flat as cons + (test/heap/exn (make-vector 1000) + (let ([flat-addr (gc:alloc-flat #f)]) + (gc:rest flat-addr)) + "not a pair") + + ;; setting flat as cons + (test/heap/exn (make-vector 1000) + (let ([flat-addr (gc:alloc-flat #f)]) + (gc:set-first! flat-addr #t)) + "not a pair") + + ;; setting flat as cons + (test/heap/exn (make-vector 1000) + (let ([flat-addr (gc:alloc-flat #f)]) + (gc:set-rest! flat-addr #t)) + "not a pair") + + ;; getting code ptr from non closure + (test/heap/exn (make-vector 1000) + (let ([flat-addr (gc:alloc-flat #f)]) + (gc:closure-code-ptr flat-addr)) + "not a closure") + + ;; getting code ptr from non closure + (test/heap/exn (make-vector 1000) + (let ([flat-addr (gc:alloc-flat #f)]) + (gc:closure-env-ref flat-addr 1)) + "not a closure") + + ;; Successful dereference: flat + (test/heap (make-vector 1000) + (gc:deref (gc:alloc-flat #t)) + #t) + + ;; successful dereference: cons + (test/heap (make-vector 1000) + (gc:deref + (gc:rest + (gc:cons + (simple-root (gc:alloc-flat 'first)) + (simple-root (gc:alloc-flat 'rest))))) + 'rest) + + (test/heap (make-vector 1000) + (gc:deref + (gc:first + (gc:cons + (simple-root (gc:alloc-flat 'first)) + (simple-root (gc:alloc-flat 'rest))))) + 'first) + + ;; successful alloc / deref closure + (test/heap (make-vector 1000) + (gc:closure-code-ptr + (gc:closure 'dummy '())) + 'dummy) + + (test/heap (make-vector 1000) + (gc:deref + (gc:closure-env-ref + (gc:closure + 'dummy + (list (simple-root (gc:alloc-flat #f)))) + 0)) + #f) + + ;; setting cons parts + (test/heap (make-vector 1000) + (let ([cons-loc + (gc:cons + (simple-root (gc:alloc-flat 'first)) + (simple-root (gc:alloc-flat 'rest)))]) + (gc:set-first! cons-loc (gc:alloc-flat 'mutated)) + (gc:deref (gc:first cons-loc))) + 'mutated) + + (test/heap (make-vector 1000) + (let ([cons-loc + (gc:cons + (simple-root (gc:alloc-flat 'first)) + (simple-root (gc:alloc-flat 'rest)))]) + (gc:set-rest! cons-loc (gc:alloc-flat 'mutated)) + (gc:deref (gc:rest cons-loc))) + 'mutated) + ) + +(module+ test + ;; heap state after initial allocation + (test/heap + (make-vector 12 '?) + (gc:alloc-flat #f) + (current-heap) + #(2 2 flat #f ? ? ? ? ? ? ? ?)) + + (test/heap + (make-vector 18 '?) + (gc:cons + (simple-root (gc:alloc-flat #f)) + (simple-root (gc:alloc-flat #t))) + (current-heap) + #(2 7 flat #f flat #t cons 2 4 ? ? ? ? ? ? ? ? ?)) + + (test/heap + (make-vector 18 '?) + (gc:closure + 'dummy + (list (simple-root (gc:alloc-flat #f)))) + (current-heap) + #(2 6 flat #f clos dummy 1 2 ? ? ? ? ? ? ? ? ? ?)) + ) + +(module+ test + ;; heap state and roots after gc + + (test/heap + (make-vector 12 '?) + (define f1 (gc:alloc-flat #f)) + (with-roots (f1) + (gc!) + (cons (current-heap) (map read-root (get-root-set)))) + (cons + #(7 2 forwarded 7 ? ? ? flat #f ? ? ?) + '(7))) + + (test/heap + (make-vector 18 '?) + (define c1 + (gc:cons + (simple-root (gc:alloc-flat #f)) + (simple-root (gc:alloc-flat #t)))) + (with-roots (c1) + (gc!) + (cons (current-heap) (map read-root (get-root-set)))) + (cons + #(10 7 forwarded 13 forwarded 15 forwarded 10 4 ? cons 13 15 flat #f flat #t ?) + '(10))) + + (test/heap + (make-vector 18 '?) + (define cl1 + (gc:closure 'dummy (list (simple-root (gc:alloc-flat #f))))) + (with-roots (cl1) + (gc!) + (cons (current-heap) (map read-root (get-root-set)))) + (cons + #(10 6 forwarded 14 forwarded 10 1 2 ? ? clos dummy 1 14 flat #f ? ?) + '(10))) + + ;; Test for coverage of forwarded tags. + (test/heap + (make-vector 26 '?) + (define c1 + (gc:cons + (simple-root (gc:alloc-flat 2)) + (simple-root (gc:alloc-flat empty)))) + (define c2 + (gc:cons + (simple-root (gc:alloc-flat 1)) + (simple-root c1))) + ;; force both cons cells to be moved before starting update pass + (with-roots (c1 c2) + (gc!) + (current-heap)) + #(14 12 + forwarded 20 forwarded 22 forwarded 14 4 forwarded 24 forwarded 17 6 + cons 20 22 cons 24 14 flat 2 flat () flat 1) + ) + ) + +(module+ test + (test/heap + (make-vector 12 '?) + (define f1 (gc:alloc-flat #f)) + (gc! (simple-root f1)) + (current-heap) + #(7 2 forwarded 7 ? ? ? flat #f ? ? ?)))