117 lines
3.9 KiB
Racket
117 lines
3.9 KiB
Racket
#lang racket
|
|
(require (only-in plai error test test/exn print-only-errors))
|
|
|
|
;; define .... placeholder syntax like plait
|
|
(define-syntax ....
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[_ (syntax/loc stx
|
|
(error "reached a `....` placeholder"))])))
|
|
|
|
;; Emulate a small part of the plai/gc2/collector language
|
|
(define current-heap (make-parameter (make-vector 0 #f)))
|
|
(define (heap-set! index val) (vector-set! (current-heap) index val))
|
|
(define (heap-ref index) (vector-ref (current-heap) index))
|
|
(define (heap-size) (vector-length (current-heap)))
|
|
(define (simple-root loc) (box loc))
|
|
(define (read-root root) (unbox root))
|
|
;; allocation pointer in word 0
|
|
(define (set-ptr! v) (heap-set! 0 v))
|
|
|
|
(define (malloc n)
|
|
(define addr (heap-ref 0))
|
|
(unless (<= (+ addr n) (heap-size))
|
|
(error 'allocator "out of memory"))
|
|
(heap-set! 0 (+ addr n))
|
|
addr)
|
|
|
|
(define-syntax-rule (with-heap vec expr ...)
|
|
(parameterize ([current-heap vec]) (begin expr ...)))
|
|
|
|
;; Convenience functions for tagged heap access
|
|
(define (expect addr tag)
|
|
(unless (equal? (heap-ref addr) tag)
|
|
(error 'expect "expecting ~a at ~a" tag addr)))
|
|
(define (heap-put! tag addr offset val)
|
|
(expect addr tag) (heap-set! (+ addr offset) val))
|
|
|
|
;; Partial implementation of a collector API
|
|
(define (gc:alloc-flat x)
|
|
(define loc (malloc 2))
|
|
(heap-set! loc 'flat)
|
|
(heap-put! 'flat loc 1 x)
|
|
loc)
|
|
|
|
(define (gc:cons f r)
|
|
(define loc (malloc 3))
|
|
(heap-set! loc 'cons)
|
|
(heap-put! 'cons loc 1 (read-root f))
|
|
(heap-put! 'cons loc 2 (read-root r))
|
|
loc)
|
|
|
|
(define (init-allocator) (set-ptr! 1))
|
|
|
|
;; coverage tests
|
|
(module+ test
|
|
(with-heap (make-vector 4 'free)
|
|
(init-allocator)
|
|
(test/exn (malloc 10) "out of memory")
|
|
(test/exn (expect 1 'flat) "expecting")))
|
|
|
|
(define (flat-2 a b)
|
|
(with-heap (make-vector 5 'free)
|
|
(init-allocator)
|
|
(gc:alloc-flat a)
|
|
(gc:alloc-flat b)
|
|
(current-heap)))
|
|
(define (cons-2 a b)
|
|
(with-heap (make-vector 8 'free)
|
|
(init-allocator)
|
|
(gc:cons (simple-root (gc:alloc-flat a)) (simple-root (gc:alloc-flat b)))
|
|
(current-heap)))
|
|
(define (self-cons)
|
|
(with-heap (make-vector 4 'free)
|
|
(init-allocator)
|
|
(define loc (malloc 0)) ; Hack to get current heap pointer
|
|
(gc:cons (simple-root loc) (simple-root loc))
|
|
(current-heap)))
|
|
(define (list-3 a b c)
|
|
(with-heap (make-vector 20 'free)
|
|
(init-allocator)
|
|
(define one (gc:cons
|
|
(simple-root (gc:alloc-flat c))
|
|
(simple-root (gc:alloc-flat (list)))))
|
|
(define two (gc:cons
|
|
(simple-root (gc:alloc-flat b))
|
|
(simple-root one)))
|
|
(gc:cons
|
|
(simple-root (gc:alloc-flat a))
|
|
(simple-root two))
|
|
(current-heap)))
|
|
; Why is this, which is the exact same as this, except the defines inlined producing a different structure?
|
|
#;(define (list-3 a b c)
|
|
(with-heap (make-vector 20 'free)
|
|
(init-allocator)
|
|
(gc:cons
|
|
(simple-root (gc:alloc-flat a))
|
|
(simple-root (gc:cons
|
|
(simple-root (gc:alloc-flat b))
|
|
(simple-root (gc:cons
|
|
(simple-root (gc:alloc-flat c))
|
|
(simple-root (gc:alloc-flat (list))))))))
|
|
(current-heap)))
|
|
|
|
(module+ test
|
|
(test (flat-2 1 2) #(5 flat 1 flat 2))
|
|
(test (flat-2 'flat 'cons) #(5 flat flat flat cons))
|
|
(test (flat-2 'cons 'flat) #(5 flat cons flat flat))
|
|
|
|
(test (cons-2 'first 'rest) #(8 flat first flat rest cons 1 3))
|
|
(test (cons-2 1 2) #(8 flat 1 flat 2 cons 1 3))
|
|
(test (cons-2 'cons 'cons) #(8 flat cons flat cons cons 1 3))
|
|
|
|
(test (self-cons) #(4 cons 1 1))
|
|
|
|
(test (list-3 'cons 'cons 'cons) '#(18 flat cons flat () cons 1 3 flat cons cons 8 5 flat cons cons 13 10 free free))
|
|
(test (list-3 'flat 'flat 'flat) '#(18 flat flat flat () cons 1 3 flat flat cons 8 5 flat flat cons 13 10 free free))
|
|
(test (list-3 1 2 3) '#(18 flat 3 flat () cons 1 3 flat 2 cons 8 5 flat 1 cons 13 10 free free))) |