#lang racket
(module call-dyn plait
  
  )
(require 'call-dyn)

(module gc-question racket
  #|
  Below you are given a partial implementation of a plai/gc2 style
  collector for a simple heap with no freelist or bitmap in the style of
  lecture 18.  Unlike lecture 20, in this question you are asked to
  combine the phase of marking white with that of freeing any records
  previously marked white. This follows the ideas of the incremental
  collector of lecture 22, and we borrow the name of the function
  free/mark-white! from that collector. Complete the function
  free/mark-white! so that the given tests pass.
  
  Note:
  
  - You do not have to write the whole collector here, just the "sweep"
  part of a mark-and-sweep. 
  
  - The code from Lecture 22 will not work directly due to a different
  heap representation.
  
  |#
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; This part provides 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-syntax-rule (with-heap vec expr ...)
    (parameterize
        ([current-heap vec])
      (begin
        expr ...)))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; This part is the partial implementation of a collector API For
  ;; simplicity, use our very first allocator without any data
  ;; structure.
  
  (define (init-allocator)
    (vector-fill! (current-heap) 'free))
  
  (define (alloc/header tag . vals)
    (define loc (malloc (+ 1 (length vals))))
    (heap-set! loc tag)
    (for ([i (in-range (length vals))]
          [v (in-list vals)])
      (heap-set! (+ loc i 1) v))
    loc)
  
  (define (gc:alloc-flat val) (alloc/header 'flat val))
  
  (define (gc:cons val1 val2) (alloc/header 'cons val1 val2))
  
  
  ;; Linear time allocator, based on Lecture 20
  
  (define (malloc size)
    (define ptr (find-free-space size))
    (unless ptr  (error 'alloc "out of memory"))
    ptr)
  
  (define (find-free-space n)
    (define (n-free-blocks? start n)
      (for/fold ([ok #t])
                ([i (in-range start (+ start n))])
        (and ok (equal? (heap-ref i) 'free))))
  
    (define (loop start)
      (and
       (< start (heap-size))
       (case (heap-ref start)
         [(flat) (loop (+ start 2))]
         [(cons) (loop (+ start 3))]
         [(free) (if (n-free-blocks? start n)
                     start
                     (loop (+ start 1)))]
         [else (error 'find-free-space
                      "unexpected tag ~a" start)])))
    (loop 0))
  
  ;; Here is the function you need to write
  (define (free/mark-white!)
    (void))
  
  (with-heap (make-vector 7 '?)
    (init-allocator)
    (test (current-heap) (make-vector 7 'free))
    (gc:alloc-flat 'first)
    (test (current-heap) #(flat first free free free free free))
    (gc:alloc-flat 'rest)
    (test (current-heap) #(flat first flat rest free free free))
    (gc:cons 0 2)
    (test (current-heap) #(flat first flat rest cons 0 2))
    (free/mark-white!)
    (test (current-heap) #(white-flat first white-flat rest white-cons 0 2))
    (free/mark-white!)
    (test (current-heap)  (make-vector 7 'free)))
  
  (with-heap  (vector 'flat 'first 'flat 'rest 'white-cons 0 2)
    (free/mark-white!)
    (test (current-heap) #(white-flat first white-flat rest free free free))
    (heap-set! 0 'flat)
    (free/mark-white!)
    (test (current-heap) #(white-flat first free free free free free)))
  
  )
(require 'gc-question)