Add final questions
This commit is contained in:
112
Final/1.rkt
Normal file
112
Final/1.rkt
Normal file
@ -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"))
|
||||
242
Final/2.rkt
Normal file
242
Final/2.rkt
Normal file
@ -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"))
|
||||
)
|
||||
388
Final/3.rkt
Normal file
388
Final/3.rkt
Normal file
@ -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 ? ? ?)))
|
||||
Reference in New Issue
Block a user