/* INTERIM DYLAN RUN-TIME SYSTEM INTERFACE
 *
 * Copyright (C) 1996 Functional Objects, Inc. All rights reserved
 *
 * This is the implementation of the interim interface between
 * the Dylan run-time system and the Memory Manager. It is
 * only here to make initial integration with Dylan easier
 * by removing some of the burden from the Dylan Group.  The
 * Dylan run-time system should migrate to the full MPS Interface
 * as soon as possible.
 *
 * This implementation now operates with multiple threads using
 * the full thread-safe MPS Interface.
 *
 * The interface is implemented using two pools: one AMC pool, which
 * holds the general objects, and an MV pool for miscellaneous
 * objects and wrappers.
 *
 * Problems:
 *  This module doesn't hold on to root handles, and violates the
 *  rule of symmetry when destroying the space on the way out from
 *  the trampoline.
 */

#ifdef LINUX_PLATFORM
#define RUN_TIME_API
#else
#define RUN_TIME_API __declspec( dllexport )
#endif


/* HACK Added by phoward 17-JUN-98
 * The file SPY-INTERFACES.C contains definitions that are not
 * referenced from within the runtime itself, but are called
 * remotely by the debugger. The Microsoft linker will throw
 * away these definitions unless another file references at least
 * one of them. The following (uncalled) function is the forced
 * reference we need.
 */

extern int spy_load_extension_component(char *);

void force_reference_to_spy_interface()
{
  spy_load_extension_component("");
}


/* Controlling the use of the Leaf Object pool 
 *
 * The leaf pool can be turned off completely with
 *   #define NO_LEAF_OBJECT
 *
 * Alternatively, finer control may be used to determine whether
 * common allocation profiles use the leaf pool or the main pool.
*/

#define USE_LEAF_FOR_SMALL_OBJECTS
#define USE_LEAF_FOR_STRINGS      
#define USE_LEAF_FOR_REPEATED_OBJECTS


#ifdef USE_LEAF_FOR_SMALL_OBJECTS
#define MMReserveLeafObject MMReserveLeaf
#define MMCommitLeafObject MMCommitLeaf
#else
#define MMReserveLeafObject MMReserveObject
#define MMCommitLeafObject MMCommitObject
#endif

#ifdef USE_LEAF_FOR_REPEATED_OBJECTS
#define MMReserveLeafRepeated MMReserveLeaf
#define MMCommitLeafRepeated MMCommitLeaf
#else
#define MMReserveLeafRepeated MMReserveObject
#define MMCommitLeafRepeated MMCommitObject
#endif

#ifdef USE_LEAF_FOR_STRINGS
#define MMReserveLeafTerminated MMReserveLeaf
#define MMCommitLeafTerminated MMCommitLeaf
#else
#define MMReserveLeafTerminated MMReserveObject
#define MMCommitLeafTerminated MMCommitObject
#endif

#ifdef TUNE_GEN0_FREQ 
extern long AMCGen0Frequency;
#endif

#ifndef MAXIMUM_HEAP_SIZE
#define MAXIMUM_HEAP_SIZE (512 * 1024 * 1024)
#endif

#ifdef BOEHM_GC
#include "gc.h"
#define MAX_BOEHM_HEAP_SIZE (176 * 1024 * 1024)
/* #define INITIAL_BOEHM_HEAP_SIZE (50 * 1024 * 1024) */
#define NO_FINALIZATION
#endif

#include "mm.h"        /* Dylan Interface */
#include "mps.h"        /* MPS Interface */
#include "mpscmv.h"     /* MPS pool class MV */
#include "mpscamc.h"    /* MPS pool class AMC */
#include "mpsavm.h"     /* MPS arena class */
#ifndef BOEHM_GC
#ifndef LINUX_PLATFORM
#include "mpsw3.h"
#endif
#else
#include "boehm.h"
#endif
#include "fmtdy.h"      /* Dylan object format */
#include "mpslib.h"     /* plinth interface */
#include <memory.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <assert.h>

#ifdef LINUX_PLATFORM
#include "linux-win32.c"
#else
#include <windows.h>
#endif

#ifdef NO_WEAKNESS
/* Revert the definitions of anything to do with weakness */
#define MPS_RANK_WEAK MPS_RANK_EXACT
#define dylan_fmt_A_weak dylan_fmt_A
#define mps_class_awl mps_class_amc
/* Plus an extra extern */
#ifndef BOEHM_GC
extern mps_res_t mps_root_create_table_masked(mps_root_t *, mps_space_t,
                                              mps_rank_t, mps_rm_t,
                                              mps_addr_t *, size_t,
                                              mps_word_t);
#endif
#else
#include "mpscawl.h"    /* MPS pool class AWL */
#endif /* NO_WEAKNESS */

#ifdef NO_LEAF_OBJECT
#define mps_class_amcz mps_class_amc
#else
#include "mpsclo.h"    /* MPS pool class LO */
#endif

/* Configuration
 *
 * MISC* configure the MV pool.
 */

#define MISCEXTENDBY    ((size_t)16384)
#define MISCAVGSIZE     ((size_t)32)
#define MISCMAXSIZE     ((size_t)65536)


typedef mps_word_t              word;
typedef unsigned char           byte_char;
typedef unsigned short          half_word;
typedef _int64                  double_word;
typedef float                   single_float;
typedef double                  double_float;
typedef void* 	                dylan_object;


#define TARG_CHECK (MPS_RES_OK == MMSUCCESS && \
                    MPS_RES_FAIL == MMFAILURE && \
                    MPS_RES_RESOURCE == MMRESOURCE && \
                    MPS_RES_MEMORY == MMRESMEM && \
                    MPS_RES_LIMIT == MMLIMIT && \
                    MPS_RES_UNIMPL == MMUNIMPLEMENTED && \
                    MPS_RES_IO == MMIO)



void report_runtime_error (char* header, char* message)
{
#ifndef BOEHM_GC
  mps_lib_FILE *stream = mps_lib_get_stderr();  
  mps_lib_fputs(header, stream);
  mps_lib_fputs(message, stream);
  mps_lib_fputc('\n', stream);
  mps_lib_abort();
#endif
}

void simple_error (char* message)
{
  report_runtime_error("\nDylan runtime error: ", message);
}



/* Default Error Handler
 *
 * This is the default error handler initially installed for all the
 * allocation interfaces in mm.h.  It prints a message on the standard
 * error stream then causes abnormal program termination.
 */

#ifdef MPS_OS_SU
extern int fprintf(FILE *, const char *, ...);
#endif

static void defaultHandler(MMError e, const char *opName, size_t size)
{
  /*
  fprintf(stderr,
          "**** %s:%d: request for %lu bytes failed -- aborting\n",
          opName, (int)e, (unsigned long)size);
  */
#ifndef BOEHM_GC
  mps_lib_FILE *stream = mps_lib_get_stderr();  
  mps_lib_fputs("\nError: ", stream);
  mps_lib_fputs(opName, stream);
  mps_lib_fputs(" - Request to allocate failed -- aborting\n", stream);
  mps_lib_abort();
#endif
}

mps_space_t space;
static mps_fmt_t format;
static mps_fmt_t dylan_fmt_weak;
static mps_fmt_A_t fmt_A;
static mps_fmt_A_t fmt_A_weak;
static mps_pool_t main_pool, weak_table_pool, wrapper_pool, misc_pool, leaf_pool;

#ifndef NO_FINALIZATION
static mps_message_type_t finalization_type;
#endif

static MMAllocHandler main_handler = defaultHandler;
static MMAllocHandler weak_awl_handler = defaultHandler;
static MMAllocHandler exact_awl_handler = defaultHandler;
static MMAllocHandler wrapper_handler = defaultHandler;
static MMAllocHandler leaf_handler = defaultHandler;
static MMAllocHandler misc_handler = defaultHandler;


/* Thread Local Variables, accessed via the GC-TEB*/

typedef struct gc_teb_s {       /* GC Thread Environment block descriptor */
  mps_bool_t gc_teb_inside_tramp;  /* the HARP runtime assumes offset 0 for this */
  mps_ap_t   gc_teb_main_ap;       /* the HARP runtime assumes offset 1 for this */
  mps_ap_t   gc_teb_weak_awl_ap;
  mps_ap_t   gc_teb_exact_awl_ap;
  mps_ap_t   gc_teb_leaf_ap;
  mps_thr_t  gc_teb_thread;
  mps_root_t gc_teb_stack_root;
  size_t     gc_teb_allocation_counter;   /* the profiler assumes this is at offset -1 from main TEB */
} gc_teb_s;


/* The profiler can use this as an offset of the allocation counter from TEB */
/* This assumes that the gc_teb is contiguous with the main teb. the HARP    */
/* runtime ensure this is always true.                                       */

int teb_allocation_counter_offset = - ((int)sizeof(size_t)); 


BOOL heap_statsQ = FALSE;
BOOL heap_alloc_statsQ = FALSE;
extern void add_stat_for_object (void *object, void* wrapper, int size);
extern void clear_wrapper_stats ();
extern void display_wrapper_stats ();

char   *dylan_buffer = NULL;
int    dylan_buffer_pos = 0;
int    dylan_buffer_size = 8192;
BOOL   dylan_streamQ = FALSE;


RUN_TIME_API
void primitive_begin_heap_alloc_stats()
{
#ifndef NO_ALLOCATION_COUNT_FOR_PROFILER
  heap_statsQ = TRUE;
  heap_alloc_statsQ = TRUE;
  clear_wrapper_stats();
#endif 
}

