Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-13 15:57:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge branch 'gc-opt5-dev'

Browse source
This commit is contained in:
Justin Ethier 2017-01-30 17:06:16 +00:00
commit 884a4a1c08
7 changed files with 761 additions and 303 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

129
examples/threading/benchmarks/ctak.scm Normal file
View file

@ -0,0 +1,129 @@
;;; CTAK -- A version of the TAK procedure that uses continuations.
(import (scheme base) (scheme read) (scheme write) (scheme time) (srfi 18))
(define (ctak x y z)
(call-with-current-continuation
(lambda (k) (ctak-aux k x y z))))
(define (ctak-aux k x y z)
(if (not (< y x))
(k z)
(call-with-current-continuation
(lambda (k)
(ctak-aux
k
(call-with-current-continuation
(lambda (k) (ctak-aux k (- x 1) y z)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- y 1) z x)))
(call-with-current-continuation
(lambda (k) (ctak-aux k (- z 1) x y))))))))
(define (main)
(let* ((count (read))
(input1 (read))
(input2 (read))
(input3 (read))
(output (read))
(s4 (number->string count))
(s3 (number->string input3))
(s2 (number->string input2))
(s1 (number->string input1))
(name "ctak"))
(run-r7rs-benchmark
(string-append name ":" s1 ":" s2 ":" s3 ":" s4)
count
(lambda ()
#;(thread-start!
(make-thread
(lambda ()
(ctak (hide count input1) (hide count input2) (hide count input3)))))
#;(thread-start!
(make-thread
(lambda ()
(ctak (hide count input1) (hide count input2) (hide count input3)))))
#;(thread-start!
(make-thread
(lambda ()
(ctak (hide count input1) (hide count input2) (hide count input3)))))
(thread-start!
(make-thread
(lambda ()
(ctak (hide count input1) (hide count input2) (hide count input3)))))
(thread-sleep! 10000)
(ctak (hide count input1) (hide count input2) (hide count input3))
;; TODO: thread-join
)
(lambda (result) (equal? result output)))))
;;; The following code is appended to all benchmarks.
;;; Given an integer and an object, returns the object
;;; without making it too easy for compilers to tell
;;; the object will be returned.
(define (hide r x)
(call-with-values
(lambda ()
(values (vector values (lambda (x) x))
(if (< r 100) 0 1)))
(lambda (v i)
((vector-ref v i) x))))
;;; Given the name of a benchmark,
;;; the number of times it should be executed,
;;; a thunk that runs the benchmark once,
;;; and a unary predicate that is true of the
;;; correct results the thunk may return,
;;; runs the benchmark for the number of specified iterations.
(define (run-r7rs-benchmark name count thunk ok?)
;; Rounds to thousandths.
(define (rounded x)
(/ (round (* 1000 x)) 1000))
(display "Running ")
(display name)
(newline)
(flush-output-port (current-output-port))
(let* ((j/s (jiffies-per-second))
(t0 (current-second))
(j0 (current-jiffy)))
(let loop ((i 0)
(result #f))
(cond ((< i count)
(loop (+ i 1) (thunk)))
((ok? result)
(let* ((j1 (current-jiffy))
(t1 (current-second))
(jifs (- j1 j0))
(secs (inexact (/ jifs j/s)))
(secs2 (rounded (- t1 t0))))
(display "Elapsed time: ")
(write secs)
(display " seconds (")
(write secs2)
(display ") for ")
(display name)
(newline)
(display "+!CSVLINE!+")
(display (this-scheme-implementation-name))
(display ",")
(display name)
(display ",")
(display secs)
(newline)
(flush-output-port (current-output-port)))
result)
(else
(display "ERROR: returned incorrect result: ")
(write result)
(newline)
(flush-output-port (current-output-port))
result)))))
(define (this-scheme-implementation-name)
(string-append "cyclone-" (Cyc-version)))
(main)

270
examples/threading/benchmarks/paraffins.scm Normal file
View file

@ -0,0 +1,270 @@
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
(import (scheme base) (scheme read) (scheme write) (scheme time) (srfi 18))
;;; This benchmark uses the following R6RS procedures.
(define (div x y)
(quotient x y))
;;; End of (faked) R6RS procedures.
(define (gen n)
(let* ((n/2 (div n 2))
(radicals (make-vector (+ n/2 1) '(H))))
(define (rads-of-size n)
(let loop1 ((ps
(three-partitions (- n 1)))
(lst
'()))
(if (null? ps)
lst
(let* ((p (car ps))
(nc1 (vector-ref p 0))
(nc2 (vector-ref p 1))
(nc3 (vector-ref p 2)))
(let loop2 ((rads1
(vector-ref radicals nc1))
(lst
(loop1 (cdr ps)
lst)))
(if (null? rads1)
lst
(let loop3 ((rads2
(if (= nc1 nc2)
rads1
(vector-ref radicals nc2)))
(lst
(loop2 (cdr rads1)
lst)))
(if (null? rads2)
lst
(let loop4 ((rads3
(if (= nc2 nc3)
rads2
(vector-ref radicals nc3)))
(lst
(loop3 (cdr rads2)
lst)))
(if (null? rads3)
lst
(cons (vector 'C
(car rads1)
(car rads2)
(car rads3))
(loop4 (cdr rads3)
lst))))))))))))
(define (bcp-generator j)
(if (odd? j)
'()
(let loop1 ((rads1
(vector-ref radicals (div j 2)))
(lst
'()))
(if (null? rads1)
lst
(let loop2 ((rads2
rads1)
(lst
(loop1 (cdr rads1)
lst)))
(if (null? rads2)
lst
(cons (vector 'BCP
(car rads1)
(car rads2))
(loop2 (cdr rads2)
lst))))))))
(define (ccp-generator j)
(let loop1 ((ps
(four-partitions (- j 1)))
(lst
'()))
(if (null? ps)
lst
(let* ((p (car ps))
(nc1 (vector-ref p 0))
(nc2 (vector-ref p 1))
(nc3 (vector-ref p 2))
(nc4 (vector-ref p 3)))
(let loop2 ((rads1
(vector-ref radicals nc1))
(lst
(loop1 (cdr ps)
lst)))
(if (null? rads1)
lst
(let loop3 ((rads2
(if (= nc1 nc2)
rads1
(vector-ref radicals nc2)))
(lst
(loop2 (cdr rads1)
lst)))
(if (null? rads2)
lst
(let loop4 ((rads3
(if (= nc2 nc3)
rads2
(vector-ref radicals nc3)))
(lst
(loop3 (cdr rads2)
lst)))
(if (null? rads3)
lst
(let loop5 ((rads4
(if (= nc3 nc4)
rads3
(vector-ref radicals nc4)))
(lst
(loop4 (cdr rads3)
lst)))
(if (null? rads4)
lst
(cons (vector 'CCP
(car rads1)
(car rads2)
(car rads3)
(car rads4))
(loop5 (cdr rads4)
lst))))))))))))))
(let loop ((i 1))
(if (> i n/2)
(vector (bcp-generator n)
(ccp-generator n))
(begin
(vector-set! radicals i (rads-of-size i))
(loop (+ i 1)))))))
(define (three-partitions m)
(let loop1 ((lst '())
(nc1 (div m 3)))
(if (< nc1 0)
lst
(let loop2 ((lst lst)
(nc2 (div (- m nc1) 2)))
(if (< nc2 nc1)
(loop1 lst
(- nc1 1))
(loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst)
(- nc2 1)))))))
(define (four-partitions m)
(let loop1 ((lst '())
(nc1 (div m 4)))
(if (< nc1 0)
lst
(let loop2 ((lst lst)
(nc2 (div (- m nc1) 3)))
(if (< nc2 nc1)
(loop1 lst
(- nc1 1))
(let ((start (max nc2 (- (div (+ m 1) 2) (+ nc1 nc2)))))
(let loop3 ((lst lst)
(nc3 (div (- m (+ nc1 nc2)) 2)))
(if (< nc3 start)
(loop2 lst (- nc2 1))
(loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst)
(- nc3 1))))))))))
(define (nb n)
(let ((x (gen n)))
(+ (length (vector-ref x 0))
(length (vector-ref x 1)))))
(define (main)
(let* ((count (read))
(input1 (read))
(output (read))
(s2 (number->string count))
(s1 (number->string input1))
(name "paraffins"))
(run-r7rs-benchmark
(string-append name ":" s1 ":" s2)
count
(lambda ()
#;(thread-start!
(make-thread
(lambda ()
(nb (hide count input1)))))
(thread-start!
(make-thread
(lambda ()
(nb (hide count input1)))))
(nb (hide count input1))
)
(lambda (result) (= result output)))))
;;; The following code is appended to all benchmarks.
;;; Given an integer and an object, returns the object
;;; without making it too easy for compilers to tell
;;; the object will be returned.
(define (hide r x)
(call-with-values
(lambda ()
(values (vector values (lambda (x) x))
(if (< r 100) 0 1)))
(lambda (v i)
((vector-ref v i) x))))
;;; Given the name of a benchmark,
;;; the number of times it should be executed,
;;; a thunk that runs the benchmark once,
;;; and a unary predicate that is true of the
;;; correct results the thunk may return,
;;; runs the benchmark for the number of specified iterations.
(define (run-r7rs-benchmark name count thunk ok?)
;; Rounds to thousandths.
(define (rounded x)
(/ (round (* 1000 x)) 1000))
(display "Running ")
(display name)
(newline)
(flush-output-port (current-output-port))
(let* ((j/s (jiffies-per-second))
(t0 (current-second))
(j0 (current-jiffy)))
(let loop ((i 0)
(result #f))
(cond ((< i count)
(loop (+ i 1) (thunk)))
((ok? result)
(let* ((j1 (current-jiffy))
(t1 (current-second))
(jifs (- j1 j0))
(secs (inexact (/ jifs j/s)))
(secs2 (rounded (- t1 t0))))
(display "Elapsed time: ")
(write secs)
(display " seconds (")
(write secs2)
(display ") for ")
(display name)
(newline)
(display "+!CSVLINE!+")
(display (this-scheme-implementation-name))
(display ",")
(display name)
(display ",")
(display secs)
(newline)
(flush-output-port (current-output-port)))
result)
(else
(display "ERROR: returned incorrect result: ")
(write result)
(newline)
(flush-output-port (current-output-port))
result)))))
(define (this-scheme-implementation-name)
(string-append "cyclone-" (Cyc-version)))
(main)

432
gc.c
View file

@ -55,12 +55,11 @@ static void **mark_stack = NULL;
static int mark_stack_len = 0;
static int mark_stack_i = 0;
// Lock to protect the heap from concurrent modifications
static pthread_mutex_t heap_lock;
// Cached heap statistics
static int cached_heap_free_sizes[7] = { 0, 0, 0, 0, 0, 0, 0 };
static int cached_heap_total_sizes[7] = { 0, 0, 0, 0, 0, 0, 0 };
// Data for the "main" thread which is guaranteed to always be there.
// Per SRFI 18:
// All threads are terminated when the primordial
// thread terminates (normally or not).
static gc_thread_data *primordial_thread = NULL;
// Data for each individual mutator thread
ck_array_t Cyc_mutators, old_mutators;
@ -144,10 +143,6 @@ void gc_initialize()
mark_stack = vpbuffer_realloc(mark_stack, &(mark_stack_len));
// Here is as good a place as any to do this...
if (pthread_mutex_init(&(heap_lock), NULL) != 0) {
fprintf(stderr, "Unable to initialize heap_lock mutex\n");
exit(1);
}
if (pthread_mutex_init(&(mutators_lock), NULL) != 0) {
fprintf(stderr, "Unable to initialize mutators_lock mutex\n");
exit(1);
@ -164,6 +159,11 @@ void gc_add_mutator(gc_thread_data * thd)
}
ck_array_commit(&Cyc_mutators);
pthread_mutex_unlock(&mutators_lock);
// Main thread is always the first one added
if (primordial_thread == NULL) {
primordial_thread = thd;
}
}
// Remove selected mutator from the mutator list.
@ -211,8 +211,11 @@ void gc_free_old_thread_data()
pthread_mutex_unlock(&mutators_lock);
}
/**
* Create a new heap page. The caller must hold the necessary locks.
*/
gc_heap *gc_heap_create(int heap_type, size_t size, size_t max_size,
size_t chunk_size)
size_t chunk_size, gc_thread_data *thd)
{
gc_free_list *free, *next;
gc_heap *h;
@ -222,12 +225,12 @@ gc_heap *gc_heap_create(int heap_type, size_t size, size_t max_size,
return NULL;
h->type = heap_type;
h->size = size;
h->newly_created = 1;
h->ttl = 10;
h->next_free = h;
h->last_alloc_size = 0;
//h->free_size = size;
cached_heap_total_sizes[heap_type] += size;
cached_heap_free_sizes[heap_type] += size;
ck_pr_add_ptr(&(thd->cached_heap_total_sizes[heap_type]), size);
ck_pr_add_ptr(&(thd->cached_heap_free_sizes[heap_type]), size);
h->chunk_size = chunk_size;
h->max_size = max_size;
h->data = (char *)gc_heap_align(sizeof(h->data) + (uintptr_t) & (h->data));
@ -263,7 +266,7 @@ gc_heap *gc_heap_free(gc_heap *page, gc_heap *prev_page)
{
// At least for now, do not free first page
if (prev_page == NULL || page == NULL) {
return page;
return NULL;
}
#if GC_DEBUG_TRACE
fprintf(stderr, "DEBUG freeing heap type %d page at addr: %p\n", page->type, page);
@ -474,11 +477,11 @@ char *gc_copy_obj(object dest, char *obj, gc_thread_data * thd)
return (char *)obj;
}
int gc_grow_heap(gc_heap * h, int heap_type, size_t size, size_t chunk_size)
int gc_grow_heap(gc_heap * h, int heap_type, size_t size, size_t chunk_size, gc_thread_data *thd)
{
size_t /*cur_size,*/ new_size;
gc_heap *h_last = h, *h_new;
pthread_mutex_lock(&heap_lock);
pthread_mutex_lock(&(thd->heap_lock));
// Compute size of new heap page
if (heap_type == HEAP_HUGE) {
new_size = gc_heap_align(size) + 128;
@ -493,6 +496,9 @@ int gc_grow_heap(gc_heap * h, int heap_type, size_t size, size_t chunk_size)
if (new_size < HEAP_SIZE) {
new_size = prev_size + h_last->size;
prev_size = h_last->size;
if (new_size > HEAP_SIZE) {
new_size = HEAP_SIZE;
}
} else {
new_size = HEAP_SIZE;
}
@ -516,9 +522,9 @@ int gc_grow_heap(gc_heap * h, int heap_type, size_t size, size_t chunk_size)
// allocate larger pages if size will not fit on the page
//new_size = gc_heap_align(((cur_size > size) ? cur_size : size));
// Done with computing new page size
h_new = gc_heap_create(heap_type, new_size, h_last->max_size, chunk_size);
h_new = gc_heap_create(heap_type, new_size, h_last->max_size, chunk_size, thd);
h_last->next = h_new;
pthread_mutex_unlock(&heap_lock);
pthread_mutex_unlock(&(thd->heap_lock));
#if GC_DEBUG_TRACE
fprintf(stderr, "DEBUG - grew heap\n");
#endif
@ -530,7 +536,7 @@ void *gc_try_alloc(gc_heap * h, int heap_type, size_t size, char *obj,
{
gc_heap *h_passed = h;
gc_free_list *f1, *f2, *f3;
pthread_mutex_lock(&heap_lock);
pthread_mutex_lock(&(thd->heap_lock));
// Start searching from the last heap page we had a successful
// allocation from, unless the current request is for a smaller
// block in which case there may be available memory closer to
@ -557,17 +563,17 @@ void *gc_try_alloc(gc_heap * h, int heap_type, size_t size, char *obj,
// Copy object into heap now to avoid any uninitialized memory issues
gc_copy_obj(f2, obj, thd);
//h->free_size -= gc_allocated_bytes(obj, NULL, NULL);
cached_heap_free_sizes[heap_type] -=
gc_allocated_bytes(obj, NULL, NULL);
ck_pr_sub_ptr(&(thd->cached_heap_free_sizes[heap_type]),
gc_allocated_bytes(obj, NULL, NULL));
}
h_passed->next_free = h;
h_passed->last_alloc_size = size;
pthread_mutex_unlock(&heap_lock);
pthread_mutex_unlock(&(thd->heap_lock));
return f2;
}
}
}
pthread_mutex_unlock(&heap_lock);
pthread_mutex_unlock(&(thd->heap_lock));
return NULL;
}
@ -607,11 +613,15 @@ void *gc_alloc(gc_heap_root * hrt, size_t size, char *obj, gc_thread_data * thd,
// A vanilla mark&sweep collector would collect now, but unfortunately
// we can't do that because we have to go through multiple stages, some
// of which are asynchronous. So... no choice but to grow the heap.
gc_grow_heap(h, heap_type, size, 0);
gc_grow_heap(h, heap_type, size, 0, thd);
*heap_grown = 1;
result = gc_try_alloc(h, heap_type, size, obj, thd);
if (!result) {
fprintf(stderr, "out of memory error allocating %zu bytes\n", size);
fprintf(stderr, "Heap type %d diagnostics:\n", heap_type);
pthread_mutex_lock(&(thd->heap_lock));
gc_print_stats(h);
pthread_mutex_unlock(&(thd->heap_lock)); // why not
exit(1); // could throw error, but OOM is a major issue, so...
}
}
@ -690,18 +700,18 @@ gc_heap *gc_heap_last(gc_heap * h)
return h;
}
size_t gc_heap_total_size(gc_heap * h)
{
size_t total_size = 0;
pthread_mutex_lock(&heap_lock);
while (h) {
total_size += h->size;
h = h->next;
}
pthread_mutex_unlock(&heap_lock);
return total_size;
}
//size_t gc_heap_total_size(gc_heap * h)
//{
// size_t total_size = 0;
// pthread_mutex_lock(&heap_lock);
// while (h) {
// total_size += h->size;
// h = h->next;
// }
// pthread_mutex_unlock(&heap_lock);
// return total_size;
//}
//
//size_t gc_heap_total_free_size(gc_heap *h)
//{
// size_t total_size = 0;
@ -714,7 +724,71 @@ size_t gc_heap_total_size(gc_heap * h)
// return total_size;
//}
size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr)
// A convenient front-end to the actual gc_sweep function.
void gc_collector_sweep()
{
ck_array_iterator_t iterator;
gc_thread_data *m;
gc_heap *h;
int heap_type;
size_t freed_tmp = 0, freed = 0;
#if GC_DEBUG_TRACE
size_t total_size;
size_t total_free;
time_t gc_collector_start = time(NULL);
#endif
CK_ARRAY_FOREACH(&Cyc_mutators, &iterator, &m) {
for (heap_type = 0; heap_type < NUM_HEAP_TYPES; heap_type++) {
h = m->heap->heap[heap_type];
if (h) {
gc_sweep(h, heap_type, &freed_tmp, m);
freed += freed_tmp;
}
}
// TODO: this loop only includes smallest 2 heaps, is that sufficient??
for (heap_type = 0; heap_type < 2; heap_type++) {
while ( ck_pr_load_ptr(&(m->cached_heap_free_sizes[heap_type])) <
(ck_pr_load_ptr(&(m->cached_heap_total_sizes[heap_type])) * GC_FREE_THRESHOLD)) {
#if GC_DEBUG_TRACE
fprintf(stderr, "Less than %f%% of the heap %d is free, growing it\n",
100.0 * GC_FREE_THRESHOLD, heap_type);
#endif
if (heap_type == HEAP_SM) {
gc_grow_heap(m->heap->heap[heap_type], heap_type, 0, 0, m);
} else if (heap_type == HEAP_64) {
gc_grow_heap(m->heap->heap[heap_type], heap_type, 0, 0, m);
} else if (heap_type == HEAP_REST) {
gc_grow_heap(m->heap->heap[heap_type], heap_type, 0, 0, m);
}
}
}
#if GC_DEBUG_TRACE
total_size = ck_pr_load_ptr(&(m->cached_heap_total_sizes[HEAP_SM])) +
ck_pr_load_ptr(&(m->cached_heap_total_sizes[HEAP_64])) +
#if INTPTR_MAX == INT64_MAX
ck_pr_load_ptr(&(m->cached_heap_total_sizes[HEAP_96])) +
#endif
ck_pr_load_ptr(&(m->cached_heap_total_sizes[HEAP_REST]));
total_free = ck_pr_load_ptr(&(m->cached_heap_free_sizes[HEAP_SM])) +
ck_pr_load_ptr(&(m->cached_heap_free_sizes[HEAP_64])) +
#if INTPTR_MAX == INT64_MAX
ck_pr_load_ptr(&(m->cached_heap_free_sizes[HEAP_96])) +
#endif
ck_pr_load_ptr(&(m->cached_heap_free_sizes[HEAP_REST]));
fprintf(stderr,
"sweep done, total_size = %zu, total_free = %zu, freed = %zu, elapsed = %ld\n",
total_size, total_free, freed,
(time(NULL) - gc_collector_start));
#endif
}
#if GC_DEBUG_TRACE
fprintf(stderr, "all thread heap sweeps done\n");
#endif
}
size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr, gc_thread_data *thd)
{
size_t freed, max_freed = 0, heap_freed = 0, sum_freed = 0, size;
object p, end;
@ -726,13 +800,9 @@ size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr)
//
// Lock the heap to prevent issues with allocations during sweep
// It sucks to have to use a coarse-grained lock like this, but let's
// be safe and prevent threading issues right now. Once the new GC
// works we can go back and try to speed things up (if possible)
// by using more fine-grained locking. Can also profile to see
// how much time is even spent sweeping
// This coarse-grained lock actually performed better than a fine-grained one.
//
pthread_mutex_lock(&heap_lock);
pthread_mutex_lock(&(thd->heap_lock));
h->next_free = h;
h->last_alloc_size = 0;
@ -840,7 +910,7 @@ size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr)
}
}
//h->free_size += heap_freed;
cached_heap_free_sizes[heap_type] += heap_freed;
ck_pr_add_ptr(&(thd->cached_heap_free_sizes[heap_type]), heap_freed);
// Free the heap page if possible.
//
// With huge heaps, this becomes more important. one of the huge
@ -855,13 +925,16 @@ size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr)
// remaining without them.
//
// Experimenting with only freeing huge heaps
if (h->type == HEAP_HUGE && gc_is_heap_empty(h) && !h->newly_created){
if (gc_is_heap_empty(h) &&
(h->type == HEAP_HUGE || !(h->ttl--))) {
unsigned int h_size = h->size;
h = gc_heap_free(h, prev_h);
cached_heap_free_sizes[heap_type] -= h_size;
cached_heap_total_sizes[heap_type] -= h_size;
gc_heap *new_h = gc_heap_free(h, prev_h);
if (new_h) { // Ensure free succeeded
h = new_h;
ck_pr_sub_ptr(&(thd->cached_heap_free_sizes[heap_type] ), h_size);
ck_pr_sub_ptr(&(thd->cached_heap_total_sizes[heap_type]), h_size);
}
}
h->newly_created = 0;
sum_freed += heap_freed;
heap_freed = 0;
}
@ -872,7 +945,7 @@ size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr)
gc_print_stats(orig_heap_ptr);
#endif
pthread_mutex_unlock(&heap_lock);
pthread_mutex_unlock(&(thd->heap_lock));
if (sum_freed_ptr)
*sum_freed_ptr = sum_freed;
return max_freed;
@ -1073,16 +1146,16 @@ void gc_mut_cooperate(gc_thread_data * thd, int buf_len)
// Threshold is intentially low because we have to go through an
// entire handshake/trace/sweep cycle, ideally without growing heap.
if (ck_pr_load_int(&gc_stage) == STAGE_RESTING &&
((cached_heap_free_sizes[HEAP_SM] <
cached_heap_total_sizes[HEAP_SM] * GC_COLLECTION_THRESHOLD) ||
(cached_heap_free_sizes[HEAP_64] <
cached_heap_total_sizes[HEAP_64] * GC_COLLECTION_THRESHOLD) ||
((ck_pr_load_ptr(&(thd->cached_heap_free_sizes[HEAP_SM])) <
ck_pr_load_ptr(&(thd->cached_heap_total_sizes[HEAP_SM])) * GC_COLLECTION_THRESHOLD) ||
(ck_pr_load_ptr(&(thd->cached_heap_free_sizes[HEAP_64])) <
ck_pr_load_ptr(&(thd->cached_heap_total_sizes[HEAP_64])) * GC_COLLECTION_THRESHOLD) ||
#if INTPTR_MAX == INT64_MAX
(cached_heap_free_sizes[HEAP_96] <
cached_heap_total_sizes[HEAP_96] * GC_COLLECTION_THRESHOLD) ||
(ck_pr_load_ptr(&(thd->cached_heap_free_sizes[HEAP_96])) <
ck_pr_load_ptr(&(thd->cached_heap_total_sizes[HEAP_96])) * GC_COLLECTION_THRESHOLD) ||
#endif
(cached_heap_free_sizes[HEAP_REST] <
cached_heap_total_sizes[HEAP_REST] * GC_COLLECTION_THRESHOLD))) {
(ck_pr_load_ptr(&(thd->cached_heap_free_sizes[HEAP_REST])) <
ck_pr_load_ptr(&(thd->cached_heap_total_sizes[HEAP_REST])) * GC_COLLECTION_THRESHOLD))) {
#if GC_DEBUG_TRACE
fprintf(stderr,
"Less than %f%% of the heap is free, initiating collector\n",
@ -1146,71 +1219,26 @@ void gc_mark_gray2(gc_thread_data * thd, object obj)
// they should never be added to the mark stack. Which would be bad because it
// could lead to stack corruption.
//
#if GC_DEBUG_VERBOSE
static void gc_collector_mark_gray(object parent, object obj)
{
if (is_object_type(obj) && mark(obj) == gc_color_clear) {
mark_stack = vpbuffer_add(mark_stack, &mark_stack_len, mark_stack_i++, obj);
fprintf(stderr, "mark gray parent = %p (%d) obj = %p\n", parent,
type_of(parent), obj);
}
}
#else
//
// Attempt to speed this up by forcing an inline
//
#define gc_collector_mark_gray(parent, gobj) \
if (is_object_type(gobj) && mark(gobj) == gc_color_clear) { \
mark_stack = vpbuffer_add(mark_stack, &mark_stack_len, mark_stack_i++, gobj); \
}
#endif
//static void gc_collector_mark_gray(object parent, object obj)
//{
// if (is_object_type(obj) && mark(obj) == gc_color_clear) {
// mark_stack = vpbuffer_add(mark_stack, &mark_stack_len, mark_stack_i++, obj);
//#if GC_DEBUG_VERBOSE
// fprintf(stderr, "mark gray parent = %p (%d) obj = %p\n", parent,
// type_of(parent), obj);
//#endif
// }
//}
// See full version below for debugging purposes.
// Also sync any changes to this macro with the function version
#define gc_mark_black(obj) \
{ \
int markColor = ck_pr_load_int(&gc_color_mark); \
if (is_object_type(obj) && mark(obj) != markColor) { \
switch (type_of(obj)) { \
case pair_tag:{ \
gc_collector_mark_gray(obj, car(obj)); \
gc_collector_mark_gray(obj, cdr(obj)); \
break; \
} \
case closure1_tag: \
gc_collector_mark_gray(obj, ((closure1) obj)->element); \
break; \
case closureN_tag:{ \
int i, n = ((closureN) obj)->num_elements; \
for (i = 0; i < n; i++) { \
gc_collector_mark_gray(obj, ((closureN) obj)->elements[i]); \
} \
break; \
} \
case vector_tag:{ \
int i, n = ((vector) obj)->num_elements; \
for (i = 0; i < n; i++) { \
gc_collector_mark_gray(obj, ((vector) obj)->elements[i]); \
} \
break; \
} \
case cvar_tag:{ \
cvar_type *c = (cvar_type *) obj; \
object pvar = *(c->pvar); \
if (pvar) { \
gc_collector_mark_gray(obj, pvar); \
} \
break; \
} \
default: \
break; \
} \
if (mark(obj) != gc_color_red) { \
mark(obj) = markColor; \
} \
} \
}
/*
#if GC_DEBUG_VERBOSE
void gc_mark_black(object obj)
{
// TODO: is sync required to get colors? probably not on the collector
@ -1259,16 +1287,60 @@ void gc_mark_black(object obj)
// Only blacken objects on the heap
mark(obj) = markColor;
}
#if GC_DEBUG_VERBOSE
if (mark(obj) != gc_color_red) {
fprintf(stderr, "marked %p %d\n", obj, markColor);
} else {
fprintf(stderr, "not marking stack obj %p %d\n", obj, markColor);
}
#endif
}
}
*/
#else
// See full version above for debugging purposes.
// Also sync any changes to this macro with the function version
#define gc_mark_black(obj) \
{ \
int markColor = ck_pr_load_int(&gc_color_mark); \
if (is_object_type(obj) && mark(obj) != markColor) { \
switch (type_of(obj)) { \
case pair_tag:{ \
gc_collector_mark_gray(obj, car(obj)); \
gc_collector_mark_gray(obj, cdr(obj)); \
break; \
} \
case closure1_tag: \
gc_collector_mark_gray(obj, ((closure1) obj)->element); \
break; \
case closureN_tag:{ \
int i, n = ((closureN) obj)->num_elements; \
for (i = 0; i < n; i++) { \
gc_collector_mark_gray(obj, ((closureN) obj)->elements[i]); \
} \
break; \
} \
case vector_tag:{ \
int i, n = ((vector) obj)->num_elements; \
for (i = 0; i < n; i++) { \
gc_collector_mark_gray(obj, ((vector) obj)->elements[i]); \
} \
break; \
} \
case cvar_tag:{ \
cvar_type *c = (cvar_type *) obj; \
object pvar = *(c->pvar); \
if (pvar) { \
gc_collector_mark_gray(obj, pvar); \
} \
break; \
} \
default: \
break; \
} \
if (mark(obj) != gc_color_red) { \
mark(obj) = markColor; \
} \
} \
}
#endif
void gc_collector_trace()
@ -1425,12 +1497,8 @@ void debug_dump_globals();
// Main collector function
void gc_collector()
{
int old_clear, old_mark, heap_type;
size_t freed_tmp = 0, freed = 0;
int old_clear, old_mark;
#if GC_DEBUG_TRACE
size_t total_size;
size_t total_free;
time_t gc_collector_start = time(NULL);
print_allocated_obj_counts();
print_current_time();
fprintf(stderr, " - Starting gc_collector\n");
@ -1476,50 +1544,8 @@ void gc_collector()
ck_pr_cas_int(&gc_stage, STAGE_TRACING, STAGE_SWEEPING);
//
//sweep :
gc_collector_sweep();
for (heap_type = 0; heap_type < NUM_HEAP_TYPES; heap_type++) {
gc_heap *h = gc_get_heap()->heap[heap_type];
if (h) {
gc_sweep(h, heap_type, &freed_tmp);
freed += freed_tmp;
}
}
// TODO: this loop only includes smallest 2 heaps, is that sufficient??
for (heap_type = 0; heap_type < 2; heap_type++) {
while (cached_heap_free_sizes[heap_type] <
(cached_heap_total_sizes[heap_type] * GC_FREE_THRESHOLD)) {
#if GC_DEBUG_TRACE
fprintf(stderr, "Less than %f%% of the heap %d is free, growing it\n",
100.0 * GC_FREE_THRESHOLD, heap_type);
#endif
if (heap_type == HEAP_SM) {
gc_grow_heap(gc_get_heap()->heap[heap_type], heap_type, 0, 0);
} else if (heap_type == HEAP_64) {
gc_grow_heap(gc_get_heap()->heap[heap_type], heap_type, 0, 0);
} else if (heap_type == HEAP_REST) {
gc_grow_heap(gc_get_heap()->heap[heap_type], heap_type, 0, 0);
}
}
}
#if GC_DEBUG_TRACE
total_size = cached_heap_total_sizes[HEAP_SM] +
cached_heap_total_sizes[HEAP_64] +
#if INTPTR_MAX == INT64_MAX
cached_heap_total_sizes[HEAP_96] +
#endif
cached_heap_total_sizes[HEAP_REST];
total_free = cached_heap_free_sizes[HEAP_SM] +
cached_heap_free_sizes[HEAP_64] +
#if INTPTR_MAX == INT64_MAX
cached_heap_free_sizes[HEAP_96] +
#endif
cached_heap_free_sizes[HEAP_REST];
fprintf(stderr,
"sweep done, total_size = %zu, total_free = %zu, freed = %zu, elapsed = %ld\n",
total_size, total_free, freed,
(time(NULL) - gc_collector_start));
#endif
#if GC_DEBUG_TRACE
fprintf(stderr, "cleaning up any old thread data\n");
#endif
@ -1637,10 +1663,25 @@ void gc_thread_data_init(gc_thread_data * thd, int mut_num, char *stack_base,
thd->mark_buffer_len = 128;
thd->mark_buffer =
vpbuffer_realloc(thd->mark_buffer, &(thd->mark_buffer_len));
if (pthread_mutex_init(&(thd->heap_lock), NULL) != 0) {
fprintf(stderr, "Unable to initialize thread mutex\n");
exit(1);
}
if (pthread_mutex_init(&(thd->lock), NULL) != 0) {
fprintf(stderr, "Unable to initialize thread mutex\n");
exit(1);
}
thd->cached_heap_free_sizes = calloc(5, sizeof(uintptr_t));
thd->cached_heap_total_sizes = calloc(5, sizeof(uintptr_t));
thd->heap = calloc(1, sizeof(gc_heap_root));
thd->heap->heap = calloc(1, sizeof(gc_heap *) * NUM_HEAP_TYPES);
thd->heap->heap[HEAP_REST] = gc_heap_create(HEAP_REST, INITIAL_HEAP_SIZE, 0, 0, thd);
thd->heap->heap[HEAP_SM] = gc_heap_create(HEAP_SM, INITIAL_HEAP_SIZE, 0, 0, thd);
thd->heap->heap[HEAP_64] = gc_heap_create(HEAP_64, INITIAL_HEAP_SIZE, 0, 0, thd);
if (sizeof(void *) == 8) { // Only use this heap on 64-bit platforms
thd->heap->heap[HEAP_96] = gc_heap_create(HEAP_96, INITIAL_HEAP_SIZE, 0, 0, thd);
}
thd->heap->heap[HEAP_HUGE] = gc_heap_create(HEAP_HUGE, 1024, 0, 0, thd);
}
void gc_thread_data_free(gc_thread_data * thd)
@ -1653,6 +1694,23 @@ void gc_thread_data_free(gc_thread_data * thd)
fprintf(stderr, "Thread mutex is locked, unable to free\n");
exit(1);
}
if (pthread_mutex_destroy(&thd->heap_lock) != 0) {
fprintf(stderr, "Thread heap mutex is locked, unable to free\n");
exit(1);
}
// Merge heaps for the terminating thread into the main thread's heap.
// Eventually any data that is unused will be freed, but we need to
// keep the heap pages for now because they could still contain live
// objects.
// Lock the primordial thread (hopefully will not cause any deadlocks)
// but don't bother locking thd since it is already done by now.
pthread_mutex_lock(&(primordial_thread->heap_lock));
gc_merge_all_heaps(primordial_thread, thd);
pthread_mutex_unlock(&(primordial_thread->heap_lock));
if (thd->cached_heap_free_sizes)
free(thd->cached_heap_free_sizes);
if (thd->cached_heap_total_sizes)
free(thd->cached_heap_total_sizes);
if (thd->jmp_start)
free(thd->jmp_start);
if (thd->gc_args)
@ -1670,6 +1728,40 @@ void gc_thread_data_free(gc_thread_data * thd)
}
}
/**
* Merge one heap into another. Assumes appropriate locks are already held.
*/
void gc_heap_merge(gc_heap *hdest, gc_heap *hsrc)
{
gc_heap *last = gc_heap_last(hdest);
last->next = hsrc;
}
/**
* Merge all thread heaps into another.
* Assumes appropriate locks are already held.
*/
void gc_merge_all_heaps(gc_thread_data *dest, gc_thread_data *src)
{
gc_heap *hdest, *hsrc;
int heap_type;
for (heap_type = 0; heap_type < NUM_HEAP_TYPES; heap_type++) {
hdest = dest->heap->heap[heap_type];
hsrc = src->heap->heap[heap_type];
if (hdest && hsrc) {
gc_heap_merge(hdest, hsrc);
ck_pr_add_ptr(&(dest->cached_heap_total_sizes[heap_type]),
ck_pr_load_ptr(&(src->cached_heap_total_sizes[heap_type])));
ck_pr_add_ptr(&(dest->cached_heap_free_sizes[heap_type]),
ck_pr_load_ptr(&(src->cached_heap_free_sizes[heap_type])));
}
}
#ifdef GC_DEBUG_TRACE
fprintf(stderr, "Finished merging old heap data\n");
#endif
}
/**
* Called explicitly from a mutator thread to let the collector know
* it (may) block for an unknown period of time.
@ -1679,6 +1771,8 @@ void gc_thread_data_free(gc_thread_data * thd)
*/
void gc_mutator_thread_blocked(gc_thread_data * thd, object cont)
{
thd->gc_cont = cont;
thd->gc_num_args = 0; // Will be set later, after collection
if (!ck_pr_cas_int((int *)&(thd->thread_state),
CYC_THREAD_STATE_RUNNABLE, CYC_THREAD_STATE_BLOCKED)) {
fprintf(stderr,
@ -1686,8 +1780,6 @@ void gc_mutator_thread_blocked(gc_thread_data * thd, object cont)
thd->thread_state);
exit(1);
}
thd->gc_cont = cont;
thd->gc_num_args = 0; // Will be set later, after collection
}
void Cyc_apply_from_buf(void *data, int argc, object prim, object * buf);

1
include/cyclone/runtime.h
View file

@ -179,7 +179,6 @@ object Cyc_set_cell(void *, object l, object val);
object Cyc_set_car(void *, object l, object val);
object Cyc_set_cdr(void *, object l, object val);
object Cyc_length(void *d, object l);
integer_type Cyc_length_as_object(void *d, object l);
object Cyc_vector_length(void *data, object v);
object Cyc_vector_ref(void *d, object v, object k);
object Cyc_vector_set(void *d, object v, object k, object obj);

120
include/cyclone/types.h
View file

@ -17,6 +17,7 @@
#include <string.h>
#include <time.h>
#include <pthread.h>
#include <stdint.h>
// Maximum number of args that GC will accept
#define NUM_GC_ARGS 128
@ -34,7 +35,7 @@
// Parameters for size of a "page" on the heap (the second generation GC), in bytes.
#define GROW_HEAP_BY_SIZE (2 * 1024 * 1024) // Grow first page by adding this amount to it
#define INITIAL_HEAP_SIZE (3 * 1024 * 1024) // Size of the first page
#define HEAP_SIZE (377 * 1024 * 1024) // Normal size of a page
#define HEAP_SIZE (32 * 1024 * 1024) // Normal size of a page
/////////////////////////////
// Major GC tuning parameters
@ -63,7 +64,7 @@
/* Additional runtime checking of the GC system.
This is here because these checks should not be
necessary if GC is working correctly. */
#define GC_SAFETY_CHECKS 1
#define GC_SAFETY_CHECKS 0
// General constants
#define NANOSECONDS_PER_MILLISECOND 1000000
@ -102,53 +103,6 @@ enum object_tag {
// Define the size of object tags
typedef unsigned char tag_type;
/* Threading */
typedef enum { CYC_THREAD_STATE_NEW, CYC_THREAD_STATE_RUNNABLE,
CYC_THREAD_STATE_BLOCKED, CYC_THREAD_STATE_BLOCKED_COOPERATING,
CYC_THREAD_STATE_TERMINATED
} cyc_thread_state_type;
/* Thread data structures */
typedef struct gc_thread_data_t gc_thread_data;
struct gc_thread_data_t {
// Thread object, if applicable
object scm_thread_obj;
cyc_thread_state_type thread_state;
// Data needed to initiate stack-based minor GC
char *stack_start;
char *stack_limit;
// Minor GC write barrier
void **mutations;
int mutation_buflen;
int mutation_count;
// List of objects moved to heap during minor GC
void **moveBuf;
int moveBufLen;
// Need the following to perform longjmp's
//int mutator_num;
jmp_buf *jmp_start;
// After longjmp, pick up execution using continuation/arguments
object gc_cont;
object *gc_args;
short gc_num_args;
// Data needed for heap GC
int gc_alloc_color;
int gc_status;
int last_write;
int last_read;
int pending_writes;
void **mark_buffer;
int mark_buffer_len;
pthread_mutex_t lock;
pthread_t thread_id;
// Data needed for call history
char **stack_traces;
int stack_trace_idx;
char *stack_prev_frame;
// Exception handler stack
object exception_handler_stack;
};
/* GC data structures */
/**
@ -191,7 +145,7 @@ struct gc_heap_t {
unsigned int size;
unsigned int chunk_size; // 0 for any size, other and heap will only alloc chunks of that size
unsigned int max_size;
unsigned int newly_created;
unsigned int ttl; // Keep empty page alive this many times before freeing
//
gc_heap *next_free;
unsigned int last_alloc_size;
@ -229,6 +183,57 @@ typedef enum { STAGE_CLEAR_OR_MARKING, STAGE_TRACING
#define gc_color_red 0 // Memory not to be GC'd, such as on the stack
#define gc_color_blue 2 // Unallocated memory
/* Threading */
typedef enum { CYC_THREAD_STATE_NEW, CYC_THREAD_STATE_RUNNABLE,
CYC_THREAD_STATE_BLOCKED, CYC_THREAD_STATE_BLOCKED_COOPERATING,
CYC_THREAD_STATE_TERMINATED
} cyc_thread_state_type;
/* Thread data structures */
typedef struct gc_thread_data_t gc_thread_data;
struct gc_thread_data_t {
// Thread object, if applicable
object scm_thread_obj;
cyc_thread_state_type thread_state;
// Data needed to initiate stack-based minor GC
char *stack_start;
char *stack_limit;
// Minor GC write barrier
void **mutations;
int mutation_buflen;
int mutation_count;
// List of objects moved to heap during minor GC
void **moveBuf;
int moveBufLen;
// Need the following to perform longjmp's
//int mutator_num;
jmp_buf *jmp_start;
// After longjmp, pick up execution using continuation/arguments
object gc_cont;
object *gc_args;
short gc_num_args;
// Data needed for heap GC
int gc_alloc_color;
int gc_status;
int last_write;
int last_read;
int pending_writes;
void **mark_buffer;
int mark_buffer_len;
pthread_mutex_t lock;
pthread_mutex_t heap_lock;
pthread_t thread_id;
gc_heap_root *heap;
uintptr_t *cached_heap_free_sizes;
uintptr_t *cached_heap_total_sizes;
// Data needed for call history
char **stack_traces;
int stack_trace_idx;
char *stack_prev_frame;
// Exception handler stack
object exception_handler_stack;
};
// Determine if stack has overflowed
#if STACK_GROWTH_IS_DOWNWARD
#define stack_overflow(x,y) ((x) < (y))
@ -350,12 +355,6 @@ typedef struct {
int value;
int padding; // Prevent mem corruption if sizeof(int) < sizeof(ptr)
} integer_type;
#define make_int(n,v) \
integer_type n; \
n.hdr.mark = gc_color_red; \
n.hdr.grayed = 0; \
n.tag = integer_tag; \
n.value = v;
typedef struct {
gc_header_type hdr;
@ -656,10 +655,12 @@ void gc_initialize();
void gc_add_mutator(gc_thread_data * thd);
void gc_remove_mutator(gc_thread_data * thd);
gc_heap *gc_heap_create(int heap_type, size_t size, size_t max_size,
size_t chunk_size);
size_t chunk_size, gc_thread_data *thd);
gc_heap *gc_heap_free(gc_heap *page, gc_heap *prev_page);
void gc_heap_merge(gc_heap *hdest, gc_heap *hsrc);
void gc_merge_all_heaps(gc_thread_data *dest, gc_thread_data *src);
void gc_print_stats(gc_heap * h);
int gc_grow_heap(gc_heap * h, int heap_type, size_t size, size_t chunk_size);
int gc_grow_heap(gc_heap * h, int heap_type, size_t size, size_t chunk_size, gc_thread_data *thd);
char *gc_copy_obj(object hp, char *obj, gc_thread_data * thd);
void *gc_try_alloc(gc_heap * h, int heap_type, size_t size, char *obj,
gc_thread_data * thd);
@ -673,7 +674,7 @@ size_t gc_heap_total_size(gc_heap * h);
//void gc_mark(gc_heap *h, object obj);
void gc_request_mark_globals(void);
void gc_mark_globals(object globals, object global_table);
size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr);
size_t gc_sweep(gc_heap * h, int heap_type, size_t * sum_freed_ptr, gc_thread_data *thd);
void gc_thr_grow_move_buffer(gc_thread_data * d);
void gc_thr_add_to_move_buffer(gc_thread_data * d, int *alloci, object obj);
void gc_thread_data_init(gc_thread_data * thd, int mut_num, char *stack_base,
@ -703,7 +704,6 @@ void gc_mutator_thread_runnable(gc_thread_data * thd, object result);
// body \
// return_thread_runnable((data), (result));
*/
gc_heap_root *gc_get_heap();
int gc_minor(void *data, object low_limit, object high_limit, closure cont,
object * args, int num_args);
/* Mutation table to support minor GC write barrier */

108
runtime.c
View file

@ -140,7 +140,6 @@ if (type_is_pair_prim(clo)) { \
/*END closcall section */
/* Global variables. */
static gc_heap_root *Cyc_heap;
object Cyc_global_variables = NULL;
int _cyc_argc = 0;
char **_cyc_argv = NULL;
@ -261,17 +260,6 @@ static bool set_insert(ck_hs_t * hs, const void *value)
void gc_init_heap(long heap_size)
{
size_t initial_heap_size = INITIAL_HEAP_SIZE;
Cyc_heap = calloc(1, sizeof(gc_heap_root));
Cyc_heap->heap = calloc(1, sizeof(gc_heap *) * NUM_HEAP_TYPES);
Cyc_heap->heap[HEAP_REST] = gc_heap_create(HEAP_REST, initial_heap_size, 0, 0);
Cyc_heap->heap[HEAP_SM] = gc_heap_create(HEAP_SM, initial_heap_size, 0, 0);
Cyc_heap->heap[HEAP_64] = gc_heap_create(HEAP_64, initial_heap_size, 0, 0);
if (sizeof(void *) == 8) { // Only use this heap on 64-bit platforms
Cyc_heap->heap[HEAP_96] = gc_heap_create(HEAP_96, initial_heap_size, 0, 0);
}
Cyc_heap->heap[HEAP_HUGE] = gc_heap_create(HEAP_HUGE, 1024, 0, 0);
if (!ck_hs_init(&symbol_table,
CK_HS_MODE_OBJECT | CK_HS_MODE_SPMC,
hs_hash, hs_compare,
@ -285,11 +273,6 @@ void gc_init_heap(long heap_size)
}
}
gc_heap_root *gc_get_heap()
{
return Cyc_heap;
}
object cell_get(object cell)
{
// FUTURE: always use unsafe car here, since computed by compiler
@ -1071,7 +1054,7 @@ object Cyc_heap_alloc_port(void *data, port_type *stack_p)
{
object p = NULL;
int heap_grown;
p = gc_alloc(Cyc_heap,
p = gc_alloc(((gc_thread_data *)data)->heap,
sizeof(port_type),
(char *)stack_p,
(gc_thread_data *)data,
@ -1385,8 +1368,8 @@ object Cyc_is_procedure(void *data, object o)
tag == closure1_tag || tag == closureN_tag || tag == primitive_tag) {
return boolean_t;
} else if (tag == pair_tag) {
integer_type l = Cyc_length_as_object(data, o);
if (l.value > 0 && Cyc_is_symbol(car(o)) == boolean_t) {
int i = obj_obj2int(Cyc_length(data, o));
if (i > 0 && Cyc_is_symbol(car(o)) == boolean_t) {
if (strncmp(((symbol) car(o))->desc, "primitive", 10) == 0 ||
strncmp(((symbol) car(o))->desc, "procedure", 10) == 0) {
return boolean_t;
@ -1498,19 +1481,6 @@ object Cyc_vector_ref(void *data, object v, object k)
return ((vector) v)->elements[idx];
}
integer_type Cyc_length_as_object(void *data, object l)
{
make_int(len, 0);
while ((l != NULL)) {
if (is_value_type(l) || ((list) l)->tag != pair_tag) {
Cyc_rt_raise2(data, "length - invalid parameter, expected list", l);
}
l = cdr(l);
len.value++;
}
return len;
}
object Cyc_vector_length(void *data, object v)
{
if ((v != NULL) && !is_value_type(v) && ((list) v)->tag == vector_tag) {
@ -2019,7 +1989,7 @@ object Cyc_make_vector(void *data, object cont, int argc, object len, ...)
// TODO: mark this thread as potentially blocking before doing
// the allocation????
int heap_grown;
v = gc_alloc(Cyc_heap,
v = gc_alloc(((gc_thread_data *)data)->heap,
sizeof(vector_type) + element_vec_size,
boolean_f, // OK to populate manually over here
(gc_thread_data *)data,
@ -2065,7 +2035,7 @@ object Cyc_make_bytevector(void *data, object cont, int argc, object len, ...)
if (length >= MAX_STACK_OBJ) {
int heap_grown;
bv = gc_alloc(Cyc_heap,
bv = gc_alloc(((gc_thread_data *)data)->heap,
sizeof(bytevector_type) + length,
boolean_f, // OK to populate manually over here
(gc_thread_data *)data,
@ -3267,30 +3237,30 @@ void _Cyc_91end_91thread_67(void *data, object cont, object args)
void __87(void *data, object cont, object args)
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_sum, cont, cont, args);
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_sum, cont, cont, args);
}
void __91(void *data, object cont, object args)
{
Cyc_check_num_args(data, "-", 1, args);
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_sub, cont, cont, args);
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_sub, cont, cont, args);
}}
void __85(void *data, object cont, object args)
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_mul, cont, cont, args);
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_mul, cont, cont, args);
}
void __95(void *data, object cont, object args)
{
Cyc_check_num_args(data, "/", 1, args);
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_div, cont, cont, args);
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_div, cont, cont, args);
}}
void _Cyc_91cvar_127(void *data, object cont, object args)
@ -3449,33 +3419,33 @@ void _cell(void *data, object cont, object args)
void __123(void *data, object cont, object args)
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_num_eq, cont, cont, args);
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_num_eq, cont, cont, args);
}
void __125(void *data, object cont, object args)
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_num_gt, cont, cont, args);
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_num_gt, cont, cont, args);
}
void __121(void *data, object cont, object args)
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_num_lt, cont, cont, args);
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_num_lt, cont, cont, args);
}
void __125_123(void *data, object cont, object args)
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_num_gte, cont, cont,
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_num_gte, cont, cont,
args);
}
void __121_123(void *data, object cont, object args)
{
integer_type argc = Cyc_length_as_object(data, args);
dispatch(data, argc.value, (function_type) dispatch_num_lte, cont, cont,
int argc = obj_obj2int(Cyc_length(data, args));
dispatch(data, argc, (function_type) dispatch_num_lte, cont, cont,
args);
}
@ -3598,9 +3568,6 @@ void _cyc_system(void *data, object cont, object args)
return_closcall1(data, cont, obj);
}}
//void _error(void *data, object cont, object args) {
// integer_type argc = Cyc_length_as_object(args);
// dispatch_va(data, argc.value, dispatch_error, cont, cont, args); }
void _Cyc_91current_91exception_91handler(void *data, object cont, object args)
{
object handler = Cyc_current_exception_handler(data);
@ -4054,30 +4021,31 @@ char *gc_fixup_moved_obj(gc_thread_data * thd, int *alloci, char *obj,
char *gc_move(char *obj, gc_thread_data * thd, int *alloci, int *heap_grown)
{
gc_heap_root *heap = thd->heap;
if (!is_object_type(obj))
return obj;
switch (type_of(obj)) {
case pair_tag:{
list hp = gc_alloc(Cyc_heap, sizeof(pair_type), obj, thd, heap_grown);
list hp = gc_alloc(heap, sizeof(pair_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case macro_tag:{
macro_type *hp =
gc_alloc(Cyc_heap, sizeof(macro_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(macro_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case closure0_tag:{
closure0_type *hp =
gc_alloc(Cyc_heap, sizeof(closure0_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(closure0_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case closure1_tag:{
closure1_type *hp =
gc_alloc(Cyc_heap, sizeof(closure1_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(closure1_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case closureN_tag:{
closureN_type *hp = gc_alloc(Cyc_heap,
closureN_type *hp = gc_alloc(heap,
sizeof(closureN_type) +
sizeof(object) *
(((closureN) obj)->num_elements),
@ -4085,7 +4053,7 @@ char *gc_move(char *obj, gc_thread_data * thd, int *alloci, int *heap_grown)
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case vector_tag:{
vector_type *hp = gc_alloc(Cyc_heap,
vector_type *hp = gc_alloc(heap,
sizeof(vector_type) +
sizeof(object) *
(((vector) obj)->num_elements),
@ -4093,41 +4061,41 @@ char *gc_move(char *obj, gc_thread_data * thd, int *alloci, int *heap_grown)
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case bytevector_tag:{
bytevector_type *hp = gc_alloc(Cyc_heap,
bytevector_type *hp = gc_alloc(heap,
sizeof(bytevector_type) +
sizeof(char) * (((bytevector) obj)->len),
obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case string_tag:{
string_type *hp = gc_alloc(Cyc_heap,
string_type *hp = gc_alloc(heap,
sizeof(string_type) + ((string_len(obj) + 1)),
obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case integer_tag:{
integer_type *hp =
gc_alloc(Cyc_heap, sizeof(integer_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(integer_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case double_tag:{
double_type *hp =
gc_alloc(Cyc_heap, sizeof(double_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(double_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case port_tag:{
port_type *hp =
gc_alloc(Cyc_heap, sizeof(port_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(port_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case cvar_tag:{
cvar_type *hp =
gc_alloc(Cyc_heap, sizeof(cvar_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(cvar_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case c_opaque_tag:{
c_opaque_type *hp =
gc_alloc(Cyc_heap, sizeof(c_opaque_type), obj, thd, heap_grown);
gc_alloc(heap, sizeof(c_opaque_type), obj, thd, heap_grown);
return gc_fixup_moved_obj(thd, alloci, obj, hp);
}
case forward_tag:
@ -4847,7 +4815,7 @@ object copy2heap(void *data, object obj)
return obj;
}
return gc_alloc(Cyc_heap, gc_allocated_bytes(obj, NULL, NULL), obj, data,
return gc_alloc(((gc_thread_data *)data)->heap, gc_allocated_bytes(obj, NULL, NULL), obj, data,
&on_stack);
}

4
srfi/18.sld
View file

@ -161,7 +161,7 @@
tmp.hdr.mark = gc_color_red;
tmp.hdr.grayed = 0;
tmp.tag = mutex_tag;
lock = gc_alloc(gc_get_heap(), sizeof(mutex_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
lock = gc_alloc(((gc_thread_data *)data)->heap, sizeof(mutex_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
if (pthread_mutex_init(&(lock->lock), NULL) != 0) {
fprintf(stderr, \"Unable to make mutex\\n\");
exit(1);
@ -214,7 +214,7 @@
tmp.hdr.mark = gc_color_red;
tmp.hdr.grayed = 0;
tmp.tag = cond_var_tag;
cond = gc_alloc(gc_get_heap(), sizeof(cond_var_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
cond = gc_alloc(((gc_thread_data *)data)->heap, sizeof(cond_var_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
if (pthread_cond_init(&(cond->cond), NULL) != 0) {
fprintf(stderr, \"Unable to make condition variable\\n\");
exit(1);