suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial pass on adding manual closure management

Browse Source 
There are still five errors, but they seem to be errors in the sample
collector. But I need to find out.
This commit is contained in:
Jay McCarthy 2012-01-04 16:16:42 -07:00
parent f80292b4cf
commit caf83b911b
5 changed files with 689 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/plai/gc2/private/collector-exports.rkt Normal file
View File

@ -0,0 +1,39 @@
#lang scheme
(provide (all-defined-out))
(define collector:deref false)
(define collector:alloc-flat false)
(define collector:cons false)
(define collector:first false)
(define collector:rest false)
(define collector:flat? false)
(define collector:cons? false)
(define collector:set-first! false)
(define collector:set-rest! false)
(define (set-collector:deref! proc)
(set! collector:deref proc))
(define (set-collector:alloc-flat! proc)
(set! collector:alloc-flat proc))
(define (set-collector:cons! proc)
(set! collector:cons proc))
(define (set-collector:first! proc)
(set! collector:first proc))
(define (set-collector:rest! proc)
(set! collector:rest proc))
(define (set-collector:flat?! proc)
(set! collector:flat? proc))
(define (set-collector:cons?! proc)
(set! collector:cons? proc))
(define (set-collector:set-first!! proc)
(set! collector:set-first! proc))
(define (set-collector:set-rest!! proc)
(set! collector:set-rest! proc))

182
collects/plai/gc2/private/gc-core.rkt Normal file
View File

