IsaacShoebottom/CS4613
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve 3.rkt a bit

Browse Source
This commit is contained in:
Isaac Shoebottom
2025-04-24 13:57:54 -03:00
parent be4b687503
commit a85d95aa89
1 changed files with 17 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

67
Final/3.rkt
View File

@ -98,55 +98,28 @@
;; malloc : size -> address ;; malloc : size -> address
(define (malloc n . other-roots) (define (malloc n . other-roots)
(when (> (+ (ptr) n (length other-roots)) (space-size)) (when (> (+ (ptr) n) (space-size))
(gc!)) (gc!))
(when (> (+ (ptr) n (length other-roots)) (space-size)) (when (> (+ (ptr) n) (space-size))
(error 'malloc "out of memory!")) (error 'malloc "out of memory!"))
(heap-set! LOC:PTR (+ (ptr) n (length other-roots))) (heap-set! LOC:PTR (+ (ptr) n))
(+ (heap-ref LOC:OFFSET) (- (ptr) n (length other-roots)))) (+ (heap-ref LOC:OFFSET) (- (ptr) n)))
(define (forward/root thing) (define (forward/root thing)
(define addr (read-root thing)) (define addr (read-root thing))
(define fwrd (+ 1 addr))
(cond (cond
[(gc:flat? addr) (gc:alloc-flat (gc:deref addr))] [(gc:flat? addr) (heap-set! fwrd (gc:alloc-flat (gc:deref addr)))]
[(gc:cons? addr) (gc:cons (gc:first thing) (gc:rest addr))] ; maybe forward root on each cons cell? could fix what seems to be memory corruption
[(gc:closure? addr) (gc:closure (gc:closure-code-ptr addr) (empty))])) [(gc:cons? addr) (heap-set! fwrd (gc:cons (simple-root (gc:first addr)) (simple-root (gc:rest addr))))]
[(gc:closure? addr)
(define (forward/loc thing) (let ([code-ptr (gc:closure-code-ptr addr)]
(define tag (heap-ref thing)) [n-vars (heap-ref (+ addr 2))])
(cond (heap-set! fwrd
[(equal? tag 'forwarded) (gc:closure code-ptr
(void)] (for/list ([i (in-range n-vars)])
[(equal? tag 'flat) (forward/root (simple-root (gc:closure-env-ref addr i)))))))])
(heap-set! thing 'forwarded) (heap-set! addr 'forwarded))
(heap-set! (+ thing 1) (gc:alloc-flat (heap-ref (+ thing 1))))]
[(equal? tag 'cons)
(heap-set! thing 'forwarded)
(heap-set! (+ thing 1) (gc:cons
(simple-root (heap-ref (+ thing 1)))
(simple-root (heap-ref (+ thing 2)))))]
[(equal? tag 'clos)
(let* ([code-ptr (heap-ref (+ thing 1))]
[n-vars (heap-ref (+ thing 2))]
[free-vars (for/list ([i (in-range n-vars)])
(simple-root (heap-ref (+ thing 3 i))))])
(heap-set! thing 'forwarded)
(heap-set! (+ thing 1) (gc:closure code-ptr free-vars)))]
[else
(error 'forward/loc "unknown tag: ~a" tag)]))
(define (object-size addr)
(define tag (heap-ref addr))
(cond
[(equal? tag 'flat) 2]
[(equal? tag 'cons) 3]
[(equal? tag 'clos)
(let ([n-vars (+ addr 2)])
(+ 3 n-vars))]
[(equal? tag 'forwarded) 2]
[else
(error 'object-size "unknown tag: ~a" tag)]))
(define (gc! . other-roots) (define (gc! . other-roots)
(swap-spaces!) (swap-spaces!)
@ -154,13 +127,7 @@
;; Forward all roots to the new semi-space ;; Forward all roots to the new semi-space
(for-each forward/root (get-root-set)) (for-each forward/root (get-root-set))
(for-each forward/root other-roots) (for-each forward/root other-roots))
;; Forward all objects reachable from the roots
(let loop ([scan (off)])
(when (< scan (ptr))
(forward/loc scan)
(loop (+ scan (object-size scan))))))
;; gc:alloc-flat : flat-value -> address ;; gc:alloc-flat : flat-value -> address
(define (gc:alloc-flat value) (define (gc:alloc-flat value)