コード例 #1
0
void Scm_ProfilerCountBufferFlush(ScmVM *vm)
{
    if (vm->prof == NULL) return; /* for safety */
    if (vm->prof->currentCount == 0) return;

    /* suspend itimer during hash table operation */
#if !defined(GAUCHE_WINDOWS)
    sigset_t set;
    sigemptyset(&set);
    sigaddset(&set, SIGPROF);
    SIGPROCMASK(SIG_BLOCK, &set, NULL);
#endif /* !GAUCHE_WINDOWS */

    int ncounts = vm->prof->currentCount;
    for (int i=0; i<ncounts; i++) {
        ScmObj e;
        int cnt;

        ScmObj func = vm->prof->counts[i].func;
        if (SCM_METHODP(func) && SCM_METHOD(func)->func == NULL) {
            /* func is Scheme-defined method.  Record the code of
               method body, so that we can match it with sampling
               profiler later. */
            func = SCM_OBJ(SCM_METHOD(func)->data);
        }

        e = Scm_HashTableSet(vm->prof->statHash,
                             vm->prof->counts[i].func,
                             SCM_FALSE,
                             SCM_DICT_NO_OVERWRITE);
        if (SCM_FALSEP(e)) {
            e = Scm_HashTableSet(vm->prof->statHash,
                                 vm->prof->counts[i].func,
                                 Scm_Cons(SCM_MAKE_INT(0), SCM_MAKE_INT(0)),
                                 0);
        }

        SCM_ASSERT(SCM_PAIRP(e));
        cnt = SCM_INT_VALUE(SCM_CAR(e)) + 1;
        SCM_SET_CAR(e, SCM_MAKE_INT(cnt));
    }
    vm->prof->currentCount = 0;

    /* resume itimer */
#if !defined(GAUCHE_WINDOWS)
    SIGPROCMASK(SIG_UNBLOCK, &set, NULL);
#endif /* !GAUCHE_WINDOWS */
}
コード例 #2
0
ファイル: gauche-glut.c プロジェクト: tanaka11-181/Gauche-gl
/*
 * External entry to manage registering callbacks
 * 'xtra1' and 'xtra2' are ignored by most callbacks; only the two callbacks
 * use them:
 *   glutTimerFunc: xtra1 for millliseconds, xtra2 for value
 *   glutJoystickFunc: xtra1 for interval
 */
void Scm_GlutRegisterCallback(int type, ScmObj closure, int xtra1, int xtra2)
{
    SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_CBS);
    if (type < SCM_GLUT_NUM_WINDOW_CBS) {
        int win = glutGetWindow();
        ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable),
                                        SCM_MAKE_INT(win), SCM_FALSE);
        
        if (SCM_EQ(entry, SCM_FALSE)) {
            entry = Scm_MakeVector(SCM_GLUT_NUM_WINDOW_CBS, SCM_FALSE);
            Scm_HashTableSet(SCM_HASH_TABLE(ScmGlutCallbackTable),
                             SCM_MAKE_INT(win), entry, 0);
        }
        SCM_VECTOR_ELEMENT(entry, type) = closure;
        registrars[type](!SCM_FALSEP(closure), xtra1);
    } else if (type == SCM_GLUT_CB_IDLE) {
        idle_closure = closure;
        if (SCM_FALSEP(closure)) {
            glutIdleFunc(NULL);
        } else {
            glutIdleFunc(idle_cb);
        }
    } else {
        timer_closure = closure;
        if (!SCM_FALSEP(closure)) {
            glutTimerFunc(xtra1, timer_cb, xtra2);
        }
    }
}
コード例 #3
0
ファイル: symbol.c プロジェクト: Z-Shang/Gauche
/* internal constructor.  NAME must be an immutable string. */
static ScmSymbol *make_sym(ScmClass *klass, ScmString *name, int interned)
{
    if (interned) {
        /* fast path */
        SCM_INTERNAL_MUTEX_LOCK(obtable_mutex);
        ScmObj e = Scm_HashTableRef(obtable, SCM_OBJ(name), SCM_FALSE);
        SCM_INTERNAL_MUTEX_UNLOCK(obtable_mutex);
        if (!SCM_FALSEP(e)) return SCM_SYMBOL(e);
    }

    ScmSymbol *sym = SCM_NEW(ScmSymbol);
    SCM_SET_CLASS(sym, klass);
    sym->name = name;
    sym->flags = interned? SCM_SYMBOL_FLAG_INTERNED : 0;

    if (!interned) {
        return sym;
    } else {
        /* Using SCM_DICT_NO_OVERWRITE ensures that if another thread interns
           the same name symbol between above HashTableRef and here, we'll
           get the already interned symbol. */
        SCM_INTERNAL_MUTEX_LOCK(obtable_mutex);
        ScmObj e = Scm_HashTableSet(obtable, SCM_OBJ(name), SCM_OBJ(sym),
                                    SCM_DICT_NO_OVERWRITE);
        SCM_INTERNAL_MUTEX_UNLOCK(obtable_mutex);
        return SCM_SYMBOL(e);
    }
}
コード例 #4
0
ファイル: symbol.c プロジェクト: Z-Shang/Gauche
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
#if GAUCHE_UNIFY_SYMBOL_KEYWORD
    /* We could optimize this later. */
    ScmObj prefix = Scm_MakeString(":", 1, 1, SCM_STRING_IMMUTABLE);
    ScmObj sname = Scm_StringAppend2(SCM_STRING(prefix), name);
    ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
    Scm_DefineConst(Scm_KeywordModule(), s, SCM_OBJ(s));
    return SCM_OBJ(s);
