cyclone-bug.scm

(import (scheme base)
        (only (scheme write) display)
        (only (srfi 18) make-thread thread-start! thread-join!))

;; Helpers
(define-syntax for
  (syntax-rules ()
    ((_ (i start end) body ...)
     (do ((i start (+ i 1)))
       ((= i end))
       body ...))))

(define (println . args)
  (for-each display args)
  (newline))

(define num-iterations 10)
(define num-threads 2)

(define threads (make-vector num-threads #f))
(define mappings (make-vector num-threads #f))

(define (race-thread i)
  (make-thread
    (lambda ()
      (define mapping (make-vector num-iterations))
      (for (n 0 num-iterations)
        (define sym (string->symbol (string-append "sym" (number->string n))))
        (vector-set! mapping n sym))
      (vector-set! mappings i mapping))))

;; Run each thread
(for (i 0 num-threads)
  (vector-set! threads i (race-thread i)))

(for (i 0 num-threads)
  (thread-start! (vector-ref threads i)))

(for (i 0 num-threads)
  (thread-join! (vector-ref threads i)))

;; Check for the race condition firing
(define a #f)
(define b #f)

(call/cc
  (lambda (return)
    (for (i 0 num-iterations)
      (define syms (make-vector num-threads #f))
      (for (j 0 num-threads)
           (vector-set! syms j (vector-ref (vector-ref mappings j) i)))
      (when (not (apply eq? (vector->list syms)))
        (set! a (vector-ref syms 0))
        (set! b (vector-ref syms 1))
        (return)))
    (display "Race condition did not occur, try again")
    (exit 1)))

;; The big reveal
(println "(symbol? " a ") == " (symbol? a))
(println "(symbol? " b ") == " (symbol? b))
(println "(string=? (symbol->string " a ") (symbol->string " b ")) == " (string=? (symbol->string a) (symbol->string b)))
(println "(eq? " a " " b ") == " (eq? a b))
(println "(eqv? " a " " b ") == " (eqv? a b))

example-output.txt

(symbol? sym0) == #t
(symbol? sym0) == #t
(string=? (symbol->string sym0) (symbol->string sym0)) == #t
(eq? sym0 sym0) == #f
(eqv? sym0 sym0) == #f

possible-fix.c

/* Here is an excerpt from the Scheme implementation I'm writing now.
 * It passes the above test (when ported to C)
 */

static ck_hs_t symbol_table;
static pthread_mutex_t symbol_table_lock;

static unsigned long sym_hash(const void *, unsigned long);
static bool sym_eq(const void *, const void *);

vm_object *vm_symbol_create(const char *name, int len)
{
    vm_symbol tmp, *sym;
    char *copy;
    unsigned long h;
    bool inserted;
    bool attempted = false;

retry:
    /* Create a stack-allocated symbol for lookup */
    tmp.header.tag = VM_OBJECT_TAG_SYMBOL;
    tmp.desc = name;
    tmp.len = len;
    h = CK_HS_HASH(&symbol_table, sym_hash, &tmp);

    sym = ck_hs_get(&symbol_table, h, &tmp);
    if (sym) {
        return (vm_object *)sym;
    }

    /* This means we found a symbol that matches, then couldn't find it the second time. */
    if (attempted) {
        fprintf(stderr, "Symbol table is in invalid state: this shouldn't happen\n");
        abort();
    }

    /* Turn the temp symbol into a heap-allocated one, moving to sym */
    copy = malloc(len + 1);
    memcpy(copy, name, len);
    copy[len] = '\0';
    tmp.desc = copy;

    sym = malloc(sizeof(vm_symbol));
    memcpy(sym, &tmp, sizeof(vm_symbol));

    /* Insert the symbol. We need the writer lock since only one thread can write. */
    pthread_mutex_lock(&symbol_table_lock);
    {
        inserted = ck_hs_put(&symbol_table, h, sym);
    }
    pthread_mutex_unlock(&symbol_table_lock);

    if (!inserted) {
        /* Another thread must have created the symbol
         * between the first lookup and grabbing the lock.
         * Retry (lookup should succeed now) */
        free(copy);
        free(sym);
        attempted = true;
        goto retry;
    }
    return (vm_object *)sym;
}