futures fixes

svn: r16829

src/mzscheme/gc2/newgc.c

@@ -32,10 +32,24 @@
 #include <stdio.h>
 #include <string.h>
 #include <assert.h>
+#include "pthread.h"
 #include "platforms.h"
 #include "gc2.h"
 #include "gc2_dump.h" 
 
+/*
+#ifdef FUTURES_ENABLED 
+extern pthread_t g_rt_threadid;
+
+#ifdef DEBUG_FUTURES
+extern void dump_state(void);
+#endif
+#endif
+*/
+
+#if defined(FUTURES_ENABLED) || defined(INSTRUMENT_PRIMITIVES)
+#include "../src/future.h"
+#endif
 
 /* the number of tags to use for tagged objects */
 #define NUMBER_OF_TAGS 512
@@ -771,7 +785,15 @@ inline static void *allocate(const size_t request_size, const int type)
       GC_gen0_alloc_page_end    = NUM(new_mpage->addr) + GEN0_PAGE_SIZE;
     }
     else {
+			#ifdef INSTRUMENT_PRIMITIVES 
+			LOG_PRIM_START(((void*)garbage_collect));			
+			#endif
+
       garbage_collect(gc, 0);
+
+			#ifdef INSTRUMENT_PRIMITIVES 
+			LOG_PRIM_END(((void*)garbage_collect));
+			#endif
     }
     newptr = GC_gen0_alloc_page_ptr + allocate_size;
     ASSERT_VALID_OBJPTR(newptr);
@@ -3055,6 +3077,14 @@ extern double scheme_get_inexact_milliseconds(void);
 
 static void garbage_collect(NewGC *gc, int force_full)
 {
+	#ifdef FUTURES_ENABLED
+	//Sanity check for FUTURES 
+	if (g_rt_threadid != 0 && pthread_self() != g_rt_threadid)
+	{
+		printf("garbage_collect invoked on wrong thread!!!\n");
+	}	
+	#endif
+
   unsigned long old_mem_use = gc->memory_in_use;
   unsigned long old_gen0    = gc->gen0.current_size;
   int next_gc_full;

src/mzscheme/main.c

@@ -78,6 +78,10 @@ START_XFORM_SUSPEND;
 # endif
 #endif
 
+#ifdef INSTRUMENT_PRIMITIVES 
+extern int g_print_prims;
+#endif
+
 #ifdef MZ_XFORM
 END_XFORM_SUSPEND;
 #endif

src/mzscheme/src/Makefile.in

@@ -261,11 +261,13 @@ error.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../incl
         $(srcdir)/../src/stypes.h  
 eval.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
         $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c \
-          $(srcdir)/schmach.h $(srcdir)/mzstkchk.h $(srcdir)/schrunst.h
+          $(srcdir)/schmach.h $(srcdir)/mzstkchk.h $(srcdir)/schrunst.h \
+				$(srcdir)/future.h
 file.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
         $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c 
 fun.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
-        $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc
+        $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc \
+				$(srcdir)/future.h
 future.@LTO@: $(srcdir)/schpriv.h $(srcdir)/future.h $(SCONFIG) $(srcdir)/../include/scheme.h \
         $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c
 hash.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
@@ -279,7 +281,8 @@ jit.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../includ
         $(srcdir)/lightning/ppc/core.h $(srcdir)/lightning/ppc/core-common.h \
         $(srcdir)/lightning/ppc/asm.h $(srcdir)/lightning/ppc/asm-common.h \
         $(srcdir)/lightning/ppc/funcs.h $(srcdir)/lightning/ppc/funcs-common.h \
-        $(srcdir)/lightning/ppc/fp.h $(srcdir)/lightning/ppc/fp-common.h
+        $(srcdir)/lightning/ppc/fp.h $(srcdir)/lightning/ppc/fp-common.h \
+				$(srcdir)/future.h
 list.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
         $(srcdir)/../src/stypes.h  
 module.@LTO@: $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \

src/mzscheme/src/eval.c

@@ -144,6 +144,8 @@
 #include <Memory.h>
 #endif 
 
+#include "future.h"
+
 #define EMBEDDED_DEFINES_START_ANYWHERE 0
 
 /* globals */
@@ -7694,6 +7696,10 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj
 
  */
 
+#ifdef INSTRUMENT_PRIMITIVES
+extern int g_print_prims;
+#endif
+
 #ifdef REGISTER_POOR_MACHINE
 # define USE_LOCAL_RUNSTACK 0
 # define DELAY_THREAD_RUNSTACK_UPDATE 0
@@ -7852,8 +7858,10 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
       }
 
       f = prim->prim_val;