RUN_TIME_API
int primitive_end_heap_alloc_stats(char *buffer)
{
#ifndef NO_ALLOCATION_COUNT_FOR_PROFILER
  dylan_streamQ = TRUE;
  dylan_buffer = buffer;
  dylan_buffer_pos = 0;
  if (heap_alloc_statsQ)
    display_wrapper_stats();
  dylan_streamQ = FALSE;
  heap_alloc_statsQ = FALSE;
  return(dylan_buffer_pos);
#endif 
}

#ifdef LINUX_PLATFORM
extern pthread_mutex_t class_breakpoint_lock;
#else
extern CRITICAL_SECTION class_breakpoint_lock;
#endif

extern unsigned int class_breakpoints_pending;
extern HANDLE class_breakpoint_events[2];

extern void set_wrapper_breakpoint (void *wrapper, int count);
extern void clear_wrapper_breakpoint (void *wrapper);
extern BOOL check_wrapper_breakpoint_for_objectQ;

__inline
void *class_wrapper(void *class)
{
  void *iclass = ((void**)class)[3];
  void *wrapper  = ((void**)iclass)[3];

  return wrapper;
}


// Handling of class breakpoints in multi-threaded applications requires
// that this function be called as a spy on an interactive thread immediately;
// then the set and clear breakpoint primitives will be run as regular interactions
// when the application continues; this is to enable synchronization with regular
// application threads that may already be in the allocation breakpointing code.
// The two class breakpoint events are used to bring this synchronization about.

RUN_TIME_API
void primitive_class_breakpoint_pending()
{
  heap_statsQ = TRUE;
  ++class_breakpoints_pending;
}

RUN_TIME_API
void primitive_set_class_breakpoint(void *class, int count)
{
  if (WaitForSingleObject(class_breakpoint_events[0], INFINITE) != WAIT_OBJECT_0) {
    // MSG0("primitive_set_class_breakpoint: error waiting for class breakpoint event\n");
  };

  if (class == (void *)1)
    // set breakpoint on all dylan classes
    check_wrapper_breakpoint_for_objectQ = TRUE;
  else {
    void *wrapper = class_wrapper(class);
    set_wrapper_breakpoint(wrapper, count >> 2);
  }

  --class_breakpoints_pending;
  SetEvent(class_breakpoint_events[1]);
}

RUN_TIME_API
void primitive_clear_class_breakpoint(void *class)
{
  void *wrapper;

  if (WaitForSingleObject(class_breakpoint_events[0], INFINITE) != WAIT_OBJECT_0) {
    // MSG0("primitive_clear_class_breakpoint: error waiting for class breakpoint event\n");
  };

  switch ((int)class) {

  case 0:
    // clear all breakpoints
    check_wrapper_breakpoint_for_objectQ = FALSE;
    clear_wrapper_breakpoint(NULL);
    break;

  case 1:
    // clear breakpoint on all dylan classes
    check_wrapper_breakpoint_for_objectQ = FALSE;
    break;
  
  default:
    wrapper = class_wrapper(class);
    clear_wrapper_breakpoint(wrapper);
    break;

  }

  --class_breakpoints_pending;
  SetEvent(class_breakpoint_events[1]);
}

extern void display_wrapper_breakpoints();

RUN_TIME_API
int primitive_display_class_breakpoints(char *buffer)
{
  if (WaitForSingleObject(class_breakpoint_events[0], INFINITE) != WAIT_OBJECT_0) {
    // MSG0("primitive_display_class_breakpoints: error waiting for class breakpoint event\n");
  };

  dylan_streamQ = TRUE; dylan_buffer = buffer; dylan_buffer_pos = 0;
  display_wrapper_breakpoints();
  dylan_streamQ = FALSE;

  --class_breakpoints_pending;
  SetEvent(class_breakpoint_events[1]);

  return(dylan_buffer_pos);
}

extern void *call_dylan_function(void *function, size_t arg_count, ...);


/* Support for keyboard-break handling */

extern void *dylan_keyboard_break_handler;
extern BOOL dylan_keyboard_interruptQ;
BOOL DylanKeyboardInterruptPollingQ = TRUE;

RUN_TIME_API
BOOL primitive_keyboard_interrupt_signaled()
{
  return dylan_keyboard_interruptQ;
}

RUN_TIME_API
void primitive_keyboard_interrupt_signaled_setter(BOOL interruptQ)
{
  dylan_keyboard_interruptQ = interruptQ;
}

RUN_TIME_API
BOOL primitive_keyboard_interrupt_polling()
{
  return DylanKeyboardInterruptPollingQ;
}

RUN_TIME_API
void primitive_keyboard_interrupt_polling_setter(BOOL pollingQ)
{
  DylanKeyboardInterruptPollingQ = pollingQ;
}


#define MAX_POLLING_THREADS 50

HANDLE polling_threads[MAX_POLLING_THREADS];

int polling_threads_cursor = -1;

#ifdef LINUX_PLATFORM
CRITICAL_SECTION(polling_threads_lock);
#else
CRITICAL_SECTION polling_threads_lock;
#endif


int polling_thread_index (HANDLE hThread)
{
  int i;

  EnterCriticalSection(&polling_threads_lock);
  for (i = 0; i < polling_threads_cursor + 1; i++) {
    if (polling_threads[i] == hThread) {
      LeaveCriticalSection(&polling_threads_lock);
      return(i);
    }
  }
  LeaveCriticalSection(&polling_threads_lock);
  return(-1);
}

__inline
BOOL polling_threadQ (HANDLE hThread)
{
  int index = polling_thread_index(hThread);

  if (index < 0) return FALSE;
  else return TRUE;
}

__inline
BOOL polling_individual_threadsQ ()
{
  if (polling_threads_cursor > -1) return TRUE;
  return FALSE;
}


void add_polling_thread (HANDLE hThread)
{
  if (polling_threadQ(hThread)) return;

  EnterCriticalSection(&polling_threads_lock);
    if (polling_threads_cursor < MAX_POLLING_THREADS) {
      ++polling_threads_cursor;
      polling_threads[polling_threads_cursor] = hThread;
    };
  LeaveCriticalSection(&polling_threads_lock);
}


void remove_polling_thread (HANDLE hThread)
{
  int index = polling_thread_index(hThread);
  int i;

  if (index > -1) {
    EnterCriticalSection(&polling_threads_lock);
      for (i = index; i < polling_threads_cursor + 1; i++)
	polling_threads[i] = polling_threads[i+1];

      --polling_threads_cursor;
    LeaveCriticalSection(&polling_threads_lock);
  }
}


RUN_TIME_API
BOOL primitive_keyboard_interrupt_polling_thread(HANDLE hThread)
{
  if (DylanKeyboardInterruptPollingQ) return TRUE;
  return polling_threadQ(hThread);
}

RUN_TIME_API
void primitive_keyboard_interrupt_polling_thread_setter
  (BOOL pollingQ, HANDLE hThread)
{
  if (pollingQ) add_polling_thread(hThread);
  else remove_polling_thread(hThread);
}


extern HANDLE get_current_thread_handle();

void HandleDylanKeyboardInterrupt()
{
  if (DylanKeyboardInterruptPollingQ
      || (polling_individual_threadsQ()
	  && (polling_threadQ(get_current_thread_handle())))) {
    dylan_keyboard_interruptQ = FALSE;
    call_dylan_function(dylan_keyboard_break_handler, 0);
  }
}

extern int wrapper_breaks_cursor;
extern void check_wrapper_breakpoint (void *wrapper, int size);

// This is to enable Dylan spy functions to run unimpeded by class breakpoints

extern BOOL Prunning_dylan_spy_functionQ;


__inline 
void update_allocation_counter(gc_teb_t gc_teb, size_t count, void* wrapper)
{
#ifndef NO_ALLOCATION_COUNT_FOR_PROFILER
  gc_teb->gc_teb_allocation_counter += count;

  // Periodic polling of keyboard-interrupt flag
  if (dylan_keyboard_interruptQ) HandleDylanKeyboardInterrupt();

  if (heap_statsQ) {
    if (!Prunning_dylan_spy_functionQ) {
      if (heap_alloc_statsQ)
	add_stat_for_object(NULL, wrapper, count);
      check_wrapper_breakpoint(wrapper, count);
    }
  }
#endif 
}

void zero_allocation_counter(gc_teb_t gc_teb)
{
#ifndef NO_ALLOCATION_COUNT_FOR_PROFILER
  gc_teb->gc_teb_allocation_counter = 0;
#endif 
}


#ifdef LINUX_PLATFORM
/* TEMPORARY - while booting the compiler */
void *Pthread_local_storage_for_gc[10];
void *Pthread_local_storage[100];
#endif