@ -0,0 +1,182 @@
#lang scheme
(require
(for-syntax scheme))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Locations
#|
(provide wrapped-location?)
(define-struct wrapped-location (location))
(provide/contract (wrap-location (location? . -> . wrapped-location?)))
(define (wrap-location loc)
(make-wrapped-location loc))
(provide/contract (unwrap-location (wrapped-location? . -> . location?)))
(define (unwrap-location wloc)
(wrapped-location-location wloc))
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Heap management
(provide current-heap)
(define current-heap (make-parameter false))
(define (format-cell cell)
(let* ([str (format "~s" cell)]
[len (string-length str)])
(if (<= len 10)
(string-append str (build-string (- 10 len) (λ (_) #\space)))
(substring str 0 10))))
;;; Textual representation of the heap
(provide heap-as-string)
(define (heap-as-string)
(let ([step 0])
(apply string-append
(for/list ([elt (in-vector (current-heap))])
(cond
[(= step 0)
(begin
(set! step (add1 step))
(format-cell elt))]
[(= step 9)
(begin
(set! step 0)
(string-append (format-cell elt) "\n"))]
[else
(begin
(set! step (add1 step))
(string-append " " (format-cell elt)))])))))
;;; Predicate determines values that may be stored on the heap. Limit this to "small" values that
;;; conceptually occupy a small, fixed amount of space. Closures are an exception.
(provide/contract [heap-value? (any/c . -> . boolean?)])
(define (heap-value? v)
(or (number? v) (symbol? v) (boolean? v) (empty? v) (procedure? v)))
(provide location?)
(define (location? v)
(if (vector? (current-heap))
(and (exact-nonnegative-integer? v) (< v (vector-length (current-heap))))
(error "Heap is unintialized")))
(provide/contract (init-heap! (exact-nonnegative-integer? . -> . void?)))
(define (init-heap! size)
(current-heap (build-vector size (λ (ix) false))))
(provide/contract (heap-set! (location? heap-value? . -> . void?)))
(define (heap-set! location value)
(vector-set! (current-heap) location value)
(when gui
(send gui update-view #:location location)))
(provide/contract (heap-ref (location? . -> . heap-value?)))
(define (heap-ref location)
(vector-ref (current-heap) location))
(provide/contract (heap-size (-> (or/c false/c exact-nonnegative-integer?))))
(define (heap-size)
(and (vector? (current-heap)) (vector-length (current-heap))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Root set management
(provide gc-roots-key)
(define gc-roots-key (gensym 'gc-roots-key))
;;; Roots are defined with custom getters and setters as they can be created in various ways.
(provide root? root-name make-root)
(define-struct root (name get set!)
#:property prop:custom-write (λ (v port write?)
(display (format "#<root:~a>" (root-name v)) port)))
(provide make-env-root)
(define-syntax (make-env-root stx)
(syntax-case stx ()
[(_ id) (identifier? #'id)
#`(make-root 'id (λ () id) (λ (loc) (set! id loc)))]))
;;; Roots on the stack.
(provide/contract (stack-roots (-> (listof root?))))
(define (stack-roots)
(filter is-mutable-root?
(apply append (continuation-mark-set->list (current-continuation-marks) gc-roots-key))))
; An immutable root is a reference to a value or procedure in the Scheme heap.
(define (is-mutable-root? root)
(location? ((root-get root))))
(provide/contract (make-stack-root (symbol? location? . -> . root?)))
(define (make-stack-root id location)
(make-root id (λ () location) (λ (new-location) (set! location new-location))))
(provide/contract (read-root (root? . -> . location?)))
(define (read-root root)
((root-get root)))
(provide/contract (set-root! (root? location? . -> . any)))
(define (set-root! root loc)
((root-set! root) loc))
(provide/contract (get-global-roots (-> (listof root?))))
(define (get-global-roots)
(filter is-mutable-root? global-roots))
(define global-roots empty)
(provide/contract (add-global-root! (root? . -> . void?)))
(define (add-global-root! root)
(set! global-roots (cons root global-roots)))
(provide get-root-set)
(define-syntax (get-root-set stx)
(syntax-case stx ()
[(_ root-id ...)
(andmap identifier? (syntax->list #'(root-id ...)))
#`(begin
(append
(list (make-root 'root-id (λ () root-id)
(λ (loc)
(set! root-id loc)))
...)
(get-global-roots)
(stack-roots)))]
[(_ e ...)
(let ([err (ormap (λ (x) (and (not (identifier? x)) x)) (syntax->list #'(e ...)))])
(raise-syntax-error false
"expected an identifier to treat as a root"
stx
err))]
[_ (raise-syntax-error false
"missing open parenthesis"
stx)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Environments of closures
; Once the closure is garbage collected, its environment is only reachable by a weak reference to
; the closure.
(define closure-envs (make-weak-hash))
(provide/contract (add-closure-env! (procedure? (listof root?) . -> . any)))
(define (add-closure-env! proc roots)
(hash-set! closure-envs proc roots))
(provide/contract (get-closure-env (procedure? . -> . (or/c false/c (listof root?)))))
(define (get-closure-env proc)
(hash-ref closure-envs proc false))
(provide/contract (procedure-roots (procedure? . -> . (listof root?))))
(define (procedure-roots proc)
(filter is-mutable-root? (hash-ref closure-envs proc empty)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Optional UI
(provide set-ui!)
(define (set-ui! ui%)
(set! gui (new ui% [heap-vec (current-heap)])))
(define gui false)

448
collects/plai/gc2/private/gc-gui.rkt Normal file
View File

@ -0,0 +1,448 @@
#lang scheme/gui
(require "gc-core.rkt")
(provide heap-viz%)
(define row-size 10)
(define heap-viz<%> (interface () update-view))
(define horizontal-axis-height 0)
(define vertical-axis-width 0)
(define label-line-size 2)
(define cell-horizontal-padding 6)
(define cell-vertical-padding 4)
(define vertical-axis-spacer 2)
(define-struct arrow (from to) #:transparent)
(define show-arrows? #t)
(define show-highlighted-cells? #f)
(define heap-canvas%
(class* canvas% (heap-viz<%>)
(init-field heap-vec)
(define column-widths (make-vector
(cond
[(<= (vector-length heap-vec) 300) 10]
[else 20])
0))
(define row-heights (make-vector (ceiling (/ (vector-length heap-vec)
(vector-length column-widths)))
0))
(define arrows '())
(define highlighted-cells '())
(define/public (update-view)
(setup-min-width/height)
(redraw-offscreen)
(recompute-arrows-and-highlighted-cells)
(on-paint))
(inherit get-dc get-client-size refresh min-width min-height)
(define/private (setup-min-width/height)
(fill-in-min-sizes)
(min-width (ceiling (inexact->exact (+ vertical-axis-width (vector-sum column-widths)))))
(min-height (ceiling (inexact->exact (+ horizontal-axis-height (vector-sum row-heights)))))
(compute-sizes))
(define/private (compute-sizes)
(fill-in-min-sizes)
(let-values ([(w h) (get-client-size)])
(define (distribute-extras sizes avail-size)
(let ([min-size (vector-sum sizes)])
(cond
[(< avail-size min-size)
;; just give up here; we'll draw outside the frame and get clipped
;; could try to shrink the bigger columns or something, tho.
(void)]
[else
;; distribute the extra width evenly to all the columns
(let ([extra-space (/ (- avail-size min-size)
(vector-length sizes))])
(for ([i (in-range 0 (vector-length sizes))])
(vector-set! sizes
i
(+ (vector-ref sizes i)
extra-space))))])))
(distribute-extras column-widths (- w vertical-axis-width))
(distribute-extras row-heights (- h horizontal-axis-height))))
(define/private (fill-in-min-sizes)
(let ([dc (get-dc)])
(let-values ([(w h d a)
(send dc get-text-extent (format "~a" (vector-length heap-vec)))])
(set! vertical-axis-width (+ w label-line-size vertical-axis-spacer)))
(let-values ([(w h d a) (send dc get-text-extent "1")])
(set! horizontal-axis-height (+ h label-line-size))))
(for ([i (in-range 0 (vector-length heap-vec))])
(let ([column (remainder i (vector-length column-widths))]
[row (quotient i (vector-length column-widths))])
(let-values ([(cw ch) (cell-min-size (vector-ref heap-vec i))])
(vector-set! row-heights
row
(max (+ ch cell-vertical-padding)
#;(vector-ref row-heights row)))
(vector-set! column-widths
column
(max (+ cw cell-horizontal-padding)
#;(vector-ref column-widths column)))))))
(define/private (cell-min-size obj)
(let ([dc (get-dc)])
(let-values ([(w h d a) (send dc get-text-extent (val->string obj))])
(values w h))))
(define/private (val->string obj)
(cond
[(boolean? obj) (if obj "#t" "#f")]
[(number? obj) (format "~a" obj)]
[(procedure? obj)
(if (object-name obj)
(format "~a" (object-name obj))
"#<proc>")]
[(symbol? obj) (format "'~s" obj)]
[(null? obj) "empty"]
[else (error 'val->string "unknown object, expected a heap-value.")]))
(define/override (on-paint)
(unless offscreen (redraw-offscreen))
(let ([dc (get-dc)])
(send dc set-origin 0 0)
(send dc draw-bitmap offscreen 0 0)
(send dc set-origin vertical-axis-width horizontal-axis-height)
(for-each (λ (i) (draw-cell dc i #t))
highlighted-cells)
(for-each (λ (arrow) (draw-arrow dc arrow))
arrows)))
(define offscreen #f)
(define/private (redraw-offscreen)
(let-values ([(w h) (get-client-size)])
(when (or (not offscreen)
(not (equal? w (send offscreen get-width)))
(not (equal? h (send offscreen get-height))))
(set! offscreen (make-object bitmap% w h)))
(let ([dc (make-object bitmap-dc% offscreen)])
(send dc set-smoothing 'aligned)
(send dc clear)
(send dc set-origin 0 0)
;; draw lines
(let-values ([(w h) (get-client-size)])
(send dc set-pen "navy" label-line-size 'solid)
(send dc draw-line
(- vertical-axis-width (/ label-line-size 2)) 0
(- vertical-axis-width (/ label-line-size 2)) h)
(send dc draw-line
0 (- horizontal-axis-height (/ label-line-size 2))
w (- horizontal-axis-height (/ label-line-size 2))))
(send dc set-origin vertical-axis-width horizontal-axis-height)
;; draw x axis
(let ([y (- 0 horizontal-axis-height label-line-size)])
(for/fold ([x 0])
([i (in-range 0 (vector-length column-widths))])
(let ([str (format "~a" i)])
(let-values ([(w h d a) (send dc get-text-extent str)])
(setup-colors dc (+ i 1) 0 #f)
(send dc draw-rectangle x y
(vector-ref column-widths i)
horizontal-axis-height)
(send dc draw-text str
(+ x (- (/ (vector-ref column-widths i) 2)
(/ w 2)))
y)
(+ x (vector-ref column-widths i))))))
;; draw y axis
(for/fold ([y 0])
([i (in-range 0 (vector-length row-heights))])
(let ([str (format "~a" (* i (vector-length column-widths)))])
(let-values ([(w h d a) (send dc get-text-extent str)])
(let ([x (- 0 label-line-size w vertical-axis-spacer)])
(setup-colors dc 0 (+ i 1) #f)
(send dc draw-rectangle
(- vertical-axis-width)
y
(- vertical-axis-width label-line-size)
(vector-ref row-heights i))
(send dc draw-text str
x
(+ y (- (/ (vector-ref row-heights i) 2)
(/ h 2))))
(+ y (vector-ref row-heights i))))))
;; draw cells (this is O(n^2), but it seems unlikely to ever matter
;; to fix, one would have to precompute the partial sums of the widths
;; and heights of the columns)
(for ([i (in-range 0 (round-up-to-even-multiple
(vector-length heap-vec)
(vector-length column-widths)))])
(draw-cell dc i #f))
(send dc set-bitmap #f))))
(define/private (draw-cell dc i highlighted?)
(let-values ([(cell-x cell-y cell-w cell-h) (cell->ltwh i)])
(let* ([column (remainder i (vector-length column-widths))]
[row (quotient i (vector-length column-widths))])
(setup-colors dc (+ column 1) (+ row 1) highlighted?)
(send dc draw-rectangle cell-x cell-y cell-w cell-h)
(when (< i (vector-length heap-vec))
(let-values ([(ow oh) (cell-min-size (vector-ref heap-vec i))])
(send dc draw-text
(val->string (vector-ref heap-vec i))
(+ cell-x (- (/ cell-w 2) (/ ow 2)))
(+ cell-y (- (/ cell-h 2) (/ oh 2)))))))))
(define/private (draw-arrow dc arrow)
(let-values ([(fcell-x fcell-y fcell-w fcell-h) (cell->ltwh (arrow-from arrow))]
[(tcell-x tcell-y tcell-w tcell-h) (cell->ltwh (arrow-to arrow))])
(let ([alpha (send dc get-alpha)])
(send dc set-alpha 2/3)
(send dc set-brush highlighted-color 'solid)
(send dc set-pen "black" 1 'transparent)
(send dc draw-ellipse
(+ fcell-x (/ fcell-w 2) -4)
(+ fcell-y (/ fcell-h 2) -4)
8 8)
(let-values ([(x y)
(fill-in-arrow (+ fcell-x (/ fcell-w 2))
(+ fcell-y (/ fcell-h 2))
(+ tcell-x (/ tcell-w 2))
(+ tcell-y (/ tcell-h 2)))])
(send dc draw-polygon arrow-points)
(send dc set-pen highlighted-color 2 'solid)
(send dc draw-line
(+ fcell-x (/ fcell-w 2))
(+ fcell-y (/ fcell-h 2))
x y))
(send dc set-alpha alpha))))
(define arrow-point1 (make-object point%))
(define arrow-point2 (make-object point%))
(define arrow-point3 (make-object point%))
(define arrow-points (list arrow-point1 arrow-point2 arrow-point3))
;; fill-in-arrow : number^ -> number number
;; returns the end point for the line, so that the line
;; doesn't cross over the arrow
(define triangle-left (make-polar 1 (* pi 1/12)))
(define triangle-right (make-polar 1 (* pi -1/12)))
(define/private (fill-in-arrow sx sy ex ey)
(let* ([dir (make-polar 16
(angle (- (make-rectangular sx (- sy))
(make-rectangular ex (- ey)))))]
[left-corner (* dir triangle-left)]
[right-corner (* dir triangle-right)]
[line-end-point (/ (+ left-corner right-corner) 2)])
(send arrow-point1 set-x ex)
(send arrow-point1 set-y ey)
(send arrow-point2 set-x (+ ex (real-part left-corner)))
(send arrow-point2 set-y (+ ey (- (imag-part left-corner))))
(send arrow-point3 set-x (+ ex (real-part right-corner)))
(send arrow-point3 set-y (+ ey (- (imag-part right-corner))))
(values (/ (+ (send arrow-point2 get-x) (send arrow-point3 get-x)) 2)
(/ (+ (send arrow-point2 get-y) (send arrow-point3 get-y)) 2))))
(define (cell->ltwh i)
(let* ([column (remainder i (vector-length column-widths))]
[row (quotient i (vector-length column-widths))]
[cell-x (vector-sum column-widths column)]
[cell-y (vector-sum row-heights row)])
(values cell-x cell-y
(vector-ref column-widths column)
(vector-ref row-heights row))))
(define/override (on-size w h)
(compute-sizes)
(redraw-offscreen)
(refresh))
(define/private (mouse-xy->ij mx my)
(define (find-index start vec m-coord)
(let loop ([coord start]
[i 0])
(cond
[(< i (vector-length vec))
(cond
[(<= coord m-coord (+ coord (vector-ref vec i)))
i]
[else
(loop (+ coord (vector-ref vec i))
(+ i 1))])]
[else #f])))
(values (find-index vertical-axis-width column-widths mx)
(find-index horizontal-axis-height row-heights my)))
(define/override (on-event evt)
(cond
[(or (send evt moving?)
(send evt entering?))
(set! mouse-x (send evt get-x))
(set! mouse-y (send evt get-y))]
[else
(set! mouse-x #f)
(set! mouse-y #f)])
(recompute-arrows-and-highlighted-cells))
(define mouse-x #f)
(define mouse-y #f)
(define/private (recompute-arrows-and-highlighted-cells)
(cond
[(and mouse-x mouse-y)
(let-values ([(i j) (mouse-xy->ij mouse-x mouse-y)])
(let ([index (and i j (+ (* j (vector-length column-widths)) i))])
(cond
[(and index (< index (vector-length heap-vec)))
(update-arrows (find-connections index))
(update-highlighted-cells (cons index (index->nexts index)))]
[else
(update-highlighted-cells '())
(update-arrows '())])))]
[else
(update-highlighted-cells '())
(update-arrows '())]))
(define/private (index->nexts index)
(if (< index (vector-length heap-vec))
(let ([n (vector-ref heap-vec index)])
(cond
[(and (exact-integer? n)
(<= 0 n)
(< n (vector-length heap-vec)))
(list n)]
[(procedure? n)
(map read-root (procedure-roots n))]
[else
'()]))
'()))
(define/private (find-connections start)
(let ([visited (make-hash)]
[ans '()])
(let loop ([i start])
(unless (hash-ref visited i #f)
(hash-set! visited i #t)
(for-each
(λ (next)
(set! ans (cons (make-arrow i next) ans))
(loop next))
(index->nexts i))))
ans))
(define/private (update-arrows new)
(when show-arrows?
(unless (equal? new arrows)
(set! arrows new)
(refresh))))
(define/private (update-highlighted-cells new)
(when show-highlighted-cells?
(unless (equal? new highlighted-cells)
(set! highlighted-cells new)
(refresh))))
(super-new)
(setup-min-width/height)
(send (get-dc) set-smoothing 'aligned)))
(define (round-up-to-even-multiple n cols)
(let ([%% (remainder n cols)])
(cond
[(zero? %%) n]
[else (+ n (- cols %%))])))
(define highlighted-color "forestgreen")
(define (setup-colors dc i j highlighted-cell?)
(send dc set-pen "black" 1 'transparent)
(cond
[highlighted-cell?
(send dc set-brush highlighted-color 'solid)
(send dc set-text-foreground (send the-color-database find-color "white"))]
[else
(send dc set-brush (ij->background-color i j) 'solid)
(send dc set-text-foreground (send the-color-database find-color (ij->text-color i j)))]))
(define (ij->background-color i j)
(cond
[(zero? i)
(if (zero? (modulo j 5))
"black"
"white")]
[(zero? j)
(if (zero? (modulo i 2))
"gray"
"white")]
[(zero? (modulo j 5))
"black"]
[(zero? (modulo i 2))
"gray"]
[else
"white"]))
(define (ij->text-color i j)
(let ([bkg (ij->background-color i j)])
(cond
[(equal? bkg "black")
"white"]
[else
"black"])))
(define (vector-sum v [cap (vector-length v)])
(for/fold ((sum 0))
((i (in-range cap)))
(+ sum (vector-ref v i))))
(define heap-viz%
(class* object% (heap-viz<%>)
(init heap-vec)
(define eventspace (make-eventspace))
(define frame
(parameterize ([current-eventspace eventspace])
(new frame% [label "Heap"])))
(define canvas (new heap-canvas% [parent frame] [heap-vec heap-vec] [style '(no-autoclear)]))
(new grow-box-spacer-pane% [parent frame])
(send frame show #t)
;; protects 'queued'
(define queued-sema (make-semaphore 1))
(define queued #f)
(define/public (update-view #:location loc)
(semaphore-wait queued-sema)
(cond
[queued
(semaphore-post queued-sema)]
[else
(set! queued #t)
(semaphore-post queued-sema)
(parameterize ([current-eventspace eventspace])
(queue-callback
(λ ()
(semaphore-wait queued-sema)
(set! queued #f)
(semaphore-post queued-sema)
;; we might get others queued while this happens, but that seems ok
(send canvas update-view))
;; low priority, so that mouse movements and window resizes
;; take priority (important in the case that the mutator is
;; running a tight loop that changes the heap)
#f))]))
(super-new)))

20
collects/plai/gc2/private/gc-transformer.rkt Normal file
View File

@ -0,0 +1,20 @@
#lang scheme
(provide/contract (find-referenced-locals ((listof identifier?) syntax? . -> . (listof identifier?))))
(define (find-referenced-locals env-ids stx)
(local ([define id-hash (make-custom-hash free-identifier=?
(λ (v) (equal-hash-code (syntax->datum v)))
(λ (v) (equal-secondary-hash-code (syntax->datum v))))]
[define (find stx)
(syntax-case stx ()
[(head . tail)
(begin
(find #'head)
(find #'tail))]
[id (identifier? stx)
(begin
(unless (dict-ref id-hash stx false)
(dict-set! id-hash stx true)))]
[_ (void)])])
(find stx)
(filter (λ (env-id) (dict-ref id-hash env-id false)) env-ids)))

18
collects/plai/gc2/random-mutator.rkt
View File

@ -1,18 +0,0 @@
#lang scheme/base
(require "private/random-mutator.rkt"
scheme/contract
"private/gc-core.rkt")
(provide/contract
[save-random-mutator
(->* (path-string?
string?)
(#:iterations
exact-positive-integer?
#:heap-values (cons/c heap-value? (listof heap-value?))
#:program-size exact-positive-integer?
#:heap-size exact-positive-integer?)
void?)]
[find-heap-values
(-> (or/c path-string? input-port?)
(listof heap-value?))])