(define-structure
(size flags next)) (define-function make-gc-protectors (vars) (map (lambda (v) (list 'gc_push_root (list 'address-of (car vars)))) vars)) (define-function make-gc-unprotectors (vars) (let ((result ())) (while (pair? vars) (set result (cons (list 'gc_pop_root (list 'address-of (car vars))) result)) (set vars (cdr vars))) result)) (define-form gc-protect (vars . prog) `(let () ,@(make-gc-protectors vars) (let ((__answer__ ,@prog)) ,@(make-gc-unprotectors vars) __answer__))) (compile-begin) (define gc_quantum 65504) (define gc_frequency 32768) (define exit (extern 'exit)) (define malloc (extern 'malloc)) (define free (extern 'free)) (define memset (extern 'memset)) (define memcpy (extern 'memcpy)) (define printf (extern 'printf)) (define gc_roots 0) (define gc_root_count 0) (define gc_root_max 0) (define gc_memory_base 0) (define gc_memory_last 0) (define gc_alloc_count 0) (define-form size-of-structure (type) (* 4 (array-at %structure-sizes (eval type)))) (define-form
-flags-used () 1) (define-form
-flags-atom () 2) (define-form
-flags-mark () 4) (define-form
-flags-mark-mask () -5) (define-form
-flags-used+atom () (+ (
-flags-used) (
-flags-atom))) (define-function max (a b) (if (> a b) a b)) (define-function fatal (reason) (printf "\n%s\n" reason) (exit 1)) (define-function new_memory_block (size) (let ((ptr (malloc size))) (or ptr (fatal "out of memory")) (set (
-size ptr) (- size (size-of-structure
))) (set (
-flags ptr) 0) (set (
-next ptr) ptr) (printf "BRK %p %d %d/%d\n" ptr size gc_alloc_count gc_frequency) ptr)) (define-function gc_initialise () (let ((ptr (new_memory_block gc_quantum))) (set gc_memory_base ptr) (set gc_memory_last ptr))) (define-function gc_push_root (ptr) (and (= gc_root_count gc_root_max) (let ((roots (malloc (* 4 (set gc_root_max (* 2 gc_root_max)))))) (memcpy roots gc_roots (* 4 gc_root_count)) (and gc_roots (free gc_roots)) (set gc_roots roots))) (set-oop-at gc_roots gc_root_count ptr) ;;(printf "gc add root %d at %p\n" gc_root_count ptr) (set gc_root_count (+ 1 gc_root_count))) (define-function gc_pop_root (ptr) (or gc_root_count (fatal "root table underflow")) (set gc_root_count (- gc_root_count 1)) ;;(printf "gc del root %d at %p\n" gc_root_count ptr) (or (= ptr (oop-at gc_roots gc_root_count)) (fatal "non-lifo root"))) (define-function gc_grow_memory (size) (let ((brk (new_memory_block size))) (set (
-next brk) (
-next gc_memory_last)) (set (
-next gc_memory_last) brk))) (define-function gc_malloc_chunk (size) (let ((ptr (
-next gc_memory_last)) (done ()) (chunk ())) (let ((lim ptr)) (while (not done) ;; (printf "alloc? %d %p %p [%p] %d >= %d %d\n" ;; (
-flags ptr) ptr (
-next ptr) lim ;; (
-size ptr) size ;; (<= size (
-size ptr))) (if (and (= 0 (
-flags ptr)) (<= size (
-size ptr))) (let () (set chunk ptr) (set done 1)) (set done (= lim (set ptr (
-next ptr))))))) ;;(printf "gc_malloc_chunk found free %p\n" chunk) (if chunk (let ((csize (
-size chunk))) ;;(printf "CSIZE %d\n" csize) (and (> csize (+ size (size-of-structure
))) (let ((split (+ chunk (+ (size-of-structure
) size)))) ;;(printf "SPLIT %p\n" split) (set (
-size split) (- csize (+ size (size-of-structure
)))) (set (
-flags split) 0) (set (
-next split) (
-next chunk)) (set (
-size chunk) size) (set (
-next chunk) split))) (set (
-flags chunk) (
-flags-used)) (set gc_memory_last chunk) ;;(printf "ALLOC CHUNK %p\n" chunk) (let ((obj (+ chunk (size-of-structure
)))) (memset obj 0 size) (set gc_alloc_count (+ gc_alloc_count 1)) obj))))) (define-function gc_sweep (obj) ;;(printf "SWEEP\n") (let ((ptr gc_memory_base) (nused 0) (nfree 0)) (while ptr ;;(printf "sweep? %d %p + %d\n" (
-flags ptr) ptr (
-size ptr)) (let ((flags (
-flags ptr))) (if (& flags (
-flags-mark)) (let () (set nused (+ nused (
-size ptr))) (set (
-flags ptr) (& flags (
-flags-mark-mask)))) ;;(printf "COLLECT %p %d\n" ptr (
-size ptr)) ;; (while (and (= 0 (& (
-flags-mark) (
-flags (
-next ptr)))) ;; (printf "%p + %d + %d = %p ? %p\n" ;; ptr (size-of-structure
) (
-size ptr) ;; (+ ptr (+ (size-of-structure
) (
-size ptr))) ;; (
-next ptr)) ;; (= (
-next ptr) (+ ptr (+ (size-of-structure
) (
-size ptr))))) ;; (let ((next (
-next (
-next ptr)))) ;; (printf "COALESCE %p < %p > %p\n" ptr (
-next ptr) next) ;; (set (
-size ptr) (- (- next ptr) (size-of-structure
))) ;; (set (
-next ptr) next))) (set nfree (+ nfree (
-size ptr))) (set (
-flags ptr) 0))) (and (= gc_memory_base (set ptr (
-next ptr))) (set ptr 0))) (printf "%d used, %d free, %d allocations\n" nused nfree gc_alloc_count) (and (< nfree nused) (gc_grow_memory gc_quantum)) )) (define-function gc_mark_and_trace (obj) ;;(printf "mark and trace %p\n" obj) (and obj (not (& obj 1)) (let* ((ptr (- obj (size-of-structure
))) (flags (
-flags ptr))) (or (& flags (
-flags-mark)) (let ((size (>> (
-size ptr) 2))) ;;(printf "mark %p %d\n" ptr size) (while size (set size (- size 1)) ;;(printf "@%d %p\n" size (oop-at obj size)) (gc_mark_and_trace (oop-at obj size))) (set (
-flags ptr) (| flags (
-flags-mark)))))))) (define-function gc_gcollect () (let ((i 0)) (while (< i gc_root_count) ;;(let ((ptr (oop-at gc_roots i))) (printf "mark gc root at %p -> %p\n" ptr (oop-at ptr 0))) (gc_mark_and_trace (oop-at (oop-at gc_roots i) 0)) (set i (+ 1 i)))) (gc_sweep) (set gc_alloc_count 0)) (define-function gc_malloc (size) (set size (& -4 (+ 3 size))) (and (= gc_alloc_count gc_frequency) (gc_gcollect)) (or (gc_malloc_chunk size) (let () (gc_grow_memory (max (+ (size-of-structure
) size) gc_quantum)) (gc_malloc_chunk size)) (fatal "internal error: failed to allocate object after growing memory"))) (define-function gc_malloc_atomic (size) (let* ((obj (gc_malloc size))) (set (
-flags (- obj (size-of-structure
))) (
-flags-used+atom)) obj)) (define-function make_pair (head tail) (let ((cell (gc_malloc 8))) (set-oop-at cell 0 head) (set-oop-at cell 1 tail) ;;(printf "pair %p (%p %p) (%p %p)\n" cell head tail (oop-at cell 0) (oop-at cell 1)) cell)) (define-function make_list (size) (if size (let ((list (make_list (- size 1)))) (gc_push_root (address-of list)) (set list (make_pair (| 1 (<< size 1)) list)) (gc_pop_root (address-of list)) list))) (define-function print_list (list) (if 0 (if list (let () (printf "%p " list (oop-at list 0)) (print_list (oop-at list 1))) (printf "\n")))) (define-function main (argc argv) (gc_initialise) (printf "%p\n" gc_memory_base) (printf "%x\n" (
-size gc_memory_base)) (printf "%x\n" (
-flags gc_memory_base)) (printf "%p\n" (
-next gc_memory_base)) (printf "%p\n" (gc_malloc 8)) (printf "%p\n" (gc_malloc 8)) (printf "%p\n" (gc_malloc 8)) (printf "%p\n" (gc_malloc 8)) (let ((i 0)) (let ((obj 0)) (gc-protect (obj) (while (< i 1000) (print_list (set obj (make_list 256))) (set i (+ i 1))) (gc_gcollect)) (gc_gcollect) )) 0 ) (compile-end)