#else  /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
    (void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
    ScmObj r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
    (void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);

    if (SCM_KEYWORDP(r)) return r;

    ScmKeyword *k = SCM_NEW(ScmKeyword);
    SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
    k->name = SCM_STRING(Scm_CopyString(name));
    (void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
    r = Scm_HashTableSet(keywords.table, SCM_OBJ(name), SCM_OBJ(k),
                         SCM_DICT_NO_OVERWRITE);
    (void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
    return r;
#endif /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
}
コード例 #5
0
ファイル: symbol.c プロジェクト: qykth-git/Gauche
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
#if GAUCHE_KEEP_DISJOINT_KEYWORD_OPTION
    if (keyword_disjoint_p) {
        (void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
        ScmObj r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
        (void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);

        if (SCM_KEYWORDP(r)) return r;

        ScmKeyword *k = SCM_NEW(ScmKeyword);
        SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
        k->name = SCM_STRING(Scm_CopyString(name));
        (void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
        r = Scm_HashTableSet(keywords.table, SCM_OBJ(name), SCM_OBJ(k),
                             SCM_DICT_NO_OVERWRITE);
        (void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
        return r;
    }
#endif /*GAUCHE_KEEP_DISJOINT_KEYWORD_OPTION*/
    ScmObj sname = Scm_StringAppend2(&keyword_prefix, name);
    ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
    Scm_DefineConst(Scm__GaucheKeywordModule(), s, SCM_OBJ(s));
    return SCM_OBJ(s);
}
コード例 #6
0
ファイル: keyword.c プロジェクト: aharisu/Gauche
/* Returns a keyword whose name is NAME.  Note that preceding ':' is not
 * a part of the keyword name.
 */
ScmObj Scm_MakeKeyword(ScmString *name)
{
    ScmObj r;
    ScmKeyword *k;

    (void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
    r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
    (void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);

    if (SCM_KEYWORDP(r)) return r;

    k = SCM_NEW(ScmKeyword);
    SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
    k->name = SCM_STRING(Scm_CopyString(name));
    (void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
    r = Scm_HashTableSet(keywords.table, SCM_OBJ(name), SCM_OBJ(k),
                         SCM_DICT_NO_OVERWRITE);
    (void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
    return r;
}
コード例 #7
0
ファイル: write.c プロジェクト: h2oota/Gauche
/* Trick: The hashtable contains positive integer after the walk pass.
   If we emit a reference tag N, we replace the entry's value to -N,
   so that we can distinguish whether we've already emitted the object
   or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
    char numbuf[50];  /* enough to contain long number */
    ScmObj stack = SCM_NIL;
    ScmWriteState *st = port->writeState;
    ScmHashTable *ht = (st? st->sharedTable : NULL);
    int stack_depth = 0;

#define PUSH(elt)                                       \
    do {                                                \
        stack = Scm_Cons(elt, stack);                   \
        if (!ht && ++stack_depth > STACK_LIMIT) {       \
            Scm_Error("write recursed too deeply; "     \
                      "maybe a circular structure?");   \
        }                                               \
    } while (0)
#define POP()                                   \
    do {                                        \
        stack = SCM_CDR(stack);                 \
        if (ht) stack_depth--;                  \
    } while (0)

    for (;;) {
    write1:
        if (ctx->flags & WRITE_LIMITED) {
            if (port->src.ostr.length >= ctx->limit) return;
        }

        /* number may be heap allocated, but we don't use srfi-38 notation. */
        if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
            if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
                Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
            }
            goto next;
        }
        if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
            || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
            /* we don't put a reference tag for these */
            write_general(obj, port, ctx);
            goto next;
        }

        if (ht) {
            ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
            long k = SCM_INT_VALUE(e);
            if (k <= 0) {
                /* This object is already printed. */
                snprintf(numbuf, 50, "#%ld#", -k);
                Scm_PutzUnsafe(numbuf, -1, port);
                goto next;
            } else if (k > 1) {
                /* This object will be seen again. Put a reference tag. */
                ScmWriteState *s = port->writeState;
                snprintf(numbuf, 50, "#%d=", s->sharedCounter);
                Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
                s->sharedCounter++;
                Scm_PutzUnsafe(numbuf, -1, port);
            }
        }

        /* Writes aggregates */
        if (SCM_PAIRP(obj)) {
            /* special case for quote etc.
               NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
               get infinite recursion for the case like (cdr '#1='#1#). */
            if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
                && (!ht
                    || SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
                const char *prefix = NULL;
                if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
                    prefix = "'";
                } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
                    prefix = "`";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
                    prefix = ",";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
                    prefix = ",@";
                }
                if (prefix) {
                    Scm_PutzUnsafe(prefix, -1, port);
                    obj = SCM_CADR(obj);
                    goto write1;
                }
            }

            /* normal case */
            Scm_PutcUnsafe('(', port);
            PUSH(Scm_Cons(SCM_TRUE, SCM_CDR(obj)));
            obj = SCM_CAR(obj);
            goto write1;
        } else if (SCM_VECTORP(obj)) {
            Scm_PutzUnsafe("#(", -1, port);
            PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
            obj = SCM_VECTOR_ELEMENT(obj, 0);
            goto write1;
        } else {
            /* string or user-defined object */
            write_general(obj, port, ctx);
            goto next;
        }

    next:
        while (SCM_PAIRP(stack)) {
            ScmObj top = SCM_CAR(stack);
            SCM_ASSERT(SCM_PAIRP(top));
            if (SCM_INTP(SCM_CAR(top))) {
                /* we're processing a vector */
                ScmObj v = SCM_CDR(top);
                int i = SCM_INT_VALUE(SCM_CAR(top));
                int len = SCM_VECTOR_SIZE(v);

                if (i == len) { /* we've done this vector */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_VECTOR_ELEMENT(v, i);
                    SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
                    goto write1;
                }
            } else {
                /* we're processing a list */
                ScmObj v = SCM_CDR(top);
                if (SCM_NULLP(v)) { /* we've done with this list */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else if (!SCM_PAIRP(v)) {
                    Scm_PutzUnsafe(" . ", -1, port);
                    obj = v;
                    SCM_SET_CDR(top, SCM_NIL);
                    goto write1;
                } else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1)))  {
                    /* cdr part is shared */
                    Scm_PutzUnsafe(" . ", -1, port);
                    obj = v;
                    SCM_SET_CDR(top, SCM_NIL);
                    goto write1;
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_CAR(v);
                    SCM_SET_CDR(top, SCM_CDR(v));
                    goto write1;
                }
            }
        }
        break;
    }

#undef PUSH
#undef POP
}
コード例 #8
0
ファイル: write.c プロジェクト: icicle99/Gauche
/* Trick: The hashtable contains positive integer after the walk pass.
   If we emit a reference tag N, we replace the entry's value to -N,
   so that we can distinguish whether we've already emitted the object
   or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
    char numbuf[50];  /* enough to contain long number */
    ScmObj stack = SCM_NIL;
    ScmWriteState *st = port->writeState;
    ScmHashTable *ht = (st? st->sharedTable : NULL);
    const ScmWriteControls *wp = Scm_GetWriteControls(ctx, st);
    int stack_depth = 0;        /* only used when !ht */

#define PUSH(elt)                                       \
    do {                                                \
        stack = Scm_Cons(elt, stack);                   \
        if (!ht && ++stack_depth > STACK_LIMIT) {       \
            Scm_Error("write recursed too deeply; "     \
                      "maybe a circular structure?");   \
        }                                               \
    } while (0)
#define POP()                                   \
    do {                                        \
        stack = SCM_CDR(stack);                 \
        if (!ht) stack_depth--;                 \
    } while (0)
#define CHECK_LEVEL()                                                   \
    do {                                                                \
        if (st) {                                                       \
            if (wp->printLevel >= 0 && st->currentLevel >= wp->printLevel) { \
                Scm_PutcUnsafe('#', port);                              \
                goto next;                                              \
            } else {                                                    \
                if (st) st->currentLevel++;                             \
            }                                                           \
        }                                                               \
    } while (0)
    

    for (;;) {
    write1:
        if (ctx->flags & WRITE_LIMITED) {
            if (port->src.ostr.length >= ctx->limit) return;
        }

        /* number may be heap allocated, but we don't use srfi-38 notation. */
        if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
            if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
                Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
            }
            goto next;
        }
        if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
            || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
            /* we don't put a reference tag for these */
            write_general(obj, port, ctx);
            goto next;
        }

        /* obj is heap allocated and we may use label notation. */
        if (ht) {
            ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
            long k = SCM_INT_VALUE(e);
            if (k <= 0) {
                /* This object is already printed. */
                snprintf(numbuf, 50, "#%ld#", -k);
                Scm_PutzUnsafe(numbuf, -1, port);
                goto next;
            } else if (k > 1) {
                /* This object will be seen again. Put a reference tag. */
                ScmWriteState *s = port->writeState;
                snprintf(numbuf, 50, "#%d=", s->sharedCounter);
                Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
                s->sharedCounter++;
                Scm_PutzUnsafe(numbuf, -1, port);
            }
        }

        /* Writes aggregates */
        if (SCM_PAIRP(obj)) {

            CHECK_LEVEL();

            /* special case for quote etc.
               NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
               get infinite recursion for the case like (cdr '#1='#1#). */
            if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
                && (!ht
                    || SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
                const char *prefix = NULL;
                if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
                    prefix = "'";
                } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
                    prefix = "`";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
                    prefix = ",";
                } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
                    prefix = ",@";
                }
                if (prefix) {
                    Scm_PutzUnsafe(prefix, -1, port);
                    obj = SCM_CADR(obj);
                    goto write1;
                }
            }

            if (wp->printLength == 0) {
                /* in this case we don't print the elements at all, so we need
                   to treat this specially. */
                Scm_PutzUnsafe("(...)", -1, port);
                if (st) st->currentLevel--;
                goto next;
            }

            /* normal case */
            Scm_PutcUnsafe('(', port);
            PUSH(Scm_Cons(SCM_TRUE, Scm_Cons(SCM_MAKE_INT(1), SCM_CDR(obj))));
            obj = SCM_CAR(obj);
            goto write1;
        } else if (SCM_VECTORP(obj)) {

            CHECK_LEVEL();

            if (wp->printLength == 0) {
                /* in this case we don't print the elements at all, so we need
                   to treat this specially. */
                Scm_PutzUnsafe("#(...)", -1, port);
                if (st) st->currentLevel--;
                goto next;
            }
            Scm_PutzUnsafe("#(", -1, port);
            PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
            obj = SCM_VECTOR_ELEMENT(obj, 0);
            goto write1;
        } else if (Scm_ClassOf(obj)->flags & SCM_CLASS_AGGREGATE) {
            CHECK_LEVEL();
            write_general(obj, port, ctx);
            if (st) st->currentLevel--;
            goto next;
        } else {
            write_general(obj, port, ctx);
            goto next;
        }

    next:
        while (SCM_PAIRP(stack)) {
            ScmObj top = SCM_CAR(stack);
            SCM_ASSERT(SCM_PAIRP(top));
            if (SCM_INTP(SCM_CAR(top))) {
                /* we're processing a vector */
                ScmObj v = SCM_CDR(top);
                int i = SCM_INT_VALUE(SCM_CAR(top));
                int len = SCM_VECTOR_SIZE(v);

                if (i == len) { /* we've done this vector */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else if (wp->printLength >= 0 && wp->printLength <= i) {
                    Scm_PutzUnsafe(" ...)", -1, port);
                    POP();
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_VECTOR_ELEMENT(v, i);
                    SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
                    goto write1;
                }
            } else {
                /* we're processing a list */
                SCM_ASSERT(SCM_PAIRP(SCM_CDR(top)));
                long count = SCM_INT_VALUE(SCM_CADR(top));
                ScmObj v = SCM_CDDR(top);
                if (SCM_NULLP(v)) { /* we've done with this list */
                    Scm_PutcUnsafe(')', port);
                    POP();
                } else if (!SCM_PAIRP(v)) {
                    /* Improper list.  We treat aggregate types specially,
                       since such object at this position shouldn't increment
                       "level" - its content is regarded as the same level of
                       the current list.
                     */
                    Scm_PutzUnsafe(" . ", -1, port);
                    if (Scm_ClassOf(v)->flags & SCM_CLASS_AGGREGATE) {
                        if (st) st->currentLevel--;
                        write_rec(v, port, ctx);
                        if (st) st->currentLevel++;
                        Scm_PutcUnsafe(')', port);
                        POP();
                    } else {
                        obj = v;
                        SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
                        SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
                        goto write1;
                    }
                } else if (wp->printLength >= 0 && wp->printLength <= count) {
                    /* print-length limit reached */
                    Scm_PutzUnsafe(" ...)", -1, port);
                    POP();
                } else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1)))  {
                    /* cdr part is shared */
                    Scm_PutzUnsafe(" . ", -1, port);
                    obj = v;
                    SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
                    SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
                    goto write1;
                } else {
                    Scm_PutcUnsafe(' ', port);
                    obj = SCM_CAR(v);
                    SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
                    SCM_SET_CDR(SCM_CDR(top), SCM_CDR(v));
                    goto write1;
                }
            }
            if (st) st->currentLevel--;
        }
        break;
    }

#undef PUSH
#undef POP
#undef CHECK_DEPTH
}