;; gc-cheney.ss

;; goal: a small computing system which supports
;;       list storage and garbage collection

;; this file implements Cheney's stop-and-copy compacting gc algorithm

(load "storage.ss")

;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; the type system
;;
;;;;;;;;;;;;;;;;;;;;;;;;;

;; broken heart
;; a datatype used by the garbage collector only
;; if the contents of a cons cell get moved,
;; we place a broken heart in its kar and a
;; forwarding address in its kdr

;  (bh 0) 

(define make-broken-heart
  (lambda ()
    (list 'bh 0)))

(define broken-heart?
  (lambda (typed-data)
    (eq? 'bh (typed-data->tag typed-data))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; garbage collection
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; process
;; move all cons-cells which are 
;; only one jump away from the root
;; process starts the job of relocating lists

(define process
  (lambda (stack)
    (cond ((null? stack) '())
          ((atomic-data? (car stack))
           (cons (car stack)
                 (process (cdr stack))))
          ((list-data? (car stack))
           (cons (new-frame (car stack))
                 (process (cdr stack))))
          (else (error "process: bad data" stack)))))
 
;; new-frame
;; produce a new stack frame 
;; (to be inserted into the symbol table)
;; containing the original var and a new val
;; indicating the new location of that var's
;; associated value in storage

(define new-frame
  (lambda (old-frame)
    (make-frame (frame->var old-frame) 
                (move (frame->typed-data old-frame)))))

;; move-cell
;; move the first cons-cell of a list 
;; for Cheney's algorithm, move = move-cell

(define move-cell
  (lambda (ptr)
    (if (forwarded? ptr)
      (forwarding-address ptr)
      (let ((loc =new-free=)
            (old-loc (typed-data->data ptr)))
        (begin
         (set! =new-free= (add1 =new-free=))
         (set-new-kar! loc (kar old-loc))
         (set-new-kdr! loc (kdr old-loc))
         ;; put a "broken heart" in the old kar
         (set-kar! old-loc (make-broken-heart))
         ;; put a forwarding address in the old kdr
         (let ((new-addr (make-pointer loc)))
           (set-kdr! old-loc new-addr)
           new-addr))))))

(define forwarded?
  (lambda (ptr)
    (and (pointer? ptr)
         (broken-heart? (kar (typed-data->data ptr))))))
    
(define forwarding-address
  (lambda (ptr)
    (kdr (typed-data->data ptr))))  

;; scan
;; scan completes the job of relocating lists
;; it is started in cell 0 and it finishes 
;; when it catches up with =new-free=

(define scan
  (lambda (addr)
    (if (< addr =new-free=)
      (let ((nkar (new-kar addr))
            (nkdr (new-kdr addr)))
       (if (pointer? nkar) 
         (set-new-kar! addr (move-cell nkar)))
       (if (pointer? nkdr)
         (set-new-kdr! addr (move-cell nkdr)))
       (scan (add1 addr))))))

;; flip interchanges old and new memory and
;; properly resets =free= and =new-free=
;; this is the last stage in garbage collection

(define flip
  (lambda ()
    (let ((a =the-kars=)
          (b =the-kdrs=)
          (c =new-kars=)
          (d =new-kdrs=)
          (f =new-free=))
      (set! =the-kars= c)
      (set! =the-kdrs= d)
      (set! =new-kars= a)
      (set! =new-kdrs= b)
      (set! =free= f)
      (set! =new-free= 0))))

;; gc

(define gc-cheney
  (lambda ()
    (set! =root= (process =root=))
    (scan 0)
    (flip)
    #t))

(define move move-cell)
(define gc gc-cheney)