-      v = f(num_rands, rands, (Scheme_Object *)prim);
+			LOG_PRIM_START(f);
 
+      v = f(num_rands, rands, (Scheme_Object *)prim);
+			LOG_PRIM_END(f);
       DEBUG_CHECK_TYPE(v);
     } else if (type == scheme_closure_type) {
       Scheme_Closure_Data *data;

src/mzscheme/src/fun.c

@@ -2388,10 +2388,14 @@ Scheme_Object *_scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_ran
   return do_apply_with_prompt(rator, num_rands, rands, 1, 0);
 }
 
+#ifdef INSTRUMENT_PRIMITIVES
+extern int g_print_prims;
+#endif
 
 Scheme_Object *
 scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
 {
+
   /* NOTE: apply_values_execute (in syntax.c) and
      tail_call_with_values_from_multiple_result (in jit.c)
      assume that this function won't allocate when 
@@ -2399,6 +2403,13 @@ scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
   int i;
   Scheme_Thread *p = scheme_current_thread;
 
+	#ifdef INSTRUMENT_PRIMITIVES 
+	if (g_print_prims)
+	{
+		printf("scheme_tail_apply\n");
+	}
+	#endif
+
   p->ku.apply.tail_rator = rator;
   p->ku.apply.tail_num_rands = num_rands;
 

src/mzscheme/src/future.c

@@ -3,6 +3,10 @@
 # include "schpriv.h"
 #endif
 
+#ifdef INSTRUMENT_PRIMITIVES 
+int g_print_prims = 0;
+#endif
+
 #ifdef FUTURES_ENABLED
 
 #include "future.h"
@@ -12,8 +16,12 @@
 # include "./tests/unit_test.h"
 #endif 
 
-#define THREAD_POOL_SIZE 1
+extern void *on_demand_jit_code;
+
+#define THREAD_POOL_SIZE 2
 static pthread_t g_pool_threads[THREAD_POOL_SIZE];
+static int g_num_avail_threads = 0;
+static unsigned long g_cur_cpu_mask = 1;
 
 future_t *g_future_queue = NULL;
 int g_next_futureid = 0;
@@ -33,8 +41,6 @@ static pthread_cond_t g_future_pending_cv = PTHREAD_COND_INITIALIZER;
 
 //Functions
 #ifndef UNIT_TEST
-static Scheme_Object *future(int argc, Scheme_Object *argv[]);
-static Scheme_Object *touch(int argc, Scheme_Object **argv);
 static void *worker_thread_future_loop(void *arg);
 static void *invoke_rtcall(future_t *future);
 static future_t *enqueue_future(void);
@@ -83,16 +89,20 @@ void debug_assert_context(future_t *future)
 	rtcall_context_t *context = future->context;
 	if (MZ_RUNSTACK_START != future->context->mz_runstack_start)
 	{
-		printf("MZ_RUNSTACK_START was %p, but future runstack start should be %p.\n", 
+		printf("Future %d (thread %p) reports MZ_RUNSTACK_START was %p, but future runstack start should be %p.\n", 
+			future->id, 
+			future->threadid, 
 			MZ_RUNSTACK_START, 
-			context->mz_runstack_start);
+			future->runstack_start);
 	}
 
 	if (MZ_RUNSTACK != context->mz_runstack)
 	{
-		printf("MZ_RUNSTACK was %p, but future runstack should be %p.\n", 
+		printf("Future %d (thread %p) reports MZ_RUNSTACK was %p, but future runstack should be %p.\n", 
+			future->id, 
+			future->threadid, 
 			MZ_RUNSTACK, 
-			context->mz_runstack);
+			future->runstack);
 	}
 }
 
@@ -103,7 +113,6 @@ void debug_kill_context(void)
 	free(future->context);
 	future->context = NULL;
 }
-#endif
 
 static Scheme_Object **get_thread_runstack(void)
 {
@@ -116,6 +125,50 @@ static Scheme_Object **get_thread_runstack_start(void)
 	return MZ_RUNSTACK_START;
 }
 
+void dump_state(void)
+{
+	future_t *f;
+	pthread_mutex_lock(&g_future_queue_mutex);
+	printf("\n");
+	printf("FUTURES STATE:\n");
+	printf("-------------------------------------------------------------\n");
+	if (NULL == g_future_queue)
+	{
+		printf("No futures currently running.  %d thread(s) available in the thread pool.\n\n", g_num_avail_threads);
+		pthread_mutex_unlock(&g_future_queue_mutex);
+		return;
+	}
+
+	for (f = g_future_queue; f != NULL; f = f->next)
+	{
+		printf("Future %d [Thread: %p, Runstack start = %p, Runstack = %p]: ", f->id, f->threadid, f->runstack_start, f->runstack);		
+		fflush(stdout);
+		switch (f->status)
+		{
+			case PENDING: 
+				printf("Waiting to be assigned to thread\n");
+				break;
+			case RUNNING: 
+				printf("Executing JIT code\n");
+				break;
+			case WAITING_FOR_PRIM:
+				printf("Waiting for runtime primitive invocation (prim=%p)\n", (void*)f->rt_prim);
+				break;
+			case FINISHED: 
+				printf("Finished work, waiting for cleanup\n");
+				break;
+		}
+
+		fflush(stdout);
+		printf("%d thread(s) available in the thread pool.\n", g_num_avail_threads);
+		printf("\n");
+		fflush(stdout);
+	}
+
+	pthread_mutex_unlock(&g_future_queue_mutex);
+}
+#endif
+
 
 /**********************************************************************/
 /* Plumbing for MzScheme initialization                               */
@@ -143,6 +196,15 @@ void scheme_init_futures(Scheme_Env *env)
 			1), 
 		newenv);
 
+	scheme_add_global_constant(
+		"num-processors", 
+		scheme_make_prim_w_arity(
+			num_processors, 
+			"num-processors", 
+			0, 
+			0), 
+		newenv);
+
 	scheme_add_global_constant(
 		"touch", 
 		scheme_make_prim_w_arity(
@@ -152,6 +214,26 @@ void scheme_init_futures(Scheme_Env *env)
 			1), 
 		newenv);
 
+	#ifdef INSTRUMENT_PRIMITIVES
+	scheme_add_global_constant(
+		"start-primitive-tracking", 
+		scheme_make_prim_w_arity(
+			start_primitive_tracking, 
+			"start-primitive-tracking", 
+			0,
+			0), 
+		newenv);
+
+	scheme_add_global_constant(
+		"end-primitive-tracking", 
+		scheme_make_prim_w_arity(
+			end_primitive_tracking, 
+			"end-primitive-tracking", 
+			0,
+			0), 
+		newenv);
+	#endif
+
 	scheme_finish_primitive_module(newenv);
 	scheme_protect_primitive_provide(newenv, NULL);
 	END_XFORM_SKIP;
@@ -168,11 +250,13 @@ void futures_init(void)
 
   //Create the worker thread pool.  These threads will
   //'queue up' and wait for futures to become available    
-    for (i = 0; i < THREAD_POOL_SIZE; i++)
+  for (i = 0; i < THREAD_POOL_SIZE - 1; i++)
   {
       pthread_create(&threadid, NULL, worker_thread_future_loop, NULL);
       g_pool_threads[i] = threadid;
   }
+
+	g_num_avail_threads = THREAD_POOL_SIZE;
 }
 
 
@@ -180,13 +264,59 @@ void futures_init(void)
 /* Primitive implementations                    					  */
 /**********************************************************************/
 
+#ifdef INSTRUMENT_PRIMITIVES
+long start_ms = 0;
+
+Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[])
+{
+	//Get the start time
+	struct timeval now;
+	long ms;
+  gettimeofday(&now, NULL);
+	
+	start_ms = now.tv_usec / 1000.0;
+	
+	g_print_prims = 1;
+	printf("Primitive tracking started at ");
+	print_ms_and_us();
+	printf("\n");
+	return scheme_void;
+}
+
+Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[])
+{
+	g_print_prims = 0;
+	printf("Primitive tracking ended at ");
+	print_ms_and_us();
+	printf("\n");
+	return scheme_void;
+}
+
+void print_ms_and_us()
+{
+  struct timeval now;
+	long ms, us;
+  gettimeofday(&now, NULL);
+
+	//ms = (now.tv_sec * 1000.0) - start_ms;
+	ms = (now.tv_usec / 1000) - start_ms;
+	us = now.tv_usec - (ms * 1000) - (start_ms * 1000);
+  printf("%ld.%ld", ms, us);
+}
+#endif
+
 Scheme_Object *future(int argc, Scheme_Object *argv[])
 {
 	START_XFORM_SKIP;
+
+		#ifdef DEBUG_FUTURES 
+		LOG_THISCALL;
+		dump_state();
+		#endif
+
     int init_runstack_size, main_runstack_size;
-    int futureid = ++g_next_futureid;
+		int futureid;
     future_t *ft;
-    Scheme_Object **old_rs, **old_rs_start;
     Scheme_Native_Closure *nc;
     Scheme_Native_Closure_Data *ncd;
     Scheme_Object *lambda = argv[0];
@@ -198,34 +328,41 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
     pthread_mutex_lock(&g_future_queue_mutex);
     ft = enqueue_future();
     pthread_cond_init(&ft->can_continue_cv, NULL);
+		futureid = ++g_next_futureid;
     ft->id = futureid;
     ft->orig_lambda = lambda;
     ft->pending = 1;
    
-    //Allocate the runstack and copy the runtime thread's
+    //Allocate a new scheme stack for the future 
-    //runstack
+		//init_runstack_size = MZ_RUNSTACK - MZ_RUNSTACK_START;
-		init_runstack_size = MZ_RUNSTACK - MZ_RUNSTACK_START;
+		init_runstack_size = 1000;
+
+		#ifdef DEBUG_FUTURES
+		printf("Allocating Scheme stack of %d bytes for future %d.\n", init_runstack_size, futureid); 
+		#endif
 
     ft->runstack_start = scheme_alloc_runstack(init_runstack_size);
     ft->runstack = ft->runstack_start + init_runstack_size;
-    //memcpy(ft->runstack_start, MZ_RUNSTACK_START, main_runstack_size);
 
-    pthread_mutex_unlock(&g_future_queue_mutex);
+    //pthread_mutex_unlock(&g_future_queue_mutex);
 
-    //JIT compile the code
+    //JIT compile the code if not already jitted
     //Temporarily repoint MZ_RUNSTACK
     //to the worker thread's runstack -
     //in case the JIT compiler uses the stack address
     //when generating code
-    //old_rs = MZ_RUNSTACK;
+		if (ncd->code == on_demand_jit_code)
-    //old_rs_start = MZ_RUNSTACK_START;
+		{
-    //MZ_RUNSTACK = ft->runstack;
+			printf("JIT compiling code.\n");
-    //MZ_RUNSTACK_START = ft->runstack_start;
 			scheme_on_demand_generate_lambda(nc, 0, NULL);
-    //MZ_RUNSTACK = old_rs;
+			printf("Code pointer is now %p, and on_demand_jit_code is %p.\n", ncd->code, on_demand_jit_code);
-    //MZ_RUNSTACK_START = old_rs_start;
+		}
+		else
+		{
+			printf("Code pointer was %p, and on_demand_jit_code was %p.  Code is already JIT compiled.\n", ncd->code, on_demand_jit_code);
+		}
 
-		pthread_mutex_lock(&g_future_queue_mutex);
+		//pthread_mutex_lock(&g_future_queue_mutex);
 		ft->code = (void*)ncd->code;
 		pthread_mutex_unlock(&g_future_queue_mutex);
 
@@ -239,6 +376,12 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
 }
 
 
+Scheme_Object *num_processors(int argc, Scheme_Object *argv[])
+{
+	return scheme_make_integer(THREAD_POOL_SIZE);
+}
+
+
 Scheme_Object *touch(int argc, Scheme_Object *argv[])
 {
 	START_XFORM_SKIP;
@@ -249,6 +392,11 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
 
 		futureid = SCHEME_INT_VAL(argv[0]);
 
+		#ifdef DEBUG_FUTURES 
+		LOG("touch (future %d)", futureid);	
+		dump_state();
+		#endif
+
     pthread_mutex_lock(&g_future_queue_mutex);
     ft = get_future(futureid);
     pthread_mutex_unlock(&g_future_queue_mutex);
@@ -280,6 +428,8 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
                 free(ft);
             }
 
+						//Increment the number of available pool threads
+						g_num_avail_threads++;	
             pthread_mutex_unlock(&g_future_queue_mutex);
         }
         else if (ft->rt_prim != NULL)
@@ -288,7 +438,9 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
             //Release the lock so other threads can manipulate the queue
             //while the runtime call executes
             pthread_mutex_unlock(&g_future_queue_mutex);
+						LOG("Invoking primitive %p on behalf of future %d...", ft->rt_prim, ft->id);
             rtcall_retval = invoke_rtcall(ft);
+						LOG("done.\n");
             pthread_mutex_lock(&g_future_queue_mutex);
 
             ft->rt_prim_retval = rtcall_retval;
@@ -301,6 +453,10 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
             pthread_cond_signal(&ft->can_continue_cv);
             pthread_mutex_unlock(&g_future_queue_mutex);
 
+						#ifdef DEBUG_FUTURES 
+						dump_state();
+						#endif
+
             goto wait_for_rtcall_or_completion;
         }
         else
@@ -323,19 +479,35 @@ void *worker_thread_future_loop(void *arg)
 	Scheme_Object *v;
 	Scheme_Object* (*jitcode)(Scheme_Object*, int, Scheme_Object**);
 
+	//Set processor affinity
+	pthread_mutex_lock(&g_future_queue_mutex);
+	if (pthread_setaffinity_np(pthread_self(), sizeof(g_cur_cpu_mask), &g_cur_cpu_mask))
+	{
+		printf(
+			"Could not set CPU affinity (%lu) for thread %p!\n", 
+			++g_cur_cpu_mask, 
+			pthread_self());
+	}
+
+	pthread_mutex_unlock(&g_future_queue_mutex);
+
     wait_for_work:
-        LOG("Waiting for new future work...");
+        //LOG("Waiting for new future work...");
         pthread_mutex_lock(&g_future_pending_mutex);
         pthread_cond_wait(&g_future_pending_cv, &g_future_pending_mutex);
 
-        LOG("Got a signal that a future is pending...");
+        //LOG("Got a signal that a future is pending...");
         
         //Work is available for this thread
         pthread_mutex_lock(&g_future_queue_mutex);
         future_t *ft = get_pending_future();
         ft->pending = 0;
+				ft->status = RUNNING;
         ft->threadid = pthread_self();
 
+				//Decrement the number of available pool threads 
+				g_num_avail_threads--;
+
 				//Initialize the runstack for this thread 
 				//MZ_RUNSTACK AND MZ_RUNSTACK_START should be thread-local
 				MZ_RUNSTACK = ft->runstack;
@@ -355,12 +527,17 @@ void *worker_thread_future_loop(void *arg)
         //From this thread's perspective, this call will never return
         //until all the work to be done in the future has been completed,
         //including runtime calls.
+				LOG("Running JIT code at %p...\n", ft->code);
         v = jitcode(ft->orig_lambda, 0, NULL);
+				LOG("Finished running JIT code at %p.\n", ft->code);
 
         //Set the return val in the descriptor
         pthread_mutex_lock(&g_future_queue_mutex);
         ft->work_completed = 1;
         ft->retval = v;
+
+				//Update the status 
+				ft->status = FINISHED;
         pthread_mutex_unlock(&g_future_queue_mutex);
 
         goto wait_for_work;
@@ -409,6 +586,9 @@ int future_do_runtimecall(
     future->rt_prim_sigtype = sigtype;
     future->rt_prim_args = args;
 
+		//Update the future's status to waiting 
+		future->status = WAITING_FOR_PRIM;
+
     //Wait for the signal that the RT call is finished
     pthread_cond_wait(&future->can_continue_cv, &g_future_queue_mutex);
 
@@ -441,19 +621,20 @@ int rtcall_void_void(void (*f)())
 	LOG_RTCALL_VOID_VOID(f);
 
 	#ifdef DEBUG_FUTURES
-	debug_save_context();
+	//debug_save_context();
 	#endif
 
 	data.prim = f;
 
 	future = get_my_future();
 	future->rt_prim_sigtype = SIG_VOID_VOID;
+	future->rt_prim = (void*)f;
 	future->calldata.void_void = data;
 
 	future_do_runtimecall((void*)f, SIG_VOID_VOID, NULL, NULL);
 
 	#ifdef DEBUG_FUTURES
-	debug_kill_context();
+	//debug_kill_context();
 	#endif
 
 	return 1;
@@ -466,7 +647,7 @@ int rtcall_obj_int_pobj_obj(
 	Scheme_Object *a, 
 	int b, 
 	Scheme_Object **c, 
-	Scheme_Object *retval)
+	Scheme_Object **retval)
 {
 	START_XFORM_SKIP;
 	future_t *future;
@@ -480,7 +661,7 @@ int rtcall_obj_int_pobj_obj(
 	LOG_RTCALL_OBJ_INT_POBJ_OBJ(f, a, b, c);
 
 	#ifdef DEBUG_FUTURES
-	debug_save_context();
+	//debug_save_context();
 	#endif
 
 	data.prim = f;
@@ -490,13 +671,14 @@ int rtcall_obj_int_pobj_obj(
 	
 	future = get_my_future();
 	future->rt_prim_sigtype = SIG_OBJ_INT_POBJ_OBJ;
+	future->rt_prim = (void*)f;
 	future->calldata.obj_int_pobj_obj = data;
 
 	future_do_runtimecall((void*)f, SIG_OBJ_INT_POBJ_OBJ, NULL, NULL);
-	*retval = *(future->calldata.obj_int_pobj_obj.retval);
+	*retval = future->calldata.obj_int_pobj_obj.retval;
 
 	#ifdef DEBUG_FUTURES
-	debug_kill_context();
+	//debug_kill_context();
 	#endif
 
 	return 1;
@@ -519,7 +701,7 @@ void *invoke_rtcall(future_t *future)
 	MZ_RUNSTACK = future->runstack;
 	MZ_RUNSTACK_START = future->runstack_start;
 	#ifdef DEBUG_FUTURES
-	debug_assert_context(future);
+	//debug_assert_context(future);
 	g_rtcall_count++;
 	#endif
 
@@ -711,21 +893,22 @@ future_t *get_future_by_threadid(pthread_t threadid)
   future_t *ft = g_future_queue;
   if (NULL == ft)
 	{
-        return ft;
+			printf("Couldn't find a future with thread ID %p!\n", threadid);
-		}
-    
-    while (ft->threadid != threadid)
-		{
-        ft = ft->next;
-		}
-
-    //Sanity check
-    if (ft->threadid != threadid)
-		{
       return NULL;
 	}
 	
+	while (1)
+	{
+		if (ft->threadid == threadid)
+		{
 			return ft;
+		}
+
+		ft = ft->next;
+	}
+
+	printf("Couldn't find a future with thread ID %p!\n", threadid);
+	return NULL;
 	END_XFORM_SKIP;
 }
 

src/mzscheme/src/future.h

@@ -2,6 +2,7 @@
 #define SCHEME_FUTURES_H
 
 #ifndef UNIT_TEST
+#include "schpriv.h"
 typedef Scheme_Object*(*prim_t)(int, Scheme_Object**);
 #else
 #define Scheme_Object void
@@ -23,6 +24,11 @@ int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2);
 #include <stdio.h>
 
 extern pthread_t g_rt_threadid;
+extern Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]);
+extern Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]);
+extern Scheme_Object *future(int argc, Scheme_Object *argv[]);
+extern Scheme_Object *touch(int argc, Scheme_Object *argv[]);
+extern Scheme_Object *num_processors(int argc, Scheme_Object *argv[]);
 extern void scheme_init_futures(Scheme_Env *env);
 extern int future_do_runtimecall(void *func, int sigtype, void *args, void *retval);
 extern void futures_init(void);
@@ -57,9 +63,15 @@ typedef struct {
 	} calldata;
 } rtcall_args_t;
 
+#define PENDING 0
+#define RUNNING 1
+#define WAITING_FOR_PRIM 2
+#define FINISHED 3
+
 typedef struct future {
 	int id;
 	pthread_t threadid;
+	int status;
   int pending;
 	int work_completed;
 	pthread_cond_t can_continue_cv;
@@ -115,6 +127,41 @@ extern future_t *get_last_future(void);
 extern void clear_futures(void);
 #endif
 
+//Primitive instrumentation stuff 
+#ifdef INSTRUMENT_PRIMITIVES 
+extern int g_print_prims;
+extern void print_ms_and_us(void);
+#define LOG_PRIM_START(p) \
+	if (g_print_prims) \
+	{ \
+		printf("%p ", p); \
+		print_ms_and_us(); \
+		printf("\n"); \
+	} 
+
+#define LOG_PRIM_END(p) 
+/*
+#define LOG_PRIM_END(p) \
+	if (g_print_prims) \
+	{ \
+		print_ms_and_us(); \
+		printf("\n"); \
+	}
+*/
+
+#define LOG_PRIM_W_NAME(name) \
+	if (g_print_prims) \
+	{ \
+		printf("%s ", name); \
+		print_ms_and_us(); \
+		printf("\n"); \
+	} 
+#else
+#define LOG_PRIM_START(p) 
+#define LOG_PRIM_END(p) 
+#define LOG_PRIM_W_NAME(name) 
+#endif
+
 //Signature flags for primitive invocations
 //Here the convention is SIG_[arg1type]_[arg2type]..._[return type]
 #define SIG_VOID_VOID 1 						//void -> void
@@ -161,7 +208,7 @@ extern int rtcall_obj_int_pobj_obj(
 	Scheme_Object *a, 
 	int b, 
 	Scheme_Object **c, 
-	Scheme_Object *retval);
+	Scheme_Object **retval);
 
 
 /*

src/mzscheme/src/jit.c

@@ -41,9 +41,7 @@
 
 #include "schpriv.h"
 #include "schmach.h"
-#ifdef FUTURES_ENABLED
 # include "future.h"
-#endif
 #ifdef MZ_USE_DWARF_LIBUNWIND
 # include "unwind/libunwind.h"
 #endif
@@ -143,7 +141,7 @@ static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *v
 static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
 static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
 static void *syntax_e_code;
-static void *on_demand_jit_code;
+void *on_demand_jit_code;
 static void *on_demand_jit_arity_code;
 static void *get_stack_pointer_code;
 static void *stack_cache_pop_code;
@@ -2129,6 +2127,10 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
   return ref2;
 }
 
+#ifdef INSTRUMENT_PRIMITIVES
+extern int g_print_prims;
+#endif
+
 /* Support for intercepting direct calls to primitives: */
 #ifdef FUTURES_ENABLED
 # define mz_prepare_direct_prim(n) mz_prepare(n)
@@ -2136,13 +2138,25 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands,
 # define mz_direct_only(p) /* skip this arg, so that total count <= 3 args */
 static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc)
 {
+	Scheme_Object *ret;
+	LOG_PRIM_START(proc);
+
   RTCALL_INT_OBJARR_OBJ(proc, argc, MZ_RUNSTACK);
-  return proc(argc, MZ_RUNSTACK);
+  ret = proc(argc, MZ_RUNSTACK);
+	LOG_PRIM_END(proc);
+
+	return ret;
 }
 static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self)
 {
+	Scheme_Object *ret;
+	LOG_PRIM_START(proc);
+
   RTCALL_INT_POBJ_OBJ_OBJ(proc, argc, MZ_RUNSTACK, self);
-  return proc(argc, MZ_RUNSTACK, self);
+  ret = proc(argc, MZ_RUNSTACK, self);
+	
+	LOG_PRIM_END(proc);
+	return ret;
 }
 
 /* Various specific 'futurized' versions of primitives that may 
@@ -2152,13 +2166,13 @@ static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc
 static Scheme_Object *ts_scheme_apply_multi_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv)
 {
   /* RTCALL_OBJ_INT_POBJ_OBJ(_scheme_apply_multi_from_native, rator, argc, argv); */
-  Scheme_Object *ret;
+  Scheme_Object *retptr;
   if (rtcall_obj_int_pobj_obj(_scheme_apply_multi_from_native, 
                               rator, 
                               argc, 
                               argv, 
-                              ret)) {
+                              &retptr)) {
-    return ret;
+    return retptr;
   }
 
   return _scheme_apply_multi_from_native(rator, argc, argv);
@@ -2167,13 +2181,13 @@ static Scheme_Object *ts_scheme_apply_multi_from_native(Scheme_Object *rator, in
 static Scheme_Object *ts_scheme_apply_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv)
 {
   /* RTCALL_OBJ_INT_POBJ_OBJ(_scheme_apply_from_native, rator, argc, argv); */
-  Scheme_Object *ret;
+  Scheme_Object *retptr;
   if (rtcall_obj_int_pobj_obj(_scheme_apply_from_native, 
                               rator, 
                               argc, 
                               argv, 
-                              ret)) {
+                              &retptr)) {
-    return ret;
+    return retptr;
   }
   
   return _scheme_apply_from_native(rator, argc, argv);

src/mzscheme/src/schnapp.inc

@@ -1,3 +1,5 @@
+#include "future.h"
+
 /* For non-tail calls, the native context has already
    incremented MZ_CONT_MARK_POS. Counter
    scheme_do_eval()'s increment, because this
@@ -30,7 +32,9 @@ static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator,
   }
   
   f = (Scheme_Primitive_Closure_Proc *)prim->prim_val;
+	LOG_PRIM_START(f);
   v = f(argc, argv, (Scheme_Object *)prim);
+	LOG_PRIM_END(f);  
 
 #if PRIM_CHECK_VALUE
   if (v == SCHEME_TAIL_CALL_WAITING) {
@@ -68,6 +72,9 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
   {
     GC_CAN_IGNORE Scheme_Object *v;
     MZ_CONT_MARK_POS -= 2;
+
+		LOG_PRIM_W_NAME("_scheme_apply");
+
     v = _scheme_apply(rator, argc, argv);
     MZ_CONT_MARK_POS += 2;
     return v;
@@ -75,6 +82,8 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
 #else
 # if PRIM_CHECK_VALUE
   {
+		LOG_PRIM_W_NAME("_scheme_apply_multi");
+
     GC_CAN_IGNORE Scheme_Object *v;
     MZ_CONT_MARK_POS -= 2;
     v = _scheme_apply_multi(rator, argc, argv);
@@ -82,6 +91,8 @@ Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
     return v;
   }
 # else 
+	LOG_PRIM_W_NAME("_scheme_tail_apply");
+
   return _scheme_tail_apply(rator, argc, argv);
 # endif
 #endif

src/mzscheme/src/string.c

@@ -1872,6 +1872,10 @@ format(int argc, Scheme_Object *argv[])
   return scheme_make_sized_utf8_string(s, len);
 }
 
+#ifdef INSTRUMENT_PRIMITIVES
+extern int g_print_prims;
+#endif
+
 static Scheme_Object *
 sch_printf(int argc, Scheme_Object *argv[])
 {