// This returns #t if successful, or a number (the correct length) if there was a mismatched length.
ptr s_fftw_execute (ptr vec, uptr plan) {
int i;
int len = Svector_length(vec);
int N = len / 2;
clock_t start, end;
plan_t* p = (plan_t*) plan;
/*printf("Executing!! len %i incoming len %i\n", p->vec_len, Svector_length(vec));
for (i=0; i<10; i++)
printf(" Got element %i %lf\n", i, ((double*)p->vec)[i]);
printf(" Got element %i %lf\n", 262000, ((double*)p->vec)[262000]);
printf(" Got element %i %lf\n", 524000, ((double*)p->vec)[524000]);*/
// TODO: CHECK THAT LENGTH IS RIGHT!
if (N != p->vec_len) {
printf("Mismatched lengths! %i %i\n", N, p->vec_len);
return(Sfixnum((uptr)p->vec_len));
}
//printf("Measuring... "); fflush( 0 );
//start = clock();
//end = clock();
//printf("Done. (time used %i)\n", end - start); fflush( 0 );
//printf("Filling... \n"); fflush( 0 );
for(i=0; i<len; i+=2) {
/*printf("Loading: real %lf, imag %lf\n",
Sflonum_value(Svector_ref(vec, i)),
Sflonum_value(Svector_ref(vec, i+1)));*/
((double*)p->vec)[i] = Sflonum_value(Svector_ref(vec, i));
((double*)p->vec)[i+1] = Sflonum_value(Svector_ref(vec, i+1));
}
//printf("Done\n");
//printf("Executing... "); fflush( 0 );
//start = clock();
fftw_execute(p->plan);
//end = clock();
//printf("Done. (time used %i)\n", end - start); fflush( 0 );
//printf("Clocks per sec... %i\n", CLOCKS_PER_SEC);
// Fill the output back into the vector:
for(i=0; i<len; i++) {
//printf("Unloading: %lf\n", ((double*)out)[i]);
Svector_set(vec, i, Sflonum(((double*)p->vec)[i]));
}
}
static ptr eval(ptr x) {
if (Spairp(x)) {
switch (Schar_value(Scar(x))) {
case '+': return S_add(First(x), Second(x));
case '-': return S_sub(First(x), Second(x));
case '*': return S_mul(First(x), Second(x));
case '/': return S_div(First(x), Second(x));
case 'q': return S_trunc(First(x), Second(x));
case 'r': return S_rem(First(x), Second(x));
case 'g': return S_gcd(First(x), Second(x));
case '=': {
ptr x1 = First(x), x2 = Second(x);
if (Sfixnump(x1) && Sfixnump(x2))
return Sboolean(x1 == x2);
else if (Sbignump(x1) && Sbignump(x2))
return Sboolean(S_big_eq(x1, x2));
else return Sfalse;
}
case '<': {
ptr x1 = First(x), x2 = Second(x);
if (Sfixnump(x1))
if (Sfixnump(x2))
return Sboolean(x1 < x2);
else
return Sboolean(!BIGSIGN(x2));
else
if (Sfixnump(x2))
return Sboolean(BIGSIGN(x1));
else
return Sboolean(S_big_lt(x1, x2));
}
case 'f': return Sflonum(S_floatify(First(x)));
case 'c':
S_gc(get_thread_context(), UNFIX(First(x)),UNFIX(Second(x)));
return Svoid;
case 'd': return S_decode_float(Sflonum_value(First(x)));
default:
S_prin1(x);
putchar('\n');
printf("unrecognized operator, returning zero\n");
return FIX(0);
}
} else
return x;
}
static void main_init() {
ptr tc = get_thread_context();
ptr p;
INT i;
/* force thread inline allocation to go through find_room until ready */
AP(tc) = (ptr)0;
EAP(tc) = (ptr)0;
REAL_EAP(tc) = (ptr)0;
/* set up dummy CP so locking in read/write/Scall won't choke */
CP(tc) = Svoid;
CODERANGESTOFLUSH(tc) = Snil;
if (S_boot_time) S_G.protect_next = 0;
S_segment_init();
S_alloc_init();
S_thread_init();
S_intern_init();
S_gc_init();
S_number_init();
S_schsig_init();
S_new_io_init();
S_print_init();
S_stats_init();
S_foreign_init();
S_prim_init();
S_prim5_init();
S_fasl_init();
S_machine_init();
S_flushcache_init(); /* must come after S_machine_init(); */
#ifdef FEATURE_EXPEDITOR
S_expeditor_init();
#endif /* FEATURE_EXPEDITOR */
if (!S_boot_time) return;
FXLENGTHBV(tc) = p = S_bytevector(256);
for (i = 0; i < 256; i += 1) {
BVIT(p, i) =
(iptr)FIX(i & 0x80 ? 8 : i & 0x40 ? 7 : i & 0x20 ? 6 : i & 0x10 ? 5 :
i & 0x08 ? 4 : i & 0x04 ? 3 : i & 0x02 ? 2 : i & 0x01 ? 1 : 0);
}
FXFIRSTBITSETBV(tc) = p = S_bytevector(256);
for (i = 0; i < 256; i += 1) {
BVIT(p, i) =
(iptr)FIX(i & 0x01 ? 0 : i & 0x02 ? 1 : i & 0x04 ? 2 : i & 0x08 ? 3 :
i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0);
}
NULLIMMUTABLEVECTOR(tc) = S_null_immutable_vector();
NULLIMMUTABLEFXVECTOR(tc) = S_null_immutable_fxvector();
NULLIMMUTABLEBYTEVECTOR(tc) = S_null_immutable_bytevector();
NULLIMMUTABLESTRING(tc) = S_null_immutable_string();
PARAMETERS(tc) = S_G.null_vector;
for (i = 0 ; i < virtual_register_count ; i += 1) {
VIRTREG(tc, i) = FIX(0);
}
p = S_code(tc, type_code, size_rp_header);
CODERELOC(p) = S_relocation_table(0);
CODENAME(p) = Sfalse;
CODEARITYMASK(p) = FIX(0);
CODEFREE(p) = 0;
CODEINFO(p) = Sfalse;
CODEPINFOS(p) = Snil;
RPHEADERFRAMESIZE(&CODEIT(p, 0)) = 0;
RPHEADERLIVEMASK(&CODEIT(p, 0)) = 0;
RPHEADERTOPLINK(&CODEIT(p, 0)) =
(uptr)&RPHEADERTOPLINK(&CODEIT(p, 0)) - (uptr)p;
S_protect(&S_G.dummy_code_object);
S_G.dummy_code_object = p;
S_protect(&S_G.error_invoke_code_object);
S_G.error_invoke_code_object = Snil;
S_protect(&S_G.invoke_code_object);
S_G.invoke_code_object = Snil;
S_protect(&S_G.active_threads_id);
S_G.active_threads_id = S_intern((const unsigned char *)"$active-threads");
S_set_symbol_value(S_G.active_threads_id, FIX(0));
S_protect(&S_G.heap_reserve_ratio_id);
S_G.heap_reserve_ratio_id = S_intern((const unsigned char *)"$heap-reserve-ratio");
SETSYMVAL(S_G.heap_reserve_ratio_id, Sflonum(default_heap_reserve_ratio));
S_protect(&S_G.scheme_version_id);
S_G.scheme_version_id = S_intern((const unsigned char *)"$scheme-version");
S_protect(&S_G.make_load_binary_id);
S_G.make_load_binary_id = S_intern((const unsigned char *)"$make-load-binary");
S_protect(&S_G.load_binary);
S_G.load_binary = Sfalse;
}
ptr test2 (ptr x) {
return Sflonum(3.8);
}