PasteRack.org
Paste # 70007
2020-03-21 20:56:23

Fork as a new paste.

Paste viewed 600 times.


Embed:

  1. #lang plai/gc2/collector
  2.  
  3. ;; Originally by Vincent St. Amour
  4.  
  5. (print-only-errors)
  6.  
  7. ;; metadata size
  8. (define METADATA-SIZE 1)
  9.  
  10. ;; where the allocation pointer is stored in the heap
  11. (define LOC:PTR 0)
  12.  
  13. (define (init-allocator)
  14.   (heap-set! LOC:PTR METADATA-SIZE))
  15.  
  16. ;; malloc : size -> address
  17. (define (malloc n)
  18.   (define addr (heap-ref LOC:PTR))
  19.   (when (> (+ addr n) (heap-size))
  20.     (error 'malloc "out of memory!"))
  21.   (heap-set! LOC:PTR (+ addr n))
  22.   addr)
  23.  
  24.  
  25. ;; gc:alloc-flat : flat-value -> address
  26. (define (gc:alloc-flat value)
  27.   (define addr (malloc 2))
  28.   (heap-set! addr 'flat)
  29.   (heap-set! (+ addr 1) value)
  30.   addr)
  31. ;; gc:flat? : address -> boolean
  32. (define (gc:flat? address)
  33.   (equal? (heap-ref address) 'flat))
  34. ;; gc:deref : address -> flat-value
  35. (define (gc:deref address)
  36.   (unless (gc:flat? address)
  37.     (error 'gc:deref "not a flat: ~a" address))
  38.   (heap-ref (+ address 1)))
  39.  
  40.  
  41. ;; gc:cons : root root -> address
  42. (define (gc:cons root1 root2)
  43.   (define addr (malloc 3))
  44.   (heap-set! addr 'cons)
  45.   (heap-set! (+ addr 1) (read-root root1))
  46.   (heap-set! (+ addr 2) (read-root root2))
  47.   addr)
  48. ;; gc:cons? : address -> boolean
  49. (define (gc:cons? address)
  50.   (equal? (heap-ref address) 'cons))
  51. ;; gc:first : address -> address
  52. (define (gc:first address)
  53.   (unless (gc:cons? address)
  54.     (error 'gc:first "not a pair: ~a" address))
  55.   (heap-ref (+ address 1)))
  56. ;; gc:rest : address -> address
  57. (define (gc:rest address)
  58.   (unless (gc:cons? address)
  59.     (error 'gc:rest "not a pair: ~a" address))
  60.   (heap-ref (+ address 2)))
  61. ;; gc:set-first! : address address -> void
  62. (define (gc:set-first! address new-value-address)
  63.   (unless (gc:cons? address)
  64.     (error 'gc:set-first! "not a pair: ~a" address))
  65.   (heap-set! (+ address 1) new-value-address))
  66. ;; gc:set-rest! : address address -> void
  67. (define (gc:set-rest! address new-value-address)
  68.   (unless (gc:cons? address)
  69.     (error 'gc:set-rest! "not a pair: ~a" address))
  70.   (heap-set! (+ address 2) new-value-address))
  71.  
  72.  
  73. ;; gc:closure : opaque-value (listof root) -> address
  74. (define (gc:closure code-ptr free-vars)
  75.   (define addr (malloc (+ 2 (length free-vars))))
  76.   (heap-set! addr 'clos)
  77.   (heap-set! (+ addr 1) code-ptr)
  78.   (for ([i  (in-range (length free-vars))]
  79.         [fv (in-list free-vars)])
  80.     (heap-set! (+ addr 2 i) (read-root fv)))
  81.   addr)
  82. ;; gc:closure? : address -> boolean
  83. (define (gc:closure? address)
  84.   (equal? (heap-ref address) 'clos))
  85. ;; gc:closure-code-ptr : address -> opaque-value
  86. (define (gc:closure-code-ptr address)
  87.   (unless (gc:closure? address)
  88.     (error 'gc:closure-code-ptr "not a closure: ~a" address))
  89.   (heap-ref (+ address 1)))
  90. ;; gc:closure-env-ref : address integer -> address
  91. (define (gc:closure-env-ref address i)
  92.   (unless (gc:closure? address)
  93.     (error 'gc:closure-env-ref "not a closure: ~a" address))
  94.   (heap-ref (+ address 2 i)))
  95.  
  96.  
  97. (define-syntax-rule (test/heap/exn heap oper ...  expected)
  98.    (with-heap heap
  99.      (init-allocator)
  100.      (test/exn
  101.       (begin  oper ...)
  102.       expected)))
  103.  
  104. (define-syntax (test/heap stx)
  105.   (syntax-case stx ()
  106.     [(_ heap oper ...  expected)
  107.      (syntax/loc stx
  108.        (with-heap heap
  109.          (init-allocator)
  110.          (test
  111.           (begin oper ...)
  112.           expected)))]))
  113.  
  114. (module+ test
  115.   ;; OOM
  116.   (test/heap/exn (make-vector METADATA-SIZE)
  117.     (gc:alloc-flat #f)
  118.     "out of memory")
  119.  
  120.   ;; dereferencing cons as flat
  121.   (test/heap/exn (make-vector 1000)
  122.     (let ([cons-addr
  123.            (gc:cons
  124.             (simple-root (gc:alloc-flat #f))
  125.             (simple-root (gc:alloc-flat #t)))])
  126.       (gc:deref cons-addr))
  127.     "not a flat")
  128.  
  129.   ;; dereferencing flat as cons
  130.   (test/heap/exn (make-vector 1000)
  131.     (let ([flat-addr (gc:alloc-flat #f)])
  132.       (gc:first flat-addr))
  133.     "not a pair")
  134.  
  135.   ;; dereferencing flat as cons
  136.   (test/heap/exn (make-vector 1000)
  137.     (let ([flat-addr (gc:alloc-flat #f)])
  138.       (gc:rest flat-addr))
  139.     "not a pair")
  140.  
  141.   ;; setting flat as cons
  142.   (test/heap/exn (make-vector 1000)
  143.     (let ([flat-addr (gc:alloc-flat #f)])
  144.       (gc:set-first! flat-addr #t))
  145.     "not a pair")
  146.  
  147.   ;; setting flat as cons
  148.   (test/heap/exn (make-vector 1000)
  149.     (let ([flat-addr (gc:alloc-flat #f)])
  150.       (gc:set-rest! flat-addr #t))
  151.     "not a pair")
  152.  
  153.  
  154.   ;; getting code ptr from non closure
  155.   (test/heap/exn (make-vector 1000)
  156.     (let ([flat-addr (gc:alloc-flat #f)])
  157.       (gc:closure-code-ptr flat-addr))
  158.     "not a closure")
  159.  
  160.   ;; getting code ptr from non closure
  161.   (test/heap/exn (make-vector 1000)
  162.     (let ([flat-addr (gc:alloc-flat #f)])
  163.       (gc:closure-env-ref flat-addr 1))
  164.     "not a closure")
  165.  
  166.   ;; Successful dereference: flat
  167.   (test/heap (make-vector 1000)
  168.     (gc:deref (gc:alloc-flat #t))
  169.     #t)
  170.  
  171.   ;; successful dereference: cons
  172.   (test/heap (make-vector 1000)
  173.     (gc:deref
  174.      (gc:rest
  175.       (gc:cons
  176.        (simple-root (gc:alloc-flat 'first))
  177.        (simple-root (gc:alloc-flat 'rest)))))
  178.     'rest)
  179.  
  180.   (test/heap (make-vector 1000)
  181.     (gc:deref
  182.      (gc:first
  183.       (gc:cons
  184.        (simple-root (gc:alloc-flat 'first))
  185.        (simple-root (gc:alloc-flat 'rest)))))
  186.     'second)
  187.  
  188.   ;; successful alloc / deref closure
  189.   (test/heap (make-vector 1000)
  190.     (gc:closure-code-ptr
  191.      (gc:closure 'dummy '()))
  192.     'dummy)
  193.  
  194.   (test/heap (make-vector 1000)
  195.     (gc:deref
  196.      (gc:closure-env-ref
  197.       (gc:closure
  198.        'dummy
  199.        (list (simple-root (gc:alloc-flat #f))))
  200.       0))
  201.     #f)
  202.  
  203.   ;; setting cons parts
  204.   (test/heap (make-vector 1000)
  205.     (let ([cons-loc
  206.            (gc:cons
  207.             (simple-root (gc:alloc-flat 'first))
  208.             (simple-root (gc:alloc-flat 'rest)))])
  209.       (gc:set-first! cons-loc (gc:alloc-flat 'mutated))
  210.       (gc:deref (gc:first cons-loc)))
  211.     'mutated)
  212.  
  213.   (test/heap (make-vector 1000)
  214.     (let ([cons-loc
  215.            (gc:cons
  216.             (simple-root (gc:alloc-flat 'first))
  217.             (simple-root (gc:alloc-flat 'rest)))])
  218.       (gc:set-rest! cons-loc (gc:alloc-flat 'mutated))
  219.       (gc:deref (gc:rest cons-loc)))
  220.     'mutated)
  221.  
  222.   (let ([h (vector 'x 'x 'x 'x 'x)])
  223.     (test (with-heap h
  224.             (init-allocator)
  225.             (gc:alloc-flat #f)
  226.             h)
  227.           (vector 3 'flat #f 'x 'x)))
  228.   (let ([h (vector 'x 'x 'x 'x 'x 'x 'x 'x 'x)])
  229.     (test (with-heap
  230.               h
  231.             (init-allocator)
  232.             (gc:cons
  233.              (simple-root (gc:alloc-flat #f))
  234.              (simple-root (gc:alloc-flat #t)))
  235.             h)
  236.           (vector 8 'flat #f 'flat #t 'cons 1 3 'x))))

=>