__inline 
 gc_teb_t current_gc_teb()
{ 
  gc_teb_t gc_teb;
#if defined(X86_LINUX_PLATFORM)
//  __asm__
//    (
//      "movl   %%esp, %%ecx\n\t"
//      "orl    $0x1fffff, %%ecx\n\t"         /* the top of stack */
//      "movl   0xffffff01(%%ecx), %%ecx\n\t"  /* offset -255; intermediate mov to avoid too many memory references */
//      "movl   %%ecx,%0\n\t" /* the TEB */
//
//      // output operands
//      : "=g" (gc_teb)
//      : // no input operands
//      // clobbered machine registers
//      : "cx"
//    );
    __asm__
      (
       "movl %%gs:%c1,%%ecx\n\t"
       "movl   %%ecx,%0\n\t" /* the TEB */

       // output operands
       : "=g" (gc_teb)
       // input operands
       : "i" (4 * 15)
       // clobbered machine registers
       : "cx"
       );
#elif defined(PPC_LINUX_PLATFORM)
  __asm__
    (
      "la     11, %1\n\t"
      "lwz    12, 0x14(11)\n\t"  /* the TEB */
      "mr     %0, 12\n"

      // output operands
      : "=g" (gc_teb)
      // input operands
      : "g" (Pthread_local_storage)
      // clobbered machine registers
      : "r12", "r11"
    );
#else
  __asm
    {
      mov eax, dword ptr fs:[0x14] /* the TEB */
      mov gc_teb, eax
    };
#endif
  gc_teb--; /* the GC-TEB is BEFORE the TEB */
  return(gc_teb);
};


#define inside_tramp  (*current_gc_teb()).gc_teb_inside_tramp
#define main_ap       (*current_gc_teb()).gc_teb_main_ap
#define weak_awl_ap   (*current_gc_teb()).gc_teb_weak_awl_ap
#define exact_awl_ap  (*current_gc_teb()).gc_teb_exact_awl_ap
#define leaf_ap       (*current_gc_teb()).gc_teb_leaf_ap
#define thread        (*current_gc_teb()).gc_teb_thread
#define stack_root    (*current_gc_teb()).gc_teb_stack_root



/* Support for handling exceptions in Dylan (other than MM traps) */
/* Currently, we just handle stack overflows & numeric overflows  */

extern int inside_dylan_ffi_barrier();
extern void dylan_stack_overflow_handler(PVOID base_address, int size, DWORD protection);
extern void dylan_integer_overflow_handler();
extern void dylan_integer_divide_0_handler();
extern void dylan_float_divide_0_handler();
extern void dylan_float_overflow_handler();
extern void dylan_float_underflow_handler();

/* Support for foreign call-ins */
extern void *dylan_callin_internal(void *arg_base, size_t s);




PVOID current_stack_pointer ()
{
  PVOID stack_ptr;
#if defined(X86_LINUX_PLATFORM)
  __asm__
  (  
    "movl  %%esp, %0"

    // output operands
    : "=a" (stack_ptr)
  );
#elif defined(PPC_LINUX_PLATFORM)
  __asm__
  (  
    "mr  %0, 1"

    // output operands
    : "=g" (stack_ptr)
  );
#else
  __asm
  {  
    mov  stack_ptr, esp
  };
#endif
  return(stack_ptr);
};


#define VPAGESIZE 0x1000


void call_dylan_stack_overflow_handler ()
{
  MEMORY_BASIC_INFORMATION memBuf;
  PVOID stack_ptr = current_stack_pointer();
  int res = VirtualQuery(stack_ptr, &memBuf, sizeof(memBuf));

  PVOID baseAddress    = memBuf.BaseAddress;     // base address of region 
  PVOID allocationBase = memBuf.AllocationBase;  // allocation base address 
  DWORD protect        = memBuf.Protect;         // current access protection 
  
  dylan_stack_overflow_handler(baseAddress, VPAGESIZE, PAGE_GUARD + protect);

}


LONG DylanExceptionFilter (LPEXCEPTION_POINTERS info)
{

  LPEXCEPTION_RECORD er = info->ExceptionRecord;

  if (inside_dylan_ffi_barrier() == 0)
  {  return(EXCEPTION_CONTINUE_SEARCH);
  }

  switch (er->ExceptionCode) 
  {
  case EXCEPTION_STACK_OVERFLOW:
    {
      // On a stack overflow, the filter calls into Dylan to signal
      // an error, via dylan_signal_overflow_handler. The dylan
      // code will arrange to re-establish the guard protection on
      // the appropriate page of the stack (probably during the
      // rewind when recovering from the error). Before calling the 
      // handler, we do a check to ensure that there is sufficient 
      // spare stack space after the guard to allow the handler itself 
      // to run.

      MEMORY_BASIC_INFORMATION memBuf;
      PVOID stack_ptr = current_stack_pointer();
      int res = VirtualQuery(stack_ptr, &memBuf, sizeof(memBuf));

      PVOID baseAddress    = memBuf.BaseAddress;    // base address of region 
      PVOID allocationBase = memBuf.AllocationBase; // allocation base addr
  
      if ( ((int)baseAddress - (int)allocationBase) >= (2 * VPAGESIZE))
      {
        // There's enough space past the guard to invoke the Dylan handler.
        // Rather than attempt a long-jump within the filter (by simply
        // calling the Dylan handler) we destructively modify the execution
        // context, so that when Windows continues from the exception, it
        // actually continues in the Dylan handler calling code instead.
        // This handler will never return - instead it will ultimatly NLX

        info->ContextRecord->Eip = (unsigned long) &call_dylan_stack_overflow_handler;
        return(EXCEPTION_CONTINUE_EXECUTION);
      }
      else
        return(EXCEPTION_CONTINUE_SEARCH);
    }
  case EXCEPTION_INT_OVERFLOW:
    { info->ContextRecord->Eip = (unsigned long) &dylan_integer_overflow_handler;
      return(EXCEPTION_CONTINUE_EXECUTION);
    }
  case EXCEPTION_INT_DIVIDE_BY_ZERO:
    { info->ContextRecord->Eip = (unsigned long) &dylan_integer_divide_0_handler;
      return(EXCEPTION_CONTINUE_EXECUTION);
    }
  case EXCEPTION_FLT_DIVIDE_BY_ZERO:
    { info->ContextRecord->Eip = (unsigned long) &dylan_float_divide_0_handler;
      return(EXCEPTION_CONTINUE_EXECUTION);
    }
  case EXCEPTION_FLT_OVERFLOW:
    { info->ContextRecord->Eip = (unsigned long) &dylan_float_overflow_handler;
      return(EXCEPTION_CONTINUE_EXECUTION);
    }
  case EXCEPTION_FLT_UNDERFLOW:
    { info->ContextRecord->Eip = (unsigned long) &dylan_float_underflow_handler;
      return(EXCEPTION_CONTINUE_EXECUTION);
    }
  /*
  case  DBG_CONTROL_C:
    { dylan_keyboard_interruptQ = TRUE;
      return(EXCEPTION_CONTINUE_EXECUTION);
    }
   */
  
  default:
    return(EXCEPTION_CONTINUE_SEARCH);
  }  
}


/* Thread creation & deletion code */

int num_threads = 0;

/* client estimate for handling requirements goes here */
int low_memory_allocation_per_thread = 128 * 1024;


#ifdef LINUX_PLATFORM
CRITICAL_SECTION(reservoir_limit_set_lock);
#else
CRITICAL_SECTION reservoir_limit_set_lock;
#endif

__inline
void update_runtime_thread_count(int increment)
{

  EnterCriticalSection(&reservoir_limit_set_lock);
    num_threads = num_threads + increment;
#ifndef BOEHM_GC
    mps_reservoir_limit_set(space, num_threads * low_memory_allocation_per_thread);
#endif
  LeaveCriticalSection(&reservoir_limit_set_lock);
}


MMError dylan_mm_register_thread(void *stackBot)
{
  mps_res_t res;

  gc_teb_t gc_teb = current_gc_teb();

  update_runtime_thread_count(1);

  zero_allocation_counter(gc_teb);

#ifndef BOEHM_GC

  res = mps_ap_create(&gc_teb->gc_teb_main_ap, main_pool, MPS_RANK_EXACT);
  if(res) goto failApCreate;

  res = mps_ap_create(&gc_teb->gc_teb_leaf_ap, leaf_pool, MPS_RANK_EXACT);
  if(res) goto failLeafApCreate;

  res = mps_ap_create(&gc_teb->gc_teb_weak_awl_ap, weak_table_pool, MPS_RANK_WEAK);
  if(res) goto failWeakAWLApCreate;

  res = mps_ap_create(&gc_teb->gc_teb_exact_awl_ap, weak_table_pool, MPS_RANK_EXACT);
  if(res) goto failExactAWLApCreate;

  res = mps_thread_reg(&gc_teb->gc_teb_thread, space);
  if(res) goto failThreadReg;

  /* Create a root object for ambiguously scanning the stack. */
  assert(stackBot != NULL);
  res = mps_root_create_reg(&gc_teb->gc_teb_stack_root, space, MPS_RANK_AMBIG, 
                           (mps_rm_t)0,
                            gc_teb->gc_teb_thread, mps_stack_scan_ambig, stackBot, 0);
  if(res) goto failStackRootCreate;
  return res;

  mps_root_destroy(gc_teb->gc_teb_stack_root);
failStackRootCreate:
  mps_thread_dereg(gc_teb->gc_teb_thread);
failThreadReg:
  mps_ap_destroy(gc_teb->gc_teb_exact_awl_ap);
failExactAWLApCreate:
  mps_ap_destroy(gc_teb->gc_teb_weak_awl_ap);
failWeakAWLApCreate:
  mps_ap_destroy(gc_teb->gc_teb_leaf_ap);
failLeafApCreate:
  mps_ap_destroy(gc_teb->gc_teb_main_ap);
failApCreate:
  return res;

#else

  return 0;

#endif


}


MMError dylan_mm_deregister_thread_from_teb(gc_teb_t gc_teb)
{

  update_runtime_thread_count(-1);
#ifndef BOEHM_GC
  mps_root_destroy(gc_teb->gc_teb_stack_root);
  mps_thread_dereg(gc_teb->gc_teb_thread);
  mps_ap_destroy(gc_teb->gc_teb_main_ap);
  mps_ap_destroy(gc_teb->gc_teb_leaf_ap);
  mps_ap_destroy(gc_teb->gc_teb_weak_awl_ap);
  mps_ap_destroy(gc_teb->gc_teb_exact_awl_ap);
  return MPS_RES_OK;
#else
  return 0;
#endif
}


/* for backwards compatibility with old runtimes */
MMError dylan_mm_deregister_thread()
{
  gc_teb_t gc_teb = current_gc_teb();

  return dylan_mm_deregister_thread_from_teb(gc_teb);
}


MMError dylan_init_thread(void **rReturn, void *(*f)(void *, size_t), void *p, size_t s)
{
#ifndef LINUX_PLATFORM
  __try {   // establish the stack overflow filter outside the MPS handler
            // because it has less requirement for efficiency
#endif
    gc_teb_t gc_teb = current_gc_teb();

    gc_teb->gc_teb_inside_tramp = 1;
  
    /* Go for it! */
    mps_tramp(rReturn, f, p, s);

    gc_teb->gc_teb_inside_tramp = 0;

#ifndef LINUX_PLATFORM
    } 

  __except (DylanExceptionFilter(GetExceptionInformation())) {
    }
#endif

  return MPS_RES_OK;

}

void *dylan_callin_handler(void *arg_base, size_t s)
{
  void *res;

#ifndef LINUX_PLATFORM
  __try {   // establish the stack overflow filter outside the MPS handler
            // because it has less requirement for efficiency
#endif

    gc_teb_t gc_teb = current_gc_teb();

    mps_bool_t was_inside = gc_teb->gc_teb_inside_tramp;
    gc_teb->gc_teb_inside_tramp = 1;
  
    /* Go for it! */
    mps_tramp(&res, dylan_callin_internal, arg_base, s);

    gc_teb->gc_teb_inside_tramp = was_inside;

#ifndef LINUX_PLATFORM
    } 

  __except (DylanExceptionFilter(GetExceptionInformation())) {
    }
#endif

  return res;

}



__inline 
void fill_dylan_object_mem(dylan_object *mem, dylan_object fill, int count)
{
#if defined(X86_LINUX_PLATFORM)
  __asm__
    (
      "cld    \n\t"
      "movl   %0, %%eax\n\t"
      "movl   %1, %%ecx\n\t"
      "movl   %2, %%edi\n\t"
      "rep    \n\t"
      "stosl  %%eax,%%es:(%%edi)\n"

      // output operands
      :
      // input operands
      : "g" (fill), "g" (count), "g" (mem)
      // clobbered machine registers
      : "ax", "cx","di","si", "cc"
    );
#elif defined(PPC_LINUX_PLATFORM)
  __asm__
    (
      "mr    11, %0\n\t"
      "mr    12, %1\n\t"
      "mr    13, %2\n\t"
      "addic 12, 12, 1\n\t"
      "mtctr 12\n\t"
      "addic 13, 13, -4\n\t"
      "b     8\n\t"
      "stwu  11, 4(13)\n\t"
      "bdnz  -4\n\t"

      // output operands
      :
      // input operands
      : "g" (fill), "g" (count), "g" (mem)
      // clobbered machine registers
      : "r11", "r12","r13"
    );
#else
  __asm
    {
      cld
      mov eax, fill
      mov ecx, count
      mov edi, mem
      rep stosd
    };
#endif
};
  

#define define_fill_mem(type) \
__inline  \
void fill_ ## type ## _mem(type *mem, type fill, int count) \
{ \
  int index = 0; \
  while (index < count) \
    {  \
      mem[index] = fill; \
      ++index; \
    }; \
}

define_fill_mem(half_word)
define_fill_mem(double_word)
define_fill_mem(single_float)
define_fill_mem(double_float)


__inline 
void untraced_fill_byte_char_mem(void **object, byte_char fill, int count, int count_slot, mps_bool_t ztq)
{
  byte_char *d = (byte_char*)(&(object[count_slot + 1]));
  memset(d, fill, count);
  if (ztq) {
    d[count] = 0;
  }
}

#define define_untraced_fill_mem(type) \
__inline  \
void untraced_fill_ ## type ## _mem(void **object, type fill, int count, int count_slot, mps_bool_t ztq) \
{ \
  int index = 0; \
  type *mem = (type*)(object + count_slot + 1); \
  object[count_slot] = (void*)((count << 2) + 1); \
 \
  while (index < count) \
    {  \
      mem[index] = fill; \
      ++index; \
    }; \
}

define_untraced_fill_mem(dylan_object)
define_untraced_fill_mem(half_word)
define_untraced_fill_mem(double_word)
define_untraced_fill_mem(single_float)
define_untraced_fill_mem(double_float)



void *dylan__malloc__misc(size_t size)
{
  return MMAllocMisc(size);
}



#define BLOCK_CODE_MASK  0xff000000
#define BLOCK_CODE_TOKEN 0xab000000
#define BLOCK_SIZE_MASK  0x00ffffff

int encode_size_of_block(int size)
{
  if ((size & BLOCK_CODE_MASK) != 0) {
    simple_error("Unexpected block size for manual allocation");
  }
  return (size | BLOCK_CODE_TOKEN);
}

int decode_size_of_block(int size)
{
  if ((size & BLOCK_CODE_MASK) != BLOCK_CODE_TOKEN) {
    simple_error("Attempt to free a corrupted manually managed object");
  }
  return (size & BLOCK_SIZE_MASK);
}

RUN_TIME_API
void *mps__malloc(size_t size)
{
  size_t tot_size = size + sizeof(size_t);
  size_t *block = (size_t *)MMAllocMisc(tot_size);
  *block = encode_size_of_block(tot_size);
  return (void*)(++block);
}


void duplicated_deallocation_error(size_t *ptr)
{
  simple_error("Duplicate attempt to free manually managed object");
}


RUN_TIME_API
void mps__free(size_t *old)
{
  if (old != NULL) {
    size_t freed = 0xdeadf00d;
    size_t *block = old - 1;
    if (*block == freed) {
      duplicated_deallocation_error(old);
    } else {
      size_t size = decode_size_of_block(*block);
      *block = freed;
      MMFreeMisc((void *)block, size);
    }
  }
}


void dylan__finish__malloc(void)
{
}
  


__inline
void *wrapper_class(void *wrapper)
{
  void *iclass = ((void**)wrapper)[1];
  void *class  = ((void**)iclass)[2];

  return class;
}

extern void *dylan_signal_low_memory;
extern void *dylan_false;

#define reserve_memory_for_object(size,  \
				  wrapper,  \
				  gc_teb,  \
				  gc_teb_ap,  \
				  handler,  \
				  MMReserve)  \
{  \
  mps_res_t res;  \
  mps_addr_t p;  \
  \
  assert(gc_teb->gc_teb_inside_tramp);  \
  \
  do {  \
    res = mps_reserve(&p, gc_teb->gc_teb_ap, size);  \
  \
    if (res == MPS_RES_OK) {  \
      /* Success */  \
      return (void *)p;  \
  \
    } else {  \
      /* Failure due to low-memory - ask for reservoir permit */  \
      void *class = wrapper_class(wrapper);  \
      void *permit = call_dylan_function(dylan_signal_low_memory, 2, class, ((size << 2) + 1));  \
      if (permit != dylan_false) {  \
        /* Have permission - so use reservoir */  \
        res = mps_reserve_with_reservoir_permit  \
                (&p, gc_teb->gc_teb_ap, size);  \
        if (res == MPS_RES_OK) {  \
          return (void *)p;  \
        }  \
        /* Failure even when using reservoir. Catastrophic */  \
        (*handler)((MMError)res, MMReserve, size);  \
      } else {  \
        /* No permission to use the reservoir.  */  \
        /* Check the reservoir is full before looping again */  \
        /* Do this inside a critical region with the limit setting function */  \
	EnterCriticalSection(&reservoir_limit_set_lock);  \
	  { \
          size_t limit = mps_reservoir_limit(space);  \
          size_t avail = mps_reservoir_available(space);  \
          if (avail < limit) {  \
            /* The reservoir is not full - so the handling policy failed */  \
            /* Could attempt to do something smart here - like work out */  \
            /* whether other threads are likely to free up memory, */  \
            /* and signal a different error if not */  \
            }  \
          }  \
        LeaveCriticalSection(&reservoir_limit_set_lock);  \
        /* Try allocation again */  \
      }  \
  \
    }  \
  \
  } while (TRUE);  \
}


__inline
void *MMReserveObject(size_t size, void *wrapper, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  reserve_memory_for_object(size, wrapper, gc_teb, gc_teb_main_ap, main_handler, "MMReserveObject");

#else

  return malloc(size);

#endif
}

__inline
int MMCommitObject(void *p, size_t size, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  assert(gc_teb->gc_teb_inside_tramp);
  assert(dylan_check(p));
  return mps_commit(gc_teb->gc_teb_main_ap, p, size);

#else

  return 1;

#endif
}


__inline
void *MMReserveLeaf(size_t size, void *wrapper, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  reserve_memory_for_object(size, wrapper, gc_teb, gc_teb_leaf_ap, leaf_handler, "MMReserveLeaf");

#else

  return malloc(size);

#endif
}

__inline
int MMCommitLeaf(void *p, size_t size, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  assert(gc_teb->gc_teb_inside_tramp);
  assert(dylan_check(p));
  return mps_commit(gc_teb->gc_teb_leaf_ap, p, size);

#else

  return 1;

#endif
}

MMAllocHandler MMReserveLeafHandler(MMAllocHandler handler)
{
  MMAllocHandler h = leaf_handler;
  leaf_handler = handler;
  return h;
}

__inline
void *MMReserveExactAWL(size_t size, void *wrapper, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  reserve_memory_for_object(size, wrapper, gc_teb, gc_teb_exact_awl_ap, exact_awl_handler, "MMReserveExactAWL");

#else

  return malloc(size);

#endif
}

__inline
int MMCommitExactAWL(void *p, size_t size, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  assert(gc_teb->gc_teb_inside_tramp);
  assert(dylan_check(p));
  return mps_commit(gc_teb->gc_teb_exact_awl_ap, p, size);

#else

  return 1;

#endif
}

MMAllocHandler MMReserveExactAWLHandler(MMAllocHandler handler)
{
  MMAllocHandler h = exact_awl_handler;
  exact_awl_handler = handler;
  return h;
}

__inline
void *MMReserveWeakAWL(size_t size, void *wrapper, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  reserve_memory_for_object(size, wrapper, gc_teb, gc_teb_weak_awl_ap, weak_awl_handler, "MMReserveWeakAWL");

#else

  return malloc(size);

#endif
}

__inline
int MMCommitWeakAWL(void *p, size_t size, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  assert(gc_teb->gc_teb_inside_tramp);
  assert(dylan_check(p));
  return mps_commit(gc_teb->gc_teb_weak_awl_ap, p, size);

#else

  return 1;

#endif
}

MMAllocHandler MMReserveWeakAWLHandler(MMAllocHandler handler)
{
  MMAllocHandler h = weak_awl_handler;
  weak_awl_handler = handler;
  return h;
}


MMAllocHandler MMReserveObjectHandler(MMAllocHandler handler)
{
  MMAllocHandler h = main_handler;
  main_handler = handler;
  return h;
}

__inline
void *MMReserveWrapper(size_t size, void *wrapper, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  mps_res_t res;
  mps_addr_t p;

  assert(gc_teb->gc_teb_inside_tramp);

  res = mps_alloc(&p, wrapper_pool, size);
  if(res) {
    (*wrapper_handler)((MMError)res, "MMReserveWrapper", size);
    return (void *)NULL;
  }

  return (void *)p;

#else

  return malloc(size);

#endif
}

/* We declare each wrapper as a root on commit.  As a flip may
 * happen between reserve and commit, the wrapper may be initialized
 * to contain any moveable references.
 */
__inline
int MMCommitWrapper(void *p, size_t size, gc_teb_t gc_teb)
{
#ifndef BOEHM_GC

  mps_res_t res;
  mps_root_t root;

  assert(gc_teb->gc_teb_inside_tramp);
  assert(dylan_check(p));

  res = mps_root_create_fmt(&root, space, MPS_RANK_EXACT,
                             (mps_rm_t)0, fmt_A->scan, p, (char *)p + size);
  if(res) return 0;
  return 1;

#else

  return 1;

#endif
}

MMAllocHandler MMReserveWrapperHandler(MMAllocHandler handler)
{
  MMAllocHandler h = wrapper_handler;
  wrapper_handler = handler;
  return h;
}

void *MMAllocMisc(size_t size)
{
#ifndef BOEHM_GC

  mps_res_t res;
  void *p;
  /* gc_teb_t gc_teb = current_gc_teb(); */

  /*  assert(gc_teb->gc_teb_inside_tramp);   not a necessary condition for misc mem  */

  res = mps_alloc((mps_addr_t *)&p, misc_pool, size);
  if(res) {
    (*misc_handler)((MMError)res, "MMAllocMisc", size);
    return NULL;
  }

  return p;

#else

  return malloc(size);

#endif
}

MMAllocHandler MMAllocMiscHandler(MMAllocHandler handler)
{
  MMAllocHandler h = misc_handler;
  misc_handler = handler;
  return h;
}

void MMFreeMisc(void *old, size_t size)
{
#ifndef BOEHM_GC

  /* gc_teb_t gc_teb = current_gc_teb(); */

  /* assert(gc_teb->gc_teb_inside_tramp); */
  mps_free(misc_pool, (mps_addr_t)old, size);

#else

  free(old);

#endif
}


/* Streamlined allocation primitives */

/*

  There are a variety of specialized allocators, which allocate
  in different pools, and perform different combinations
  of initialization.

  The names follow the following pattern:-
    primitive_alloc{pool_opt}{slot_opt}{repeat_opt}

  All take arguments (size_t size, void *wrapper, {parameters-for-options})

  Here are the options, with their parameters (although not all combinations
  are necessarily implemented):-

  pool_opt:

    <default>    ()                    Allocate in AMC
    _leaf        ()                    Allocate in LO
    _exact_awl   (assoc)               Allocate exact in AWL
    _weak_awl    (assoc)               Allocate weak in AWL
    _wrapper     ()                    Allocate in wrapper pool

  slot_opt:
    <default>    ()                    No initialization of fixed slots
    _s1          (data1)               Fill slot 1 with data1
    _s2          (data1, data2)        Fill slot 1 with data1, slot 2 with data2 
    _s           (fill_num, fill)      Fill fill_num slots with fill


  repeat:opt
    <default>    ()                    No initializtion of repeated slots
    _r           (rep_size, offset)    Set repeated slot size at offset (raw param)
    _rf          (rep_size, off, fill) Set size slot and fill repeated data
    _rt          (rep_size, off, templ)Fill repeated data from template
    _ruf         (rep_size, off, fill) Set size slot and fill repeated untraced data
    _ruz         (rep_size, off)       Set rep slot size. Zero terminate untraced data
    _rufz        (rep_size, off, fill) Set size slot, fill & zero terminate  untraced data
    


*/


#define alloc_internal(size,  \
		       wrapper,  \
		         \
		       s1q,  /* init first 2 fixed slots */  \
		       s1,  \
		       s2q,  \
		       s2,  \
		         \
		       sq,   /* init any fixed slots */  \
		       no_to_fill,  \
		       fill,  \
		         \
		       rq,   /* init repeated slot size */  \
		       rep_size,  \
		       rep_size_slot,  \
		         \
		       rfq,  /* init repeated slot data for type */  \
		       type, \
		       word_fill,  \
		         \
		       ufq,  /* init untraced repeated slot data */  \
		       ztq,  \
		       type2, \
		       untraced_fill,  \
		         \
		       reserve,  \
		       commit)  \
{  \
  \
  size_t msize = (size);  \
  void *mwrapper = (wrapper);  \
			         \
  mps_bool_t ms1q = (s1q);  /* init first 2 fixed slots */  \
  void *ms1 = (s1);  \
  mps_bool_t ms2q = (s2q);  \
  void *ms2 = (s2);  \
    \
  mps_bool_t msq = (sq);   /* init other fixed slots */  \
  int mno_to_fill = (no_to_fill);  \
  void *mfill = (fill);  \
    \
  mps_bool_t mrq = (rq);   /* init repeated slot size */  \
  int mrep_size = (rep_size);  \
  int mrep_size_slot = (rep_size_slot);  \
    \
  mps_bool_t mrfq = (rfq);  /* init word repeated slot data */  \
  type mword_fill = (type)(word_fill);  \
    \
  mps_bool_t mufq = (ufq);  /* init untraced repeated slot data */  \
  mps_bool_t mztq = (ztq);  \
  type2 muntraced_fill = (type2)(untraced_fill);  \
  \
  void **object;  \
  \
  gc_teb_t gc_teb = current_gc_teb();  \
  \
  update_allocation_counter(gc_teb, msize, wrapper);  \
  \
  do {  \
    object = reserve(msize, wrapper, gc_teb);  \
    object[0] = mwrapper;  \
    if (msq) fill_dylan_object_mem(object + 1, mfill, mno_to_fill);  \
    if (ms1q) object[1] = ms1;  \
    if (ms2q) object[2] = ms2;  \
    if (mrq)  \
      if (mrep_size_slot)  \
	object[mrep_size_slot] = (void*)((mrep_size << 2) + 1);  \
    if (mrfq) fill_ ## type ## _mem((type *)(object + mrep_size_slot + 1), mword_fill, mrep_size);  \
  }  \
  while(!commit(object, msize, gc_teb));  \
  \
  if (mufq && mrq) {  \
    untraced_fill_ ## type2 ## _mem(object, muntraced_fill, mrep_size, mrep_size_slot, mztq); \
  }  \
    \
  \
  return object;  \
} 


#if 0

/* Here's an attempt to implement general allocators using a function rather than */
/* a macro. Unfortunately, the compiler can't be relied upon to inline the code.  */

__inline
static
void *primitive_alloc_internal(size_t size,
			       void *wrapper,
			       
			       mps_bool_t s1q,  /* init first 2 fixed slots */
			       void *s1,
			       mps_bool_t s2q,
			       void *s2,
			       
			       mps_bool_t sq,   /* init any fixed slots */
			       int no_to_fill,
			       void *fill,
			       
			       mps_bool_t rq,   /* init repeated slot size */
			       int rep_size,
			       int rep_size_slot,
			       
			       mps_bool_t rfq,  /* init word repeated slot data */
			       void *word_fill,
			       
			       mps_bool_t bfq,  /* init byte repeated slot data */
			       mps_bool_t ztq,
			       unsigned char byte_fill)
{
  void **object;

  gc_teb_t gc_teb = current_gc_teb();

  update_allocation_counter(gc_teb, size, wrapper);

  do {
    object = MMReserveObject(size, wrapper, gc_teb);
    object[0] = wrapper;
    if (sq) fill_mem(object + 1, fill, no_to_fill);
    if (s1q) object[1] = s1;
    if (s2q) object[2] = s2;
    if (rq)
      if (rep_size_slot)
	object[rep_size_slot] = (void*)((rep_size << 2) + 1);
    if (rfq) fill_mem(object + rep_size_slot + 1, word_fill, rep_size);
  }
  while(!MMCommitObject(object, size, gc_teb));

  if (bfq && rq) {
    unsigned char *d = (unsigned char*)(&(object[rep_size_slot + 1]));
    int byte_fill_size = rep_size;
    memset(d, byte_fill, byte_fill_size);
    if (ztq) {
      d[byte_fill_size] = 0;
    }
  }
  

  return object;
}

#endif


RUN_TIME_API
void *primitive_alloc(size_t size,
		      void *wrapper)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 0, 0, 0, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_s1(size_t size,
			  void *wrapper,
			  void *data1)
{
  alloc_internal(size, wrapper, 
		 1, data1, 0, 0,
		 0, 0, 0, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}

RUN_TIME_API
void *primitive_alloc_s2(size_t size,
			  void *wrapper,
			  void *data1,
			  void *data2)
{
  alloc_internal(size, wrapper, 
		 1, data1, 1, data2,
		 0, 0, 0, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_s(size_t size,
			void *wrapper,
			int no_to_fill,
			void *fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_r(size_t size,
			void *wrapper,
			int rep_size,
			int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 0, 0, 0,
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}

RUN_TIME_API
void *primitive_alloc_rf(size_t size,
			 void *wrapper,
			 int rep_size,
			 int rep_size_slot,
			 dylan_object fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 0, 0, 0,
		 1, rep_size, rep_size_slot,
		 1, dylan_object, fill,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_s_r(size_t size,
			  void *wrapper,
			  int no_to_fill,
			  void *fill,
			  int rep_size,
			  int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}


#define define_primitive_alloc_s_rf(type, suffix) \
RUN_TIME_API \
void *primitive_alloc_s_ ## suffix(size_t size, \
				   void *wrapper, \
				   int no_to_fill, \
				   void *fill, \
				   int rep_size, \
				   int rep_size_slot, \
				   type rep_fill) \
{ \
  alloc_internal(size, wrapper,  \
		 0, 0, 0, 0, \
		 1, no_to_fill, fill,  \
		 1, rep_size, rep_size_slot, \
		 1, type, rep_fill, \
		 0, 0, dylan_object, 0, \
		 MMReserveObject, MMCommitObject); \
}

define_primitive_alloc_s_rf(dylan_object, rf)
define_primitive_alloc_s_rf(half_word, rhf)
define_primitive_alloc_s_rf(single_float, rsff)
define_primitive_alloc_s_rf(double_float, rdff)
define_primitive_alloc_s_rf(double_word, rdwf)


RUN_TIME_API
void *primitive_alloc_s_rbf(size_t size,
			    void *wrapper,
			    int no_to_fill,
			    void *fill,
			    int rep_size,
			    int rep_size_slot,
			    int byte_fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 1, 0, byte_char, byte_fill,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_s_rbfz(size_t size,
			     void *wrapper,
			     int no_to_fill,
			     void *fill,
			     int rep_size,
			     int rep_size_slot,
			     int byte_fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 1, 1, byte_char, byte_fill,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_rbfz(size_t size,
			   void *wrapper,
			   int rep_size,
			   int rep_size_slot,
			   int byte_fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 0, 0, 0,
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 1, 1, byte_char, byte_fill,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_s_rb(size_t size,
			   void *wrapper,
			   int no_to_fill,
			   void *fill,
			   int rep_size,
			   int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveObject, MMCommitObject);
}


RUN_TIME_API
void *primitive_alloc_leaf(size_t size,
			   void *wrapper)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 0, 0, 0, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveLeafObject, MMCommitLeafObject);
}


RUN_TIME_API
void *primitive_alloc_leaf_s_r(size_t size,
			       void *wrapper,
			       int no_to_fill,
			       void *fill,
			       int rep_size,
			       int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveLeafRepeated, MMCommitLeafRepeated);
}



RUN_TIME_API
void *primitive_alloc_leaf_s1(size_t size,
			      void *wrapper,
			      void *data1)
{
  alloc_internal(size, wrapper, 
		 1, data1, 0, 0,
		 0, 0, 0, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveLeafObject, MMCommitLeafObject);
}

RUN_TIME_API
void *primitive_alloc_leaf_s2(size_t size,
			      void *wrapper,
			      void *data1,
			      void *data2)
{
  alloc_internal(size, wrapper, 
		 1, data1, 1, data2,
		 0, 0, 0, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveLeafObject, MMCommitLeafObject);
}


RUN_TIME_API
void *primitive_alloc_leaf_s(size_t size,
			     void *wrapper,
			     int no_to_fill,
			     void *fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 0, 0, 0,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveLeafObject, MMCommitLeafObject);
}



RUN_TIME_API
void *primitive_alloc_leaf_r(size_t size,
			     void *wrapper,
			     int rep_size,
			     int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 0, 0, 0,
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveLeafRepeated, MMCommitLeafRepeated);
}


RUN_TIME_API
void *primitive_alloc_leaf_s_rbf(size_t size,
				 void *wrapper,
				 int no_to_fill,
				 void *fill,
				 int rep_size,
				 int rep_size_slot,
				 int byte_fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 1, 0, byte_char, byte_fill,
		 MMReserveLeafRepeated, MMCommitLeafRepeated);
}

#define define_primitive_alloc_leaf_rf(type, suffix) \
RUN_TIME_API \
void *primitive_alloc_leaf_ ## suffix(size_t size, \
				      void *wrapper, \
				      int rep_size, \
				      int rep_size_slot, \
				      type rep_fill) \
{ \
  alloc_internal(size, wrapper,  \
		 0, 0, 0, 0, \
		 1, 0, 0,  \
		 1, rep_size, rep_size_slot, \
		 0, dylan_object, 0, \
		 1, 0, type, rep_fill, \
		 MMReserveLeafRepeated, MMCommitLeafRepeated); \
}


define_primitive_alloc_leaf_rf(dylan_object, rf)
define_primitive_alloc_leaf_rf(byte_char, rbf)
define_primitive_alloc_leaf_rf(half_word, rhf)
define_primitive_alloc_leaf_rf(single_float, rsff)
define_primitive_alloc_leaf_rf(double_float, rdff)
define_primitive_alloc_leaf_rf(double_word, rdwf)

RUN_TIME_API
void *primitive_alloc_leaf_s_rbfz(size_t size,
				  void *wrapper,
				  int no_to_fill,
				  void *fill,
				  int rep_size,
				  int rep_size_slot,
				  int byte_fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 1, 1, byte_char, byte_fill,
		 MMReserveLeafTerminated, MMCommitLeafTerminated);
}


RUN_TIME_API
void *primitive_alloc_leaf_rbfz(size_t size,
				void *wrapper,
				int rep_size,
				int rep_size_slot,
				int byte_fill)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 0, 0, 0,
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 1, 1, byte_char, byte_fill,
		 MMReserveLeafTerminated, MMCommitLeafTerminated);
}


RUN_TIME_API
void *primitive_alloc_leaf_s_rb(size_t size,
				void *wrapper,
				int no_to_fill,
				void *fill,
				int rep_size,
				int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveLeafRepeated, MMCommitLeafRepeated);
}


RUN_TIME_API
void *primitive_alloc_exact_awl_s_r(size_t size,
				    void *wrapper,
				    void *assoc,
				    int no_to_fill,
				    void *fill,
				    int rep_size,
				    int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 1, assoc, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveExactAWL, MMCommitExactAWL);
}


RUN_TIME_API
void *primitive_alloc_weak_awl_s_r(size_t size,
				   void *wrapper,
				   void *assoc,
				   int no_to_fill,
				   void *fill,
				   int rep_size,
				   int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 1, assoc, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveWeakAWL, MMCommitWeakAWL);
}


RUN_TIME_API
void *primitive_alloc_exact_awl_rf(size_t size,
				   void *wrapper,
				   void *assoc,
				   int rep_size,
				   int rep_size_slot,
				   void *fill)
{
  alloc_internal(size, wrapper, 
		 1, assoc, 0, 0,
		 0, 0, 0,
		 1, rep_size, rep_size_slot,
		 1, dylan_object, fill,
		 0, 0, dylan_object, 0,
		 MMReserveExactAWL, MMCommitExactAWL);
}


RUN_TIME_API
void *primitive_alloc_weak_awl_rf(size_t size,
				  void *wrapper,
				  void *assoc,
				  int rep_size,
				  int rep_size_slot,
				  void *fill)
{
  alloc_internal(size, wrapper, 
		 1, assoc, 0, 0,
		 0, 0, 0,
		 1, rep_size, rep_size_slot,
		 1, dylan_object, fill,
		 0, 0, dylan_object, 0,
		 MMReserveWeakAWL, MMCommitWeakAWL);
}


RUN_TIME_API
void *primitive_alloc_wrapper_s_r(size_t size,
				  void *wrapper,
				  int no_to_fill,
				  void *fill,
				  int rep_size,
				  int rep_size_slot)
{
  alloc_internal(size, wrapper, 
		 0, 0, 0, 0,
		 1, no_to_fill, fill, 
		 1, rep_size, rep_size_slot,
		 0, dylan_object, 0,
		 0, 0, dylan_object, 0,
		 MMReserveWrapper, MMCommitWrapper);
}


RUN_TIME_API
void *primitive_alloc_rt(size_t size,
			 void *wrapper,
			 int rep_size,
			 int rep_size_slot,
			 void *template)
{
  void **object;

  gc_teb_t gc_teb = current_gc_teb();

  update_allocation_counter(gc_teb, size, wrapper);

  do {
    int findex = 1;
    object = MMReserveObject(size, wrapper, gc_teb);
    object[0] = wrapper;
    object[rep_size_slot] = (void*)((rep_size << 2) + 1);
    memcpy(object + rep_size_slot + 1, template, rep_size << 2);
  }
  while(!MMCommitObject(object, size, gc_teb));
  

  return object;
}

RUN_TIME_API
void *primitive_copy(size_t size,
		     void *template)
{
  void **object;
  void *wrapper = ((void**)template)[0];

  gc_teb_t gc_teb = current_gc_teb();

  update_allocation_counter(gc_teb, size, wrapper);

  do {
    int findex = 1;
    object = MMReserveObject(size, wrapper, gc_teb);
    memcpy(object, template, size);
  }
  while(!MMCommitObject(object, size, gc_teb));
  
  return object;
}


/* Copy all but the repeated slots of a template */

RUN_TIME_API
void *primitive_copy_r(size_t size,
		       int rep_size,
		       int rep_size_slot,
		       void *template)
{
  void **object;
  void *wrapper = ((void**)template)[0];

  gc_teb_t gc_teb = current_gc_teb();

  update_allocation_counter(gc_teb, size, wrapper);

  do {
    int findex = 1;
    object = MMReserveObject(size, wrapper, gc_teb);
    memcpy(object, template, rep_size_slot << 2);
    object[rep_size_slot] = (void*)((rep_size << 2) + 1);
  }
  while(!MMCommitObject(object, size, gc_teb));
  

  return object;
}




unsigned MMCollectCount(void)
{
  gc_teb_t gc_teb = current_gc_teb();

  assert(gc_teb->gc_teb_inside_tramp);
#ifndef BOEHM_GC
  return (unsigned)mps_collections(space);
#else
  return 0;
#endif
}

MMError MMRegisterRootStatic(mps_root_t *rootp, void *base, void *limit)
{
#ifndef BOEHM_GC
  /* assert(gc_teb->gc_teb_inside_tramp); tramp not needed for root registration */
  return mps_root_create_fmt(rootp, space, MPS_RANK_EXACT,
                             MPS_RM_PROT, fmt_A->scan, base, limit);
#else
  return 0;
#endif
}

MMError MMRegisterRootImmut(mps_root_t *rootp, void *base, void *limit)
{
#ifndef BOEHM_GC
  /* assert(gc_teb->gc_teb_inside_tramp); tramp not needed for root registration */
  return mps_root_create_fmt(rootp, space, MPS_RANK_EXACT,
                             MPS_RM_CONST, fmt_A->scan, base, limit);
#else
  return 0;
#endif
}


/* Don't protect ambiguous roots. That's because they're used */
/* for managing low-level runtime data including the TEBs.    */
/* In particular, they might be referenced by the Dylan trap  */
/* handler which must not be allowed to recursively trap      */

MMError MMRegisterRootAmbig(mps_root_t *rootp, void *base, void *limit)
{
#ifndef BOEHM_GC
  size_t s = ((char *)limit - (char *)base) / sizeof(mps_addr_t);
  /* assert(gc_teb->gc_teb_inside_tramp); tramp not needed for root registration */
  return mps_root_create_table(rootp, space, MPS_RANK_AMBIG,
                               0, base, s);
#else
  return 0;
#endif
}

MMError MMRegisterRootExact(mps_root_t *rootp, void *base, void *limit)
{
#ifndef BOEHM_GC
  size_t s = ((char *)limit - (char *)base) / sizeof(mps_addr_t);
  /* assert(gc_teb->gc_teb_inside_tramp); tramp not needed for root registration */
  return mps_root_create_table_masked(rootp, space, MPS_RANK_EXACT,
				      MPS_RM_PROT, base, s, 3);
#else
  return 0;
#endif
}

void MMDeregisterRoot(mps_root_t root)
{
#ifndef BOEHM_GC
  if (root) {
    mps_root_destroy(root);
  }
#endif
}



void *dylan__malloc__ambig(size_t size)
{
  size_t new_size = size + 4;
  void *object = MMAllocMisc(new_size);

  MMRegisterRootAmbig(object, object, (char *)object + new_size);
  return (void *)((char *)object + 4);
}

/* This doesn't work yet -- results in GC anomaly; to be debugged 

   Nosa  Mar 15, 1999  */

void *dylan__malloc__exact(size_t size)
{
  size_t new_size = size + 4;
  void *object = MMAllocMisc(new_size);

  MMRegisterRootExact(object, object, (char *)object + new_size);
  return (void *)((char *)object + 4);
}

void dylan__free__root(void *object, size_t size)
{
  size_t new_size = size + 4;
  void *new_object = (void *)((char *)object - 4);

  MMDeregisterRoot(((void**)new_object)[0]);
  MMFreeMisc(new_object, new_size);
}



/* Root regsitration support for the interactive downloader       */
/* This doesn't need to remember the root                         */
/* It must not use MPS_RM_PROT (see the cottonwood release notes) */


MMError MMRootStatic(void *base, void *limit)
{
#ifndef BOEHM_GC
  mps_root_t root;
  return mps_root_create_fmt(&root, space, MPS_RANK_EXACT,
                             0, fmt_A->scan, base, limit);
#else
  return 0;
#endif
}

MMError MMRootImmut(void *base, void *limit)
{
  mps_root_t root;
  return  MMRegisterRootImmut(&root, base, limit);
}

MMError MMRootAmbig(void *base, void *limit)
{
#ifndef BOEHM_GC
  mps_root_t root;
  size_t s = ((char *)limit - (char *)base) / sizeof(mps_addr_t);
  return mps_root_create_table(&root, space, MPS_RANK_AMBIG,
                               0, base, s);
#else
  return 0;
#endif
}

MMError MMRootExact(void *base, void *limit)
{
#ifndef BOEHM_GC
  mps_root_t root;
  size_t s = ((char *)limit - (char *)base) / sizeof(mps_addr_t);
  return mps_root_create_table_masked(&root, space, MPS_RANK_EXACT,
				      0, base, s, 3);
#else
  return 0;
#endif
}


/* Support for MM control */

RUN_TIME_API
void primitive_mps_clamp()
{
#ifndef BOEHM_GC
  mps_space_clamp(space);
#endif
}

RUN_TIME_API
void primitive_mps_park()
{
#ifndef BOEHM_GC
  mps_space_park(space);
#endif
}

RUN_TIME_API
void primitive_mps_release()
{
#ifndef BOEHM_GC
  mps_space_release(space);
#endif
}

extern void display_stats_for_memory_usage ();

RUN_TIME_API
void primitive_mps_collect(BOOL display_stats)
{
#ifndef BOEHM_GC
  mps_space_collect(space);
  if (display_stats)
    display_stats_for_memory_usage();
#endif
}

RUN_TIME_API
size_t primitive_mps_committed()
{
#ifndef BOEHM_GC
  return mps_space_committed(space);
#else
  return 0;
#endif
}

RUN_TIME_API
void primitive_mps_begin_ramp_alloc()
{
#ifndef BOEHM_GC
  gc_teb_t gc_teb = current_gc_teb();
  mps_alloc_pattern_t pattern = mps_alloc_pattern_ramp();

  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_main_ap, pattern);
  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_leaf_ap, pattern);
  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_weak_awl_ap, pattern);
  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_exact_awl_ap, pattern);
#endif
}

RUN_TIME_API
void primitive_mps_end_ramp_alloc()
{
#ifndef BOEHM_GC
  gc_teb_t gc_teb = current_gc_teb();
  mps_alloc_pattern_t pattern = mps_alloc_pattern_ramp();

  mps_ap_alloc_pattern_end(gc_teb->gc_teb_main_ap, pattern);
  mps_ap_alloc_pattern_end(gc_teb->gc_teb_leaf_ap, pattern);
  mps_ap_alloc_pattern_end(gc_teb->gc_teb_weak_awl_ap, pattern);
  mps_ap_alloc_pattern_end(gc_teb->gc_teb_exact_awl_ap, pattern);
#endif
}

RUN_TIME_API
void primitive_mps_begin_ramp_alloc_all()
{
#ifndef BOEHM_GC
  gc_teb_t gc_teb = current_gc_teb();
  mps_alloc_pattern_t pattern = mps_alloc_pattern_ramp_collect_all();

  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_main_ap, pattern);
  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_leaf_ap, pattern);
  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_weak_awl_ap, pattern);
  mps_ap_alloc_pattern_begin(gc_teb->gc_teb_exact_awl_ap, pattern);
#endif
}

RUN_TIME_API
void primitive_mps_end_ramp_alloc_all()
{
#ifndef BOEHM_GC
  gc_teb_t gc_teb = current_gc_teb();
  mps_alloc_pattern_t pattern = mps_alloc_pattern_ramp_collect_all();

  mps_ap_alloc_pattern_end(gc_teb->gc_teb_main_ap, pattern);
  mps_ap_alloc_pattern_end(gc_teb->gc_teb_leaf_ap, pattern);
  mps_ap_alloc_pattern_end(gc_teb->gc_teb_weak_awl_ap, pattern);
  mps_ap_alloc_pattern_end(gc_teb->gc_teb_exact_awl_ap, pattern);
#endif
}


mps_message_t message;

RUN_TIME_API
void primitive_mps_enable_gc_messages()
{
#ifndef BOEHM_GC
  mps_message_type_enable(space, mps_message_type_gc());
#endif
}


RUN_TIME_API
BOOL primitive_mps_collection_stats(void** results)
{
#ifndef BOEHM_GC
  size_t live, condemned, not_condemned;

  if (mps_message_get(&message, space, mps_message_type_gc())) {

    live = mps_message_gc_live_size(space, message);
    condemned = mps_message_gc_condemned_size(space, message);
    not_condemned = mps_message_gc_not_condemned_size(space, message);

    mps_message_discard(space, message);
    
    results[0] =   (void*)((live << 2) + 1);
    results[1] = (void*)((condemned << 2) + 1);
    results[2] = (void*)((not_condemned << 2) + 1);
    return TRUE;
  }
  else
    return FALSE;
#else
  return FALSE;
#endif
}


/* Support for Finalization */


void primitive_mps_finalize(void *obj)
{
#ifndef NO_FINALIZATION
  mps_finalize(space, &obj);
#endif
}

void* primitive_mps_finalization_queue_first()
{
#ifdef NO_FINALIZATION
  return 0;
#else
  mps_message_t finalization_message;
  if (mps_message_get(&finalization_message, space, finalization_type))
    {
      mps_addr_t object_ref;
      mps_message_finalization_ref(&object_ref, space, finalization_message);
      mps_message_discard(space, finalization_message);
      return object_ref;
    }
  else
    return 0;
#endif
}

/* Support for Location Dependencies */

typedef struct d_hs_s      *d_hs_t;     /* Dylan Hash State */

typedef struct d_hs_s         /* Dylan Hash State object */
{
  void *dylan_wrapper;
  mps_ld_s internal_state;
} d_hs_s;



void primitive_mps_ld_reset(d_hs_t d_hs)
{
#ifndef BOEHM_GC
  mps_ld_t mps_ld = &(d_hs->internal_state);
  gc_teb_t gc_teb = current_gc_teb();
  assert(gc_teb->gc_teb_inside_tramp);
  mps_ld_reset(mps_ld, space);
#endif
}

void primitive_mps_ld_add(d_hs_t d_hs, mps_addr_t addr)
{
#ifndef BOEHM_GC
  mps_ld_t mps_ld = &(d_hs->internal_state);
  gc_teb_t gc_teb = current_gc_teb();
  assert(gc_teb->gc_teb_inside_tramp);
  mps_ld_add(mps_ld, space, addr);
#endif
}

mps_bool_t primitive_mps_ld_isstale(d_hs_t d_hs)
{
#ifndef BOEHM_GC

  mps_ld_t mps_ld = &(d_hs->internal_state);
  gc_teb_t gc_teb = current_gc_teb();
  assert(gc_teb->gc_teb_inside_tramp);
  return(mps_ld_isstale(mps_ld, space, 0));

#else

  return 0; /* Never stale */

#endif
}


void primitive_mps_ld_merge(d_hs_t d_into, d_hs_t d_obj)
{
#ifndef BOEHM_GC
  mps_ld_t into = &(d_into->internal_state);
  mps_ld_t addr = &(d_obj->internal_state);
  gc_teb_t gc_teb = current_gc_teb();
  assert(gc_teb->gc_teb_inside_tramp);
  mps_ld_merge(into, space, addr);
#endif
}



/* initialization and deinitialization */

void init_error (char* message)
{
  report_runtime_error("\nDylan runtime MPS initialization error: failed to ", message);
}



extern BOOL Prunning_under_dylan_debuggerQ;

/*
    The strategy at the moment for handling keyboard interrupts is merely
    to set a flag; the runtime will check this flag periodically (e.g. every
    time an attempt is made to heap-allocate an object) and signal a keyboard
    interrupt at that time. Provision is also made for applications to do their
    own polling of this flag, for example in a dedicated thread, if they so wish.
*/


BOOL WINAPI DylanBreakControlHandler(DWORD dwCtrlType)
{
  switch (dwCtrlType)
    {
    case CTRL_BREAK_EVENT:
    case CTRL_C_EVENT:
      {
	if (Prunning_under_dylan_debuggerQ == FALSE)
	  dylan_keyboard_interruptQ = TRUE;
	return TRUE;
      }
    
    default:
      return FALSE;
    }
}

MMError dylan_init_memory_manager()
{
  mps_res_t res;
  int max_heap_size = MAXIMUM_HEAP_SIZE;

  gc_teb_t gc_teb = current_gc_teb();

  if (Prunning_under_dylan_debuggerQ == FALSE)
    SetConsoleCtrlHandler(&DylanBreakControlHandler, TRUE);

  assert(!gc_teb->gc_teb_inside_tramp);
  assert(TARG_CHECK);

#ifndef BOEHM_GC
  res = mps_arena_create(&space, mps_arena_class_vm(), (size_t)max_heap_size);
  if(res) { init_error("create arena"); return(res); }

  fmt_A = dylan_fmt_A();    
  res = mps_fmt_create_A(&format, space, fmt_A);
  if(res) { init_error("create format"); return(res); }

#ifndef NO_WEAKNESS
  fmt_A_weak = dylan_fmt_A_weak();    
  res = mps_fmt_create_A(&dylan_fmt_weak, space, fmt_A_weak);
  if(res) { init_error("create weak format"); return(res); }
#endif

  res = mps_pool_create(&main_pool, space, mps_class_amc(), format);
  if(res) { init_error("create main pool"); return(res); }

#ifdef NO_LEAF_OBJECT
  leaf_pool = main_pool;
#else
  /* Create the Leaf Object pool */
  res = mps_pool_create(&leaf_pool, space, mps_class_amcz(), format);
  if(res) { init_error("create leaf pool"); return(res); }
#endif

#ifdef NO_WEAKNESS
  weak_table_pool = main_pool;
#else
  /* Create the Automatic Weak Linked pool */
  res = mps_pool_create(&weak_table_pool, space, mps_class_awl(), dylan_fmt_weak);
  if(res) { init_error("create weak pool"); return(res); }
#endif

  /* Create the MV pool for miscellaneous objects. */
  /* This is also used for wrappers. */
  res = mps_pool_create(&misc_pool, space, mps_class_mv(),
                        MISCEXTENDBY, MISCAVGSIZE, MISCMAXSIZE);
  if(res) { init_error("create misc pool"); return(res); }

  wrapper_pool = misc_pool;

#ifndef NO_FINALIZATION
  finalization_type = mps_message_type_finalization();
  mps_message_type_enable(space, finalization_type);
#endif

#ifdef TUNE_GEN0_FREQ
  AMCGen0Frequency = TUNE_GEN0_FREQ;
#endif

#endif

#ifdef BOEHM_GC
  /* Not required for the dll version of Boehm. */
  /* GC_init(); */ 

#ifdef MAX_BOEHM_HEAP_SIZE
  /* Only makes sense for a 128Mb machine. */
  GC_set_max_heap_size(MAX_BOEHM_HEAP_SIZE);
#endif

#ifdef INITIAL_BOEHM_HEAP_SIZE
  /* Call this to give an initial heap size hint. */
  GC_expand_hp(INITIAL_BOEHM_HEAP_SIZE);
#endif

  /* Call this to enable incrementality. This doesn't work with the MM GC. */
  /* GC_enable_incremental(); */
#endif

  InitializeCriticalSection(&reservoir_limit_set_lock);
  InitializeCriticalSection(&polling_threads_lock);

  if (Prunning_under_dylan_debuggerQ) {
    InitializeCriticalSection(&class_breakpoint_lock);
    class_breakpoint_events[0] = CreateEvent(NULL, FALSE, FALSE, NULL);
    class_breakpoint_events[1] = CreateEvent(NULL, FALSE, FALSE, NULL);
  }

  return(0);
  
}



void dylan_shut_down_memory_manager()
{
#ifndef BOEHM_GC

#ifndef NO_FINALIZATION
  while(primitive_mps_finalization_queue_first());
#endif
  mps_pool_destroy(misc_pool);
#ifndef NO_WEAKNESS
  mps_pool_destroy(weak_table_pool);
#endif
#ifndef NO_LEAF_OBJECT
  mps_pool_destroy(leaf_pool);
#endif
  mps_pool_destroy(main_pool);
#ifndef NO_WEAKNESS
  mps_fmt_destroy(dylan_fmt_weak);
#endif
  mps_fmt_destroy(format);
  mps_space_destroy(space);

#endif
}


#ifndef LINUX_PLATFORM

extern void dylan_main ();

int main ()
{
  dylan_main();
  return 0;
}

#endif
