ScmObj Scm_Force(ScmObj obj)
{
if (!SCM_PROMISEP(obj)) {
SCM_RETURN(obj);
} else {
ScmPromiseContent *c = SCM_PROMISE(obj)->content;
if (c->forced) SCM_RETURN(c->code);
else {
ScmVM *vm = Scm_VM();
void *data[2];
data[0] = obj;
data[1] = vm->handlers;
if (c->owner == vm) {
/* we already have the lock and evaluating this promise. */
c->count++;
Scm_VMPushCC(force_cc, data, 2);
SCM_RETURN(Scm_VMApply0(c->code));
} else {
/* TODO: check if the executing thread terminates
prematurely */
SCM_INTERNAL_MUTEX_LOCK(c->mutex);
if (c->forced) {
SCM_INTERNAL_MUTEX_UNLOCK(c->mutex);
SCM_RETURN(c->code);
}
SCM_ASSERT(c->owner == NULL);
c->owner = vm;
install_release_thunk(vm, obj);
c->count++;
/* mutex is unlocked by force_cc. */
Scm_VMPushCC(force_cc, data, 2);
SCM_RETURN(Scm_VMApply0(c->code));
}
}
}
}
/* Returns the statHash */
ScmObj Scm_ProfilerRawResult(void)
{
ScmVM *vm = Scm_VM();
if (vm->prof == NULL) return SCM_FALSE;
if (vm->prof->state == SCM_PROFILER_INACTIVE) return SCM_FALSE;
if (vm->prof->state == SCM_PROFILER_RUNNING) Scm_ProfilerStop();
if (vm->prof->errorOccurred > 0) {
Scm_Warn("profiler: An error has been occurred during saving profiling samples. The result may not be accurate");
}
Scm_ProfilerCountBufferFlush(vm);
/* collect samples in the current buffer */
collect_samples(vm->prof);
/* collect samples in the saved file */
off_t off;
SCM_SYSCALL(off, lseek(vm->prof->samplerFd, 0, SEEK_SET));
if (off == (off_t)-1) {
Scm_ProfilerReset();
Scm_Error("profiler: seek failed in retrieving sample data");
}
for (;;) {
ssize_t r = read(vm->prof->samplerFd, vm->prof->samples,
sizeof(ScmProfSample[1]) * SCM_PROF_SAMPLES_IN_BUFFER);
if (r <= 0) break;
vm->prof->currentSample = r / sizeof(ScmProfSample[1]);
collect_samples(vm->prof);
}
vm->prof->currentSample = 0;
if (ftruncate(vm->prof->samplerFd, 0) < 0) {
Scm_SysError("profiler: failed to truncate temporary file");
}
return SCM_OBJ(vm->prof->statHash);
}
/*=============================================================
* External API
*/
void Scm_ProfilerStart(void)
{
ScmVM *vm = Scm_VM();
ScmObj templat = Scm_StringAppendC(SCM_STRING(Scm_TmpDir()),
"/gauche-profXXXXXX", -1, -1);
char *templat_buf = Scm_GetString(SCM_STRING(templat)); /*mutable copy*/
if (!vm->prof) {
vm->prof = SCM_NEW(ScmVMProfiler);
vm->prof->state = SCM_PROFILER_INACTIVE;
vm->prof->samplerFd = Scm_Mkstemp(templat_buf);
vm->prof->currentSample = 0;
vm->prof->totalSamples = 0;
vm->prof->errorOccurred = 0;
vm->prof->currentCount = 0;
vm->prof->statHash =
SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 0));
unlink(templat_buf); /* keep anonymous tmpfile */
} else if (vm->prof->samplerFd < 0) {
vm->prof->samplerFd = Scm_Mkstemp(templat_buf);
unlink(templat_buf);
}
if (vm->prof->state == SCM_PROFILER_RUNNING) return;
vm->prof->state = SCM_PROFILER_RUNNING;
vm->profilerRunning = TRUE;
/* NB: this should be done globally!!! */
struct sigaction act;
act.sa_handler = sampler_sample;
sigfillset(&act.sa_mask);
act.sa_flags = SA_RESTART;
if (sigaction(SIGPROF, &act, NULL) < 0) {
Scm_SysError("sigaction failed");
}
ITIMER_START();
}
void Scm_ProfilerReset(void)
{
ScmVM *vm = Scm_VM();
if (vm->prof == NULL) return;
if (vm->prof->state == SCM_PROFILER_INACTIVE) return;
if (vm->prof->state == SCM_PROFILER_RUNNING) Scm_ProfilerStop();
if (vm->prof->samplerFd >= 0) {
close(vm->prof->samplerFd);
vm->prof->samplerFd = -1;
#if defined(GAUCHE_WINDOWS)
unlink(vm->prof->samplerFileName);
#endif /* GAUCHE_WINDOWS */
}
vm->prof->totalSamples = 0;
vm->prof->currentSample = 0;
vm->prof->errorOccurred = 0;
vm->prof->currentCount = 0;
vm->prof->statHash =
SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 0));
vm->prof->state = SCM_PROFILER_INACTIVE;
}
/* signal handler */
#if defined(GAUCHE_WINDOWS)
static void sampler_sample(ScmVM *vm)
#else /* !GAUCHE_WINDOWS */
static void sampler_sample(int sig)
#endif /* !GAUCHE_WINDOWS */
{
#if !defined(GAUCHE_WINDOWS)
ScmVM *vm = Scm_VM();
#endif /* !GAUCHE_WINDOWS */
if (vm == NULL || vm->prof == NULL) return;
if (vm->prof->state != SCM_PROFILER_RUNNING) return;
if (vm->prof->currentSample >= SCM_PROF_SAMPLES_IN_BUFFER) {
#if !defined(GAUCHE_WINDOWS)
ITIMER_STOP();
#endif /* !GAUCHE_WINDOWS */
sampler_flush(vm);
#if !defined(GAUCHE_WINDOWS)
ITIMER_START();
#endif /* !GAUCHE_WINDOWS */
}
int i = vm->prof->currentSample++;
if (vm->base) {
/* If vm->pc is RET and val0 is a subr, it is pretty likely that
we're actually executing that subr. */
if (vm->pc && SCM_VM_INSN_CODE(*vm->pc) == SCM_VM_RET
&& SCM_SUBRP(vm->val0)) {
vm->prof->samples[i].func = vm->val0;
vm->prof->samples[i].pc = NULL;
} else {
vm->prof->samples[i].func = SCM_OBJ(vm->base);
vm->prof->samples[i].pc = vm->pc;
}
} else {
vm->prof->samples[i].func = SCM_FALSE;
vm->prof->samples[i].pc = NULL;
}
vm->prof->totalSamples++;
}
void *rts_scheduler (void *reso) {
struct timeval currenttime;
struct timeval targettime;
struct timeval deltatime;
struct timeval intervaltime;
struct timespec waittime;
qtime_t utime, qtime, etime;
qentry_t *entry;
qdata_t edata;
qtype_t etype;
#ifdef HAVE_GAUCHE
char tmp[64] = "cm gauche vm";
ScmVM *vm;
ScmVM *parentvm;
int res = 0;
parentvm = Scm_VM();
vm = Scm_NewVM(parentvm, SCM_MAKE_STR_IMMUTABLE(tmp));
// probably should check to make sure there is no error
res = Scm_AttachVM(vm);
#endif
intervaltime.tv_sec = 0;
intervaltime.tv_usec = (int32_t)reso; // 100=.1 millisecond
deltatime.tv_sec = 0;
while (TRUE) {
pthread_mutex_lock(&state_lock);
if (rts_state == RTS_STATUS_STOPPED)
break;
else
while (rts_state == RTS_STATUS_PAUSED)
pthread_cond_wait(&pause_cond, &state_lock);
pthread_mutex_unlock(&state_lock);
gettimeofday(¤ttime, NULL);
//add_timevals(¤ttime, &intervaltime, &targettime);
timeradd(¤ttime, &intervaltime, &targettime);
while (TRUE) {
pthread_mutex_lock(&queue_lock);
if (rts_queue_empty_p()) {
pthread_mutex_unlock(&queue_lock);
break;
}
entry=rts_queue_pop();
qtime=qentry_time(entry);
utime=rts_scheduler_time_usec();
if (qtime>utime) {
rts_queue_prepend(entry);
pthread_mutex_unlock(&queue_lock);
break;
}
// drop entries more than a second late (?)
if (qtime<(utime-1000000)) {
qentry_free(entry);
pthread_mutex_unlock(&queue_lock);
break;
}
edata=qentry_data(entry);
etype=qentry_type(entry);
//etime=(rts_tunit == TIME_UNIT_MSEC) ? (utime/1000) : utime;
// use queue time not clock time!
etime=(rts_tunit == TIME_UNIT_MSEC) ? (qtime/1000) : qtime;
qentry_free(entry);
pthread_mutex_unlock(&queue_lock);
// queue unlocked during callback, enqueue should always lock
pthread_mutex_lock(&lisp_lock);
(*rts_callb) (edata, etype, etime);
pthread_mutex_unlock(&lisp_lock);
}
gettimeofday(¤ttime, NULL);
//fprintf(log_file, "%f \n", currenttime.tv_usec / 1000.0);
//find_positive_delta(&targettime, ¤ttime, &deltatime);
timersub(&targettime, ¤ttime, &deltatime);
if (deltatime.tv_usec > 0) {
waittime.tv_sec = deltatime.tv_sec;
waittime.tv_nsec = deltatime.tv_usec * 1000L;
//TIMEVAL_TO_TIMESPEC(&deltatime, &waittime);
nanosleep(&waittime, NULL);
}
}
rts_scheduler_reset();
fclose(log_file);
pthread_exit(NULL);
}
static ScmObj mutex_locker(ScmObj *args, int argc, void *mutex)
{
return Scm_MutexLock((ScmMutex*)mutex, SCM_FALSE, Scm_VM());
}
void further_options(const char *optarg)
{
ScmVM *vm = Scm_VM();
if (strcmp(optarg, "no-inline-globals") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOINLINE_GLOBALS);
}
else if (strcmp(optarg, "no-inline-locals") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOINLINE_LOCALS);
}
else if (strcmp(optarg, "no-inline-constants") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOINLINE_CONSTS);
}
else if (strcmp(optarg, "no-inline") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOINLINE_GLOBALS);
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOINLINE_LOCALS);
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOINLINE_CONSTS);
}
else if (strcmp(optarg, "no-post-inline-pass") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NO_POST_INLINE_OPT);
}
else if (strcmp(optarg, "no-lambda-lifting-pass") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NO_LIFTING);
}
else if (strcmp(optarg, "no-source-info") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOSOURCE);
}
else if (strcmp(optarg, "load-verbose") == 0) {
SCM_VM_RUNTIME_FLAG_SET(vm, SCM_LOAD_VERBOSE);
}
else if (strcmp(optarg, "include-verbose") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_INCLUDE_VERBOSE);
}
else if (strcmp(optarg, "case-fold") == 0) {
SCM_VM_RUNTIME_FLAG_SET(vm, SCM_CASE_FOLD);
}
else if (strcmp(optarg, "warn-legacy-syntax") == 0) {
Scm_SetReaderLexicalMode(SCM_INTERN("warn-legacy"));
}
else if (strcmp(optarg, "test") == 0) {
test_mode = TRUE;
}
/* For development; not for public use */
else if (strcmp(optarg, "collect-stats") == 0) {
stats_mode = TRUE;
SCM_VM_RUNTIME_FLAG_SET(vm, SCM_COLLECT_VM_STATS);
}
/* For development; not for public use */
else if (strcmp(optarg, "no-combine-instructions") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_NOCOMBINE);
}
/* For development; not for public use */
else if (strcmp(optarg, "debug-compiler") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_SHOWRESULT);
}
/* Experimental */
else if (strcmp(optarg, "limit-module-mutation") == 0) {
SCM_VM_RUNTIME_FLAG_SET(vm, SCM_LIMIT_MODULE_MUTATION);
}
/* Experimental */
else if (strcmp(optarg, "c-expr") == 0) {
SCM_VM_COMPILER_FLAG_SET(vm, SCM_COMPILE_ENABLE_CEXPR);
}
else {
fprintf(stderr, "unknown -f option: %s\n", optarg);
fprintf(stderr, "supported options are: -fcase-fold, -fload-verbose, -finclude-verbose, -fno-inline, -fno-inline-globals, -fno-inline-locals, -fno-inline-constants, -fno-source-info, -fno-post-inline-pass, -fno-lambda-lifting-pass, -fwarn-legacy-syntax, or -ftest\n");
exit(1);
}
}
} else if (access("../../src/gauche/config.h", R_OK) == 0
&& access("../../libsrc/srfi-1.scm", R_OK) == 0
&& access("../../lib/srfi-0.scm", R_OK) == 0) {
Scm_AddLoadPath("../../src", FALSE);
Scm_AddLoadPath("../../libsrc", FALSE);
Scm_AddLoadPath("../../lib", FALSE);
}
/* Also set a feature identifier gauche.in-place, so that other modules
may initialize differently if needed. */
Scm_AddFeature("gauche.in-place", NULL);
}
/* Cleanup */
void cleanup_main(void *data SCM_UNUSED)
{
ScmVM *vm = Scm_VM();
if (profiling_mode) {
Scm_ProfilerStop();
Scm_EvalCString("(profiler-show)",
SCM_OBJ(Scm_GaucheModule()),
NULL); /* ignore errors */
}
/* EXPERIMENTAL */
if (stats_mode) {
fprintf(stderr, "\n;; Statistics (*: main thread only):\n");
fprintf(stderr,
";; GC: %zubytes heap, %zubytes allocated\n",
GC_get_heap_size(), GC_get_total_bytes());
fprintf(stderr,
