reload_saved_string_length = 0;
read_command_line_options (argc, argv);
+#ifndef ENABLE_SMP
setup_memory ((BLOCKS_TO_BYTES (option_heap_size)),
(BLOCKS_TO_BYTES (option_stack_size)),
(BLOCKS_TO_BYTES (option_constant_size)));
+#else
+ setup_memory ((BLOCKS_TO_BYTES (option_heap_size)),
+ (BLOCKS_TO_BYTES (option_constant_size)),
+ option_processor_count,
+ (BLOCKS_TO_BYTES (option_processor_heap_size)),
+ (BLOCKS_TO_BYTES (option_stack_size)));
+ smp_initialize (option_processor_count);
+#endif
initialize_primitives ();
compiler_initialize (option_fasl_file != 0);
SCHEME_OBJECT * block_end = ((CC_BLOCK_ADDR_END (block)) - 1);
return
((((HEAP_ADDRESS_P (block)) && (HEAP_ADDRESS_P (block_end)))
+#ifdef ENABLE_SMP
+ || ((SHARED_HEAP_ADDRESS_P (block))
+ && (SHARED_HEAP_ADDRESS_P (block_end)))
+#endif
|| ((ADDRESS_IN_CONSTANT_P (block))
&& (ADDRESS_IN_CONSTANT_P (block_end))))
&& (ENVIRONMENT_P (*block_end)));
[Support native compiled code if available [[yes]]]))
: ${enable_native_code='yes'}
+AC_ARG_ENABLE([smp],
+ AS_HELP_STRING([--enable-smp],
+ [Support multi-processing if available [[no]]]))
+: ${enable_smp='no'}
+
AC_ARG_WITH([openssl],
AS_HELP_STRING([--with-openssl],
[Use OpenSSL crypto library if available [[yes]]]))
M4_FLAGS="${M4_FLAGS} -P VALGRIND_MODE,1"
fi
+dnl Check for pthreads.
+if test "${enable_smp}" != no; then
+ AC_CHECK_HEADER([pthread.h],
+ [
+ AC_DEFINE([ENABLE_SMP], [1],
+ [Define to 1 for Symmetric Multiple Processor support.])
+ CFLAGS="-pthread ${CFLAGS}"
+ LDFLAGS="-pthread ${LDFLAGS}"
+ M4_FLAGS="${M4_FLAGS} -P ENABLE_SMP,1"
+ ],
+ AC_MSG_ERROR([SMP support requires <pthread.h>]))
+fi
+
OPTIONAL_BASES="${OPTIONAL_BASES} cmpint cmpintmd comutl"
case ${mit_scheme_native_code} in
# define HEAP_FREE(address)
#endif
+#ifndef ENABLE_SMP
+#define __thread
+#endif
+
#endif /* SCM_CONFSHARED_H */
{
bool c = verify_heap_area ("constants", constant_start, constant_alloc_next);
bool h = verify_heap_area ("heap", heap_start, Free);
+#ifdef ENABLE_SMP
+ bool s = verify_heap_area ("shared heap",shared_heap_start,shared_heap_free);
+ return (c && h && s);
+#else
return (c && h);
+#endif
}
#else /* !ENABLE_DEBUGGING_TOOLS */
extern SCHEME_OBJECT * heap_alloc_limit;
extern SCHEME_OBJECT * heap_start;
extern SCHEME_OBJECT * heap_end;
+#ifdef ENABLE_SMP
+extern SCHEME_OBJECT * p0_heap_start;
+extern SCHEME_OBJECT * shared_heap_start;
+extern SCHEME_OBJECT * shared_heap_free;
+extern SCHEME_OBJECT * shared_heap_end;
+#endif
extern SCHEME_OBJECT * stack_pointer;
extern SCHEME_OBJECT * stack_guard;
extern struct obstack scratch_obstack;
extern struct obstack ffi_obstack;
-extern unsigned long n_heap_blocks;
-extern unsigned long n_constant_blocks;
-extern unsigned long n_stack_blocks;
-
extern SCHEME_OBJECT * memory_block_start;
extern SCHEME_OBJECT * memory_block_end;
/* Amount of space needed when GC requested */
extern unsigned long gc_space_needed;
+#ifdef ENABLE_SMP
+extern unsigned long gc_shared_space_needed;
+#endif
/* Number of new ephemerons requested from the GC. */
extern unsigned long n_ephemerons_requested;
extern bool object_in_constant_space_p (SCHEME_OBJECT);
extern SCHEME_OBJECT * copy_to_constant_space (SCHEME_OBJECT *, unsigned long);
+#ifndef ENABLE_SMP
extern void setup_memory (unsigned long, unsigned long, unsigned long);
+#else
+extern void setup_memory (unsigned long, unsigned long,
+ int, unsigned long, unsigned long);
+#endif
extern void reset_memory (void);
/* Utilities for primitives */
extern void termination_trap (void) NORETURN;
extern void termination_no_error_handler (void) NORETURN;
extern void termination_gc_out_of_space (void) NORETURN;
+#ifdef ENABLE_SMP
+extern void termination_gc_out_of_shared_space (void) NORETURN;
+#endif
extern void termination_eof (void) NORETURN;
extern void termination_signal (const char * signal_name) NORETURN;
#include "osio.h"
#include "osfile.h"
#include "osfs.h"
+#include "ossmp.h"
#define In_Fasdump
#include "gccode.h"
#include "trap.h"
static void finalize_fasl_header (unsigned long);
static bool write_fasl_file
(SCHEME_OBJECT *, SCHEME_OBJECT *, fasl_file_handle_t);
+
+#ifndef ENABLE_SMP
+#define HEAP_START heap_start
+#define HEAP_END heap_end
+#else
+#define HEAP_START shared_heap_start
+#define HEAP_END shared_heap_end
+#endif
\f
/* FASDUMP:
copy must have the global value cell of symbols set to UNBOUND.
Second, and worse, all the broken hearts created during the process
must be restored to their original values. This last is done by
- growing the copy of the object in the bottom of spare heap, keeping
- track of the locations of broken hearts and original contents at
- the top of the spare heap. */
+ keeping track of the locations of broken hearts and original
+ contents in a malloced/realloced array of fixup_ts. */
DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3,
"(OBJECT NAMESTRING FLAG)\n\
error_bad_range_arg (2);
transaction_record_action (tat_always, close_fasl_file, (&ff_info));
- open_tospace (heap_start);
+ open_tospace (HEAP_START);
/* This must be _before_ the call to initialize_fixups(): */
transaction_record_action (tat_abort, abort_fasdump, 0);
initialize_fixups ();
ok = ((write_fasl_header (fh, (ff_info . handle)))
&& (save_tospace (save_tospace_write, (&ff_info))));
+
transaction_commit (); /* 1 */
COMPARE_GC_VARS ();
static SCHEME_OBJECT * fasdump_saved_stack_guard;
static SCHEME_OBJECT * fasdump_saved_stack_start;
static SCHEME_OBJECT * fasdump_saved_stack_end;
+#ifdef ENABLE_SMP
+static SCHEME_OBJECT * fasdump_saved_shared_heap_free;
+static SCHEME_OBJECT * fasdump_saved_shared_heap_start;
+static SCHEME_OBJECT * fasdump_saved_shared_heap_end;
+#endif
static SCHEME_OBJECT * fasdump_saved_constant_alloc_next;
static SCHEME_OBJECT * fasdump_saved_constant_start;
static SCHEME_OBJECT * fasdump_saved_constant_end;
SAVE_GC_VAR (stack_guard);
SAVE_GC_VAR (stack_start);
SAVE_GC_VAR (stack_end);
+#ifdef ENABLE_SMP
+ SAVE_GC_VAR (shared_heap_free);
+ SAVE_GC_VAR (shared_heap_start);
+ SAVE_GC_VAR (shared_heap_end);
+#endif
SAVE_GC_VAR (constant_alloc_next);
SAVE_GC_VAR (constant_start);
SAVE_GC_VAR (constant_end);
COMPARE_GC_VAR (stack_guard);
COMPARE_GC_VAR (stack_start);
COMPARE_GC_VAR (stack_end);
+#ifdef ENABLE_SMP
+ COMPARE_GC_VAR (shared_heap_free);
+ COMPARE_GC_VAR (shared_heap_start);
+ COMPARE_GC_VAR (shared_heap_end);
+#endif
COMPARE_GC_VAR (constant_alloc_next);
COMPARE_GC_VAR (constant_start);
COMPARE_GC_VAR (constant_end);
fasdump_saved_heap_start,
((fasdump_saved_Free - fasdump_saved_heap_start)
* SIZEOF_SCHEME_OBJECT));
+#ifdef ENABLE_SMP
+ (void) mhash (ctx,
+ fasdump_saved_shared_heap_start,
+ ((fasdump_saved_shared_heap_free
+ - fasdump_saved_shared_heap_start)
+ * SIZEOF_SCHEME_OBJECT));
+#endif
return (mhash_end (ctx));
}
static
DEFINE_GC_HANDLER (handle_ephemeron)
{
- /* Count each one once by counting only if there is no borken heart. */
+ /* Count each one once by counting only if there is no broken heart. */
if (0 == (GC_PRECHECK_FROM (OBJECT_ADDRESS (object))))
dumped_ephemeron_count += 1;
return (gc_handle_unaligned_vector (scan, object));
Saves an image of the current world to the file NAMESTRING.\n\
When the file is reloaded, PROCEDURE is called with an argument of #F.")
{
- SCHEME_OBJECT * to = Free;
+ SCHEME_OBJECT * to;
SCHEME_OBJECT * prim_table_start;
SCHEME_OBJECT * c_code_table_start;
bool result;
CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
CHECK_ARG (2, STRING_P);
- Primitive_GC_If_Needed (5);
+#ifndef ENABLE_SMP
+ to = Free;
+ Primitive_GC_If_Needed (6);
+#else
+
+ ENTER_CRITICAL_SECTION ("band dump");
+
+ open_tospace (shared_heap_start);
+
+ initialize_weak_chain ();
+ ephemeron_count = 0;
+
+ std_gc_pt1 ();
+ std_gc_pt2 ();
+
+ to = shared_heap_free;
+
+ assert (Free == heap_start);
+ assert (SHARED_HEAP_AVAILABLE_P (6));
+#endif
initialize_fasl_header (true, true);
{
SCHEME_OBJECT comb;
to += (FASLHDR_C_CODE_TABLE_SIZE (fh));
#endif
- if (to > heap_end)
+ if (to > HEAP_END)
result = false;
else
{
export_c_code_table (c_code_table_start);
#endif
- (FASLHDR_HEAP_START (fh)) = heap_start;
+ (FASLHDR_HEAP_START (fh)) = HEAP_START;
(FASLHDR_HEAP_END (fh)) = prim_table_start;
(FASLHDR_CONSTANT_START (fh)) = constant_start;
(FASLHDR_CONSTANT_END (fh)) = constant_alloc_next;
#include "osscheme.h"
#include "osfile.h"
#include "osio.h"
+#include "ossmp.h"
#include "gccode.h"
#include "trap.h"
#include "option.h"
reset_allocator_parameters
((FASLHDR_CONSTANT_SIZE (fh)), (FASLHDR_HEAP_RESERVED (fh)));
+#ifdef ENABLE_SMP
+ reset_processor_allocator (self);
+#endif
/* We cleared the heap; the ephemeron array is now bogus. */
ephemeron_array = SHARP_F;
result = (load_file (handle, 0));
typedef void gc_abort_handler_t (void);
typedef bool gc_walk_proc_t (SCHEME_OBJECT *, SCHEME_OBJECT *, void *);
+#ifndef ENABLE_SMP
extern void initialize_gc
(unsigned long, SCHEME_OBJECT **, SCHEME_OBJECT **,
gc_tospace_allocator_t *, gc_abort_handler_t * NORETURN);
+#else
+extern void initialize_gc
+ (unsigned long, gc_tospace_allocator_t *, gc_abort_handler_t * NORETURN);
+#endif
extern void resize_tospace (unsigned long);
extern void open_tospace (SCHEME_OBJECT *);
*/
\f
#include "object.h"
-#include "outf.h"
+#include "extern.h"
#include "gccode.h"
/* For ephemeron layout. */
/* For memory advice. */
#include "ostop.h"
-static SCHEME_OBJECT ** p_fromspace_start;
-static SCHEME_OBJECT ** p_fromspace_end;
static gc_tospace_allocator_t * gc_tospace_allocator;
static gc_abort_handler_t * gc_abort_handler NORETURN;
static SCHEME_OBJECT * current_scan;
static SCHEME_OBJECT current_object;
+#ifndef ENABLE_SMP
+static SCHEME_OBJECT ** p_fromspace_start;
+static SCHEME_OBJECT ** p_fromspace_end;
+
#define ADDRESS_IN_FROMSPACE_P(addr) \
((((void *) (addr)) >= ((void *) (*p_fromspace_start))) \
&& (((void *) (addr)) < ((void *) (*p_fromspace_end))))
+#else /* ENABLE_SMP */
+
+#define ADDRESS_IN_FROMSPACE_P(addr) \
+ (((((void *) (addr)) >= ((void *) (p0_heap_start))) \
+ && (((void *) (addr)) < ((void *) (constant_start)))) \
+ || ((((void *) (addr)) >= ((void *) (shared_heap_start))) \
+ && (((void *) (addr)) < ((void *) (shared_heap_free)))))
+#endif
+
#define TOSPACE_TO_NEWSPACE(p) (((p) - tospace_start) + newspace_start)
#define NEWSPACE_TO_TOSPACE(p) (((p) - newspace_start) + tospace_start)
static SCHEME_OBJECT ephemeron_queue = SHARP_F;
static bool scanning_ephemerons_p = false;
-extern SCHEME_OBJECT ephemeron_array;
-extern unsigned long ephemeron_count;
-
static void queue_ephemerons_for_key (SCHEME_OBJECT *);
static SCHEME_OBJECT gc_transport_weak_pair (SCHEME_OBJECT);
static SCHEME_OBJECT gc_transport_ephemeron (SCHEME_OBJECT);
\f
void
initialize_gc (unsigned long n_words,
+#ifndef ENABLE_SMP
SCHEME_OBJECT ** pf_start,
SCHEME_OBJECT ** pf_end,
+#endif
gc_tospace_allocator_t * allocator,
gc_abort_handler_t * abort_handler NORETURN)
{
+#ifndef ENABLE_SMP
p_fromspace_start = pf_start;
p_fromspace_end = pf_end;
+#endif
gc_tospace_allocator = allocator;
gc_abort_handler = abort_handler;
CLOSE_TOSPACE ();
if (GC_NEEDED_P (gc_space_needed))
termination_gc_out_of_space ();
gc_space_needed = 0;
+#ifdef ENABLE_SMP
+ if (!SHARED_HEAP_AVAILABLE_P(gc_shared_space_needed))
+ termination_gc_out_of_shared_space ();
+ gc_shared_space_needed = 0;
+#endif
EXIT_CRITICAL_SECTION ({ SAVE_CONT (); });
break;
"prosterm"
"prostty"
"pruxsock" ;Misnamed, should be "prossock".
+"prossmp"
#include "gccode.h"
#include "osscheme.h"
#include "ostop.h"
+#include "ossmp.h"
#ifdef __WIN32__
extern void win32_allocate_registers (void);
static unsigned long saved_heap_size;
static unsigned long saved_constant_size;
-static unsigned long saved_stack_size;
+unsigned long saved_stack_size;
+#ifdef ENABLE_SMP
+int saved_processor_count;
+unsigned long saved_processor_heap_size;
+#endif
static gc_tospace_allocator_t allocate_tospace;
static gc_abort_handler_t abort_gc NORETURN;
static unsigned long compute_ephemeron_array_length (unsigned long);
+#ifndef ENABLE_SMP
+
/* Memory Allocation, sequential processor:
oo
initialize_gc (heap_size, (&heap_start), (&Free), allocate_tospace, abort_gc);
}
+#else /* ENABLE_SMP */
+
+/* Memory Allocation, multi-processor:
+
+ Machine variables, both thread-local & shared:
+oo ---------------- ---------------------------------
+ -------------------------
+ | To Space |
+ | |
+ ------------------------- <- to_space, malloced
+ . .
+ . .
+ . .
+ ------------------------- <- memory_block_end
+ | (Shared) Heap | & shared_heap_end
+ | |
+ | --------------------- | <- shared_heap_free
+ | /\ |
+ | || |
+ ------------------------- <- shared_heap_start
+ | Constant (& Pure) | & constant_end, moved by purify
+ | |
+ | -------------------- | <- constant_alloc_next
+ | /\ |
+ | || |
+ | || |
+ ------------------------- <- heap_end constant_start & pN->heap_end
+ | --------------------- | <- heap_alloc_limit
+ | |
+ | --------------------- | <- Free pN->heap_free
+ | /\ |
+ | ProcessorN Heap || |
+ ------------------------- <- heap_start pN->heap_start
+ ...
+ ------------------------- <- heap_end p0->heap_end & p1->heap_start
+ | --------------------- | <- heap_alloc_limit
+ | |
+ | --------------------- | <- Free p0->free_pointer
+ | /\ |
+ | Processor0 Heap || |
+ ------------------------- <- heap_start p0->heap_start & p0_heap_start
+ | ProcessorN Stack || | & pN->stack_end
+ | \/ |
+ | --------------------- | <- stack_pointer pN->stack_pointer
+ | |
+ | --------------------- | <- stack_guard
+ ------------------------- <- stack_start pN->stack_start
+ ...
+ ------------------------- <- p0->stack_end
+ | Processor0 Stack || |
+ | \/ |
+ | ----------------------| <- stack_pointer p0->stack_pointer
+ | |
+ | ----------------------| <- stack_guard
+ ------------------------- <- stack_start p0->stack_start
+0 & memory_block_start
+
+ Each area has a pointer to the next free word. For the stack it is
+ a pointer to the last word in use. */
+
+void
+setup_memory (unsigned long heap_size,
+ unsigned long constant_size,
+ int processor_count,
+ unsigned long processor_heap_size,
+ unsigned long stack_size)
+{
+ unsigned long total_size;
+ ALLOCATE_REGISTERS ();
+
+ if (heap_size == 0)
+ {
+ outf_fatal ("Invalid (zero) heap size.\n");
+ outf_flush_fatal ();
+ exit (1);
+ }
+ if (stack_size == 0)
+ {
+ outf_fatal ("Invalid (zero) stack size.\n");
+ outf_flush_fatal ();
+ exit (1);
+ }
+ if (processor_count == 0)
+ {
+ outf_fatal ("Invalid (zero) processor count.\n");
+ outf_flush_fatal ();
+ exit (1);
+ }
+
+ if (processor_heap_size == 0)
+ {
+ processor_heap_size = heap_size; /* / 2 / processor_count; ??? */
+ if (processor_heap_size < SIZEOF_SCHEME_OBJECT*1024*1024)
+ processor_heap_size = SIZEOF_SCHEME_OBJECT*1024*1024;
+ }
+ total_size = (heap_size + constant_size
+ + (processor_count * (stack_size + processor_heap_size)));
+
+ if (total_size >= DATUM_MASK)
+ {
+ outf_fatal ("Not enough heap addresses for this configuration.\n");
+ outf_flush_fatal ();
+ exit (1);
+ }
+
+ /* Allocate */
+ ALLOCATE_HEAP_SPACE (total_size, memory_block_start, memory_block_end);
+
+ if (memory_block_start == 0)
+ {
+ outf_fatal ("Not enough memory for this configuration.\n");
+ outf_flush_fatal ();
+ reset_memory ();
+ exit (1);
+ }
+
+ if ((ADDRESS_TO_DATUM (memory_block_end)) > DATUM_MASK)
+ {
+ outf_fatal ("Requested allocation is too large.\n");
+ outf_fatal ("Try again with a smaller argument to '--heap'.\n");
+ outf_flush_fatal ();
+ reset_memory ();
+ exit (1);
+ }
+
+ saved_heap_size = heap_size;
+ saved_stack_size = stack_size;
+ saved_constant_size = constant_size;
+ saved_processor_count = processor_count;
+ saved_processor_heap_size = processor_heap_size;
+ reset_allocator_parameters (0, 0);
+ initialize_gc (saved_heap_size, allocate_tospace, abort_gc);
+}
+#endif /* ENABLE_SMP */
+
void
reset_memory (void)
{
unsigned long n_reserved)
{
return
- ((memory_block_start
- + saved_stack_size
+ ((constant_start
+ n_constant + CONSTANT_SPACE_FUDGE
+ n_heap + ((n_reserved == 0) ? DEFAULT_HEAP_RESERVED : n_reserved))
< memory_block_end);
}
+#ifndef ENABLE_SMP
+
void
reset_allocator_parameters (unsigned long n_constant, unsigned long reserved)
{
STACK_RESET ();
}
+#else /* ENABLE_SMP */
+
+void
+reset_allocator_parameters (unsigned long n_constant, unsigned long reserved)
+{
+ heap_reserved = ((reserved == 0) ? DEFAULT_HEAP_RESERVED : reserved);
+ p0_heap_start = (memory_block_start
+ + saved_processor_count * saved_stack_size);
+ constant_start = (memory_block_start
+ + saved_processor_count * (saved_stack_size
+ + saved_processor_heap_size));
+ constant_alloc_next = constant_start;
+ constant_end = (constant_alloc_next + n_constant + CONSTANT_SPACE_FUDGE);
+ shared_heap_start = constant_end;
+ shared_heap_free = shared_heap_start;
+ shared_heap_end = memory_block_end;
+}
+
+void
+reset_processor_allocator (processor_t *p)
+{
+ /* All of these variables should be thread-local. */
+ gc_space_needed = 0;
+ gc_shared_space_needed = 0;
+ SET_STACK_LIMITS (p->stack_start, saved_stack_size);
+ heap_start = p->heap_start;
+ heap_end = p->heap_end;
+ Free = heap_start;
+
+ RESET_HEAP_ALLOC_LIMIT ();
+ INITIALIZE_STACK ();
+ STACK_RESET ();
+}
+
+#define FOR_EACH_PROCESSOR(stmt) do { \
+ processor_t *P = processors; \
+ while (P != NULL) \
+ { \
+ stmt; \
+ P = P->next; \
+ } \
+ } while (0)
+
+#endif
+
static void
allocate_tospace (unsigned long n_words,
SCHEME_OBJECT ** start_r, SCHEME_OBJECT ** end_r)
object_in_heap_p (SCHEME_OBJECT object)
{
SCHEME_OBJECT * address = (get_object_address (object));
- return ((address != 0) && (ADDRESS_IN_HEAP_P (address)));
+ return ((address != 0) && ((ADDRESS_IN_HEAP_P (address))
+#ifdef ENABLE_SMP
+ || (ADDRESS_IN_SHARED_HEAP_P (address))
+#endif
+ ));
}
\f
DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1,
STACK_CHECK_FATAL ("GC");
if (Free > heap_end)
{
+#ifndef ENABLE_SMP
outf_fatal ("\nGC has been delayed too long!\n");
+#else
+ outf_fatal ("\n;%d GC has been delayed too long!\n", self->id);
+#endif
outf_fatal
("Free = %#lx; heap_alloc_limit = %#lx; heap_end = %#lx\n",
((unsigned long) Free),
if (GC_Debug == true) verify_heap ();
#endif
+#ifndef ENABLE_SMP
+
open_tospace (heap_start);
+
+#else
+
+ open_tospace (shared_heap_start);
+
+#endif /* ENABLE_SMP */
+
initialize_weak_chain ();
ephemeron_count = 0;
saved_to = (get_newspace_ptr ());
add_to_tospace (fixed_objects);
+#ifndef ENABLE_SMP
add_to_tospace
(MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, history_register));
+#else
+ FOR_EACH_PROCESSOR
+ (add_to_tospace (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE,
+ P->history_register)));
+#endif
current_gc_table = (std_gc_table ());
+#ifndef ENABLE_SMP
gc_scan_oldspace (stack_pointer, stack_end);
+#else
+ FOR_EACH_PROCESSOR
+ (gc_scan_oldspace (P->stack_pointer, P->stack_end));
+#endif
gc_scan_oldspace (constant_start, constant_alloc_next);
gc_scan_tospace (saved_to, 0);
update_weak_pointers ();
}
+#ifndef ENABLE_SMP
+
+#define EPHEMERON_GC_NEEDED(length,n_ephemerons) \
+ !HEAP_AVAILABLE_P ((VECTOR_DATA + length) + (n_ephemerons * EPHEMERON_SIZE))
+
+#define SPACE_NEEDED gc_space_needed
+
+#define make_ephemeron_vector(length) (make_vector (length, SHARP_F, false))
+
+#else
+
+#define EPHEMERON_GC_NEEDED(length,n_ephemerons) \
+ !((HEAP_AVAILABLE_P (n_ephemerons * EPHEMERON_SIZE)) \
+ && SHARED_HEAP_AVAILABLE_P (VECTOR_DATA + length))
+
+#define SPACE_NEEDED gc_shared_space_needed
+
+static SCHEME_OBJECT
+make_ephemeron_vector (unsigned long length)
+{
+ SCHEME_OBJECT result;
+ result = (MAKE_POINTER_OBJECT (TC_VECTOR, shared_heap_free));
+ (*shared_heap_free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
+ while ((length--) > 0)
+ (*shared_heap_free++) = SHARP_F;
+ return (result);
+}
+#endif
+
void
std_gc_pt2 (void)
{
SCHEME_OBJECT * p = (get_newspace_ptr ());
(void) save_tospace (save_tospace_copy, 0);
+#ifndef ENABLE_SMP
Free = p;
+#else
+ shared_heap_free = p;
+ Free = heap_start;
+#endif
fixed_objects = (*saved_to++);
+#ifndef ENABLE_SMP
history_register = (OBJECT_ADDRESS (*saved_to++));
+#else
+ FOR_EACH_PROCESSOR
+ (P->history_register = (OBJECT_ADDRESS (*saved_to++)));
+ history_register = self->history_register;
+#endif
saved_to = 0;
{
unsigned long length
= (compute_ephemeron_array_length
(ephemeron_count + n_ephemerons_requested));
- if (!HEAP_AVAILABLE_P
- ((VECTOR_DATA + length) + (n_ephemerons_requested * EPHEMERON_SIZE)))
+ if (EPHEMERON_GC_NEEDED (length, n_ephemerons_requested))
{
if (ephemeron_request_hard_p)
- gc_space_needed += (VECTOR_DATA + length);
+ SPACE_NEEDED += (VECTOR_DATA + length);
length = (compute_ephemeron_array_length (ephemeron_count));
#ifdef ENABLE_GC_DEBUGGING_TOOLS
/* This should never trigger, because we discard the previous
ephemeron array, which always has room for at least as many
ephemerons as are now live. */
- if (!HEAP_AVAILABLE_P (VECTOR_DATA + length))
+ if (!SHARED_HEAP_AVAILABLE_P (VECTOR_DATA + length))
std_gc_death ("No room for ephemeron array");
#endif
}
- ephemeron_array = (make_vector (length, SHARP_F, false));
+ ephemeron_array = make_ephemeron_vector (length);
n_ephemerons_requested = 0;
ephemeron_request_hard_p = false;
}
if (!ephemeron_array_big_enough_p (n))
{
unsigned long length = (compute_ephemeron_array_length (n));
- assert (HEAP_AVAILABLE_P (VECTOR_DATA + length));
- ephemeron_array = (make_vector (length, SHARP_F, false));
+ assert (SHARED_HEAP_AVAILABLE_P (VECTOR_DATA + length));
+ ephemeron_array = make_ephemeron_vector (length);
}
}
\f
static void
-gc_if_needed_for_ephemeron (unsigned long extra_space)
+gc_if_needed_for_ephemeron (unsigned long table_space)
{
- if (GC_NEEDED_P (EPHEMERON_SIZE + extra_space))
+#ifndef ENABLE_SMP
+ if (GC_NEEDED_P (EPHEMERON_SIZE + table_space))
{
n_ephemerons_requested = 1;
ephemeron_request_hard_p = true;
Primitive_GC (EPHEMERON_SIZE);
}
+#else
+ if ((GC_NEEDED_P (EPHEMERON_SIZE))
+ || ((!SHARED_HEAP_AVAILABLE_P (table_space))
+ && (GC_ENABLED_P())))
+ {
+ n_ephemerons_requested = 1;
+ ephemeron_request_hard_p = true;
+ Primitive_GC (EPHEMERON_SIZE);
+ }
+#endif
}
DEFINE_PRIMITIVE ("MAKE-EPHEMERON", Prim_make_ephemeron, 2, 2, 0)
unsigned long length
= (compute_ephemeron_array_length (ephemeron_count));
gc_if_needed_for_ephemeron (VECTOR_DATA + length);
- ephemeron_array = (make_vector (length, SHARP_F, false));
+ ephemeron_array = (make_ephemeron_vector (length));
}
{
SCHEME_OBJECT * addr = Free;
#define HEAP_AVAILABLE \
((unsigned long) ((FREE_OK_P (Free)) ? (heap_alloc_limit - Free) : 0))
+#ifndef ENABLE_SMP
+# define SHARED_HEAP_AVAILABLE_P HEAP_AVAILABLE_P
+#else
+# define SHARED_HEAP_AVAILABLE_P(n_words) \
+ ((shared_heap_free + (n_words)) < shared_heap_end)
+# define SHARED_HEAP_AVAILABLE \
+ ((unsigned long) (shared_heap_end - shared_heap_free))
+#endif
+
#define FREE_OK_P(free) \
(((free) >= heap_start) && ((free) < heap_alloc_limit))
#define ADDRESS_IN_HEAP_P(address) \
(((address) >= heap_start) && ((address) < heap_end))
+#ifdef ENABLE_SMP
+#define ADDRESS_IN_SHARED_HEAP_P(address) \
+ (((address) >= shared_heap_start) && ((address) < shared_heap_end))
+#endif
+
#define ADDRESS_IN_STACK_P(address) \
(((address) >= stack_start) && ((address) < stack_end))
extern bool allocations_ok_p (unsigned long, unsigned long, unsigned long);
extern void reset_allocator_parameters (unsigned long, unsigned long);
+#ifdef ENABLE_SMP
+#include "ossmp.h"
+extern void reset_processor_allocator (processor_t *p);
+#endif
extern bool object_in_heap_p (SCHEME_OBJECT);
extern void std_gc_pt1 (void);
extern void std_gc_pt2 (void);
#define HEAP_ADDRESS_P(address) \
(((address) >= heap_start) && ((address) < Free))
+#ifdef ENABLE_SMP
+#define SHARED_HEAP_ADDRESS_P(address) \
+ (((address) >= shared_heap_start) && ((address) < shared_heap_free))
+#endif
#ifndef FLOATING_ALIGNMENT
# define FLOATING_ALIGNMENT 0
static const char * option_raw_heap;
static const char * option_raw_constant;
static const char * option_raw_stack;
+static const char * option_raw_processor_count;
+static const char * option_raw_processor_heap;
/* Command-line arguments */
int option_saved_argc;
unsigned long option_heap_size;
unsigned long option_constant_size;
unsigned long option_stack_size;
+int option_processor_count;
+unsigned long option_processor_heap_size;
\f
void
print_help (void)
#ifndef STACK_SIZE_VARIABLE
# define STACK_SIZE_VARIABLE "MITSCHEME_STACK_SIZE"
#endif
+
+#ifndef PROCESSORS_VARIABLE
+# define PROCESSORS_VARIABLE "MITSCHEME_PROCESSORS"
+#endif
+
+#ifndef PROCESSOR_HEAP_SIZE_VARIABLE
+# define PROCESSOR_HEAP_SIZE_VARIABLE "MITSCHEME_PROCESSOR_HEAP_SIZE"
+#endif
\f
static int
string_compare_ci (const char * string1, const char * string2)
option_argument ("silent", false, (&option_batch_mode));
option_argument ("stack", true, (&option_raw_stack));
option_argument ("version", false, (&option_show_version));
+ option_argument ("processors", true, (&option_raw_processor_count));
+ option_argument ("processor-heap", true, (&option_raw_processor_heap));
/* These are deprecated: */
option_argument ("compiler", false, 0);
outf_fatal (" %s size: %d\n", name, value);
}
+static void
+describe_number_option (const char * name, unsigned int value)
+{
+ outf_fatal (" number of %s: %d\n", name, value);
+}
+
static void
describe_path_option (const char * name, const char ** value)
{
describe_boolean_option ("force interactive", option_force_interactive);
describe_boolean_option ("disable core dump", option_disable_core_dump);
describe_boolean_option ("suppress noise", option_batch_mode);
+ describe_number_option ("processors", option_processor_count);
+ describe_size_option ("processor heap", option_processor_heap_size);
if (option_unused_argc == 0)
outf_fatal (" no unused arguments\n");
else
option_raw_stack,
STACK_SIZE_VARIABLE,
DEFAULT_STACK_SIZE));
+ option_processor_count
+ = (standard_numeric_option ("processors",
+ option_raw_processor_count,
+ PROCESSORS_VARIABLE,
+ 1));
+ option_processor_heap_size
+ = (standard_numeric_option ("processor-heap",
+ option_raw_processor_heap,
+ PROCESSOR_HEAP_SIZE_VARIABLE,
+ 0));
if (option_show_version)
{
outf_console ("%s\n", PACKAGE_STRING);
extern unsigned long option_heap_size;
extern unsigned long option_constant_size;
extern unsigned long option_stack_size;
+extern int option_processor_count;
+extern unsigned long option_processor_heap_size;
extern void read_command_line_options (int argc, const char ** argv);
pc_location = pc_in_heap;
block_address = (find_block_address (((void *) pc), heap_start));
}
+ else if ((((ULONG)shared_heap_start) <= pc)&&(pc < ((ULONG)shared_heap_end)))
+ {
+ pc_location = pc_in_heap;
+ block_address = (find_block_address (((void *) pc), shared_heap_start));
+ }
else if ((((ULONG) constant_start) <= pc) && (pc < ((ULONG) constant_end)))
{
pc_location = pc_in_heap;
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+#ifndef SCM_OSSMP_H
+#define SCM_OSSMP_H
+
+#include "config.h"
+
+#ifdef ENABLE_SMP
+
+typedef enum {
+ PROCESSOR_NEW,
+ PROCESSOR_RUNNING,
+ PROCESSOR_PAUSED,
+ PROCESSOR_DEAD
+} processor_state_t;
+
+typedef struct processor processor_t;
+
+struct processor {
+ struct processor *next;
+ char id;
+ processor_state_t state;
+ pthread_t pthread;
+ SCHEME_OBJECT * stack_end;
+ SCHEME_OBJECT * stack_start;
+ SCHEME_OBJECT * heap_end;
+ SCHEME_OBJECT * heap_start;
+ /* The values of the thread-local Free, stack_pointer and
+ history_register are copied here when entering the GC-WAIT
+ state, and copied back when gc_finished. */
+ SCHEME_OBJECT * stack_pointer;
+ SCHEME_OBJECT * free_pointer;
+ SCHEME_OBJECT * history_register;
+};
+
+extern processor_t *processors;
+extern __thread processor_t *self;
+
+extern void smp_initialize (int processor_count);
+#endif
+
+#endif /* SCM_OSSMP_H */
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Primitives for "symmetric multi-processing". */
+
+#include "prims.h"
+
+#ifdef ENABLE_SMP
+
+#include "history.h"
+#include "osio.h"
+#include "ossmp.h"
+#include <pthread.h>
+
+/* The chain of processors, starting with processor0 -- main()'s thread: */
+processor_t *processors;
+
+/* The mutex that serializes thread switches. */
+static pthread_mutex_t thread_mutex = PTHREAD_MUTEX_INITIALIZER;
+
+/* The current pthread's processor. */
+__thread processor_t *self;
+
+extern int saved_processor_count;
+extern int saved_processor_heap_size;
+extern int saved_stack_size;
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+
+static bool smp_trace_p = false;
+
+static void
+trace (const char * format, ...)
+{
+ va_list args;
+ va_start (args, format);
+ if (smp_trace_p == true)
+ voutf_error_line (format, args);
+ va_end (args);
+}
+
+#else
+
+#define trace(...) do {} while (false)
+
+#endif
+
+#endif
+
+DEFINE_PRIMITIVE ("SMP-ID", Prim_smp_id, 0, 0, "(SMP-ID)\n\
+A fixnum identifying the current processor.")
+{
+ PRIMITIVE_HEADER (0);
+#ifdef ENABLE_SMP
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (self->id));
+#else
+ PRIMITIVE_RETURN (FIXNUM_ZERO);
+#endif
+}
+
+DEFINE_PRIMITIVE ("SMP-COUNT", Prim_smp_count, 0, 0, "(SMP-COUNT)\n\
+The number of concurrently running Symmetric Multi-Processors.")
+{
+ PRIMITIVE_HEADER (0);
+#ifdef ENABLE_SMP
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (saved_processor_count));
+#else
+ PRIMITIVE_RETURN (SHARP_F);
+#endif
+}
+
+DEFINE_PRIMITIVE ("SMP-LOCK-THREADS", Prim_smp_lock_threads, 1, 1,
+ "(SMP-LOCK-THREADS LOCK?)\n\
+When LOCK? is #F/non-#F, unlock/lock the pthread mutex serializing\n\
+thread switches.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+#ifdef ENABLE_SMP
+ SCHEME_OBJECT which = ARG_REF (1);
+ if (which == SHARP_F)
+ {
+ int ret;
+
+ ret = pthread_mutex_unlock (&thread_mutex);
+ if (ret != 0)
+ error_external_return ();
+ }
+ else
+ {
+ int ret = pthread_mutex_lock (&thread_mutex);
+ if (ret != 0)
+ error_external_return ();
+ }
+#endif
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+#ifdef ENABLE_SMP
+
+static void make_processors (int);
+
+void
+smp_initialize (int count)
+{
+ make_processors (count-1);
+
+ self = processors;
+ assert (self->id == 0);
+ self->pthread = pthread_self ();
+ /* assert (C_Stack_Pointer == NULL); */
+ reset_processor_allocator (self);
+ RESET_HISTORY ();
+}
+
+static void *
+work (void *p)
+{
+ SCHEME_OBJECT expr;
+ self = (processor_t *)p;
+ trace (";%d Start.", self->id);
+ assert (self->id != 0);
+ assert (self != processors);
+ reset_processor_allocator (self);
+ RESET_HISTORY ();
+
+ /* expr: (SMP-PAUSE) */
+ expr = (MAKE_POINTER_OBJECT (TC_COMBINATION, Free));
+ (*Free++) = MAKE_OBJECT (TC_MANIFEST_VECTOR, 1);
+ (*Free++) = make_primitive ("SMP-PAUSE", 0);
+
+ /* Setup registers */
+ INITIALIZE_INTERRUPTS (0);
+ SET_ENV (THE_GLOBAL_ENV);
+ trapping = false;
+
+ /* Give the interpreter something to chew on, and ... */
+ Will_Push (CONTINUATION_SIZE);
+ SET_RC (RC_END_OF_COMPUTATION);
+ SET_EXP (SHARP_F);
+ SAVE_CONT ();
+ Pushed ();
+
+ SET_EXP (expr);
+
+ /* Go to it! */
+ gc_space_needed = 0;
+ gc_shared_space_needed = 0;
+
+ Interpret (0);
+
+ trace (";%d Died.", self->id);
+ self->state = PROCESSOR_DEAD;
+ return (NULL);
+}
+
+static void
+make_processors (int id)
+{
+ SCHEME_OBJECT *stack_start, *heap_start;
+ processor_t *new;
+
+ trace (";%d Setup.", id);
+ new = malloc (sizeof (processor_t));
+ if (new == NULL)
+ {
+ outf_fatal ("\n;%d could not malloc processor_t\n", id);
+ outf_flush_fatal ();
+ Microcode_Termination (TERM_NO_SPACE);
+ }
+ stack_start = memory_block_start + id * saved_stack_size;
+ heap_start = memory_block_start + (saved_processor_count * saved_stack_size
+ + id * saved_processor_heap_size);
+ new->next = processors;
+ new->id = id;
+ new->state = PROCESSOR_NEW;
+ new->stack_start = stack_start;
+ new->stack_end = stack_start + saved_stack_size;
+ new->heap_start = heap_start;
+ new->heap_end = heap_start + saved_processor_heap_size;
+ processors = new;
+
+ if (id != 0)
+ {
+ int err = pthread_create (&new->pthread, NULL, &work, new);
+ if (err)
+ {
+ outf_fatal ("pthread_create failed: %d\n", err);
+ outf_flush_fatal ();
+ exit (1);
+ }
+ }
+
+ trace (";%d heap: 0x%0lx-0x%0lx", id,
+ (ulong)new->heap_start, (ulong)new->heap_end);
+ trace (";%d stack: 0x%0lx-0x%0lx", id,
+ (ulong)new->stack_start, (ulong)new->stack_end);
+
+ if (id > 0)
+ make_processors (id - 1);
+}
+#endif
+
+DEFINE_PRIMITIVE ("SMP-PAUSE", Prim_smp_pause, 0, 0, "(SMP-PAUSE)\n\
+Pause a new processor.")
+{
+ PRIMITIVE_HEADER (0);
+#ifdef ENABLE_SMP
+ assert (self->id != 0);
+ self->state = PROCESSOR_PAUSED;
+ OS_pause ();
+ self->state = PROCESSOR_RUNNING;
+#else
+ signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
+#endif
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
/* Copy objects into constant/pure space. */
#include "scheme.h"
+#include "ossmp.h"
#include "prims.h"
#include "gccode.h"
+#ifndef ENABLE_SMP
+#define HEAP_START heap_start
+#define HEAP_END heap_end
+#else
+#define HEAP_START shared_heap_start
+#define HEAP_END shared_heap_end
+#endif
+
static void purify (SCHEME_OBJECT);
\f
/* Purify increases the size of constant space at the expense of the
open_tospace (constant_alloc_next);
initialize_weak_chain ();
+ ephemeron_count = 0;
start_copy = (get_newspace_ptr ());
add_to_tospace (object);
constant_alloc_next = new_constant_alloc_next;
constant_end = heap_copy_start;
- heap_start = constant_end;
+ HEAP_START = constant_end;
std_gc_pt2 ();
- resize_tospace (heap_end - heap_start);
+ resize_tospace (HEAP_END - HEAP_START);
}
/* strict limit for Free */
SCHEME_OBJECT * heap_alloc_limit;
-/* limits of active heap */
+#ifdef ENABLE_SMP
+/* the start of From space */
+SCHEME_OBJECT * p0_heap_start;
+
+/* limits of shared heap */
+SCHEME_OBJECT * shared_heap_start;
+SCHEME_OBJECT * shared_heap_end;
+
+/* next free word in the shared heap */
+SCHEME_OBJECT * shared_heap_free;
+#endif
+
+/* limits of local heap */
SCHEME_OBJECT * heap_start;
SCHEME_OBJECT * heap_end;
bool trapping;
-unsigned long n_heap_blocks;
-unsigned long n_constant_blocks;
-unsigned long n_stack_blocks;
SCHEME_OBJECT * memory_block_start;
SCHEME_OBJECT * memory_block_end;
/* Amount of space needed when GC requested */
unsigned long gc_space_needed;
+#ifdef ENABLE_SMP
+unsigned long gc_shared_space_needed;
+#endif
/* Number of new ephemerons requested from the GC. */
unsigned long n_ephemerons_requested;
{
PRIMITIVE_HEADER (0);
{
+#ifdef ENABLE_SMP
+ SCHEME_OBJECT v = (make_vector (15, SHARP_F, true));
+#else
SCHEME_OBJECT v = (make_vector (12, SHARP_F, true));
+#endif
VECTOR_SET (v, 0, (ULONG_TO_FIXNUM (sizeof (SCHEME_OBJECT))));
VECTOR_SET (v, 1, (CONVERT_ADDRESS (constant_start)));
VECTOR_SET (v, 2, (CONVERT_ADDRESS (constant_alloc_next)));
VECTOR_SET (v, 9, (CONVERT_ADDRESS (stack_pointer)));
VECTOR_SET (v, 10, (CONVERT_ADDRESS (stack_guard)));
VECTOR_SET (v, 11, (CONVERT_ADDRESS (stack_end)));
+#ifdef ENABLE_SMP
+ VECTOR_SET (v, 12, (CONVERT_ADDRESS (shared_heap_start)));
+ VECTOR_SET (v, 13, (CONVERT_ADDRESS (shared_heap_free)));
+ VECTOR_SET (v, 14, (CONVERT_ADDRESS (shared_heap_end)));
+#endif
PRIMITIVE_RETURN (v);
}
}
termination_suffix_trace (TERM_GC_OUT_OF_SPACE);
}
+#ifdef ENABLE_SMP
+void
+termination_gc_out_of_shared_space (void)
+{
+ termination_prefix (TERM_GC_OUT_OF_SPACE);
+ outf_fatal ("You are out of shared heap at the end of a garbage collection!\n");
+ outf_fatal
+ ("shared_heap_free = %#lx; shared_heap_end = %#lx\n",
+ ((unsigned long) shared_heap_free),
+ ((unsigned long) shared_heap_end));
+ outf_fatal ("# words needed = %lu; # words available = %lu\n",
+ gc_shared_space_needed, SHARED_HEAP_AVAILABLE);
+ termination_suffix_trace (TERM_GC_OUT_OF_SPACE);
+}
+#endif
+
void
termination_eof (void)
{
= ((error_code <= MAX_ERROR)
? (Error_Names[error_code])
: 0);
+#ifndef ENABLE_SMP
if (message == 0)
outf (where, "Unknown error code %#lx.\n", error_code);
else
outf (where, "Error code %#lx (%s).\n", error_code, message);
+#else /* ENABLE_SMP */
+ if (message == 0)
+ outf (where, ";%d Unknown error code %#lx.\n", self->id, error_code);
+ else
+ outf (where, ";%d Error code %#lx (%s).\n", self->id, error_code, message);
+#endif
}
long death_blow;
#ifdef ENABLE_DEBUGGING_TOOLS
err_print (error_code, ERROR_OUTPUT);
+#ifndef ENABLE_SMP
if ((GET_RC == RC_INTERNAL_APPLY)
|| (GET_RC == RC_INTERNAL_APPLY_VAL))
{
}
Print_Return ("Return code");
outf_error ("\n");
+#else /* ENABLE_SMP */
+ if ((GET_RC == RC_INTERNAL_APPLY)
+ || (GET_RC == RC_INTERNAL_APPLY_VAL))
+ {
+ outf_error (";%d Procedure: ", self->id);
+ Print_Expression (STACK_REF(CONTINUATION_SIZE + STACK_ENV_FUNCTION), "");
+ outf_error ("\n");
+ {
+ int i;
+ int nargs = (APPLY_FRAME_HEADER_N_ARGS
+ (STACK_REF (CONTINUATION_SIZE + STACK_ENV_HEADER)));
+ for (i = 0; i < nargs; i++)
+ {
+ outf_error (";%d Argument %d: ", self->id, i+1);
+ Print_Expression ((STACK_REF(CONTINUATION_SIZE
+ + STACK_ENV_FIRST_ARG + i)), "");
+ outf_error ("\n");
+ }
+ }
+ }
+ else
+ {
+ outf_error (";%d Expression: ", self->id);
+ Print_Expression (GET_EXP, "");
+ outf_error ("\n");
+ outf_error (";%d Environment: ", self->id);
+ Print_Expression (GET_ENV, "");
+ outf_error ("\n");
+ }
+ outf_error (";%d Return code", self->id);
+ Print_Return ("");
+#endif /* ENABLE_SMP */
#endif
if (Trace_On_Error)
extern const char * find_signal_name (int);
extern void UX_dump_core (void);
-extern void * initial_C_stack_pointer;
\f
struct ux_sig_code_desc
{
enum pc_location
{
pcl_heap,
+#ifdef ENABLE_SMP
+ pcl_shared_heap,
+#endif
pcl_constant,
pcl_builtin,
pcl_utility,
#ifdef CC_SUPPORT_P
static SCHEME_OBJECT * find_heap_address (unsigned long);
+#ifdef ENABLE_SMP
+ static SCHEME_OBJECT * find_shared_heap_address (unsigned long);
+#endif
static SCHEME_OBJECT * find_constant_address (unsigned long);
# ifdef ENABLE_TRAP_RECOVERY
static SCHEME_OBJECT * find_block_address (unsigned long, SCHEME_OBJECT *);
{
unsigned long pc = (SIGCONTEXT_PC (scp));
SCHEME_OBJECT primitive = GET_PRIMITIVE;
- SCHEME_OBJECT * block_addr;
- unsigned int index;
+ SCHEME_OBJECT * block_addr = NULL;
+ unsigned int index = 0;
SCHEME_OBJECT * new_sp = 0;
struct trap_recovery_info recovery_info;
break;
case pcl_heap:
+#ifdef ENABLE_SMP
+ case pcl_shared_heap:
+#endif
case pcl_constant:
#ifdef CC_SUPPORT_P
return (find_block_address (pc, heap_start));
}
+#ifdef ENABLE_SMP
+static SCHEME_OBJECT *
+find_shared_heap_address (unsigned long pc)
+{
+ return (find_block_address (pc, shared_heap_start));
+}
+#endif
+
static SCHEME_OBJECT *
find_constant_address (unsigned long pc)
{
return (0);
}
+#ifdef ENABLE_SMP
+static SCHEME_OBJECT *
+find_shared_heap_address (unsigned long pc)
+{
+ return (0);
+}
+#endif
+
static SCHEME_OBJECT *
find_constant_address (unsigned long pc)
{
unsigned int * r_index)
{
#ifdef CC_SUPPORT_P
+ enum pc_location type = pcl_unknown;
+ SCHEME_OBJECT * block_addr = NULL;
+
if (PC_ALIGNED_P (pc))
{
if (HEAP_ADDRESS_P ((SCHEME_OBJECT *) pc))
{
- SCHEME_OBJECT * block_addr = (find_heap_address (pc));
- if (block_addr == 0)
- return (pcl_unknown);
- if (r_block_addr != 0)
- (*r_block_addr) = block_addr;
- return (pcl_heap);
+ block_addr = (find_heap_address (pc));
+ type = pcl_heap;
}
- if (ADDRESS_IN_CONSTANT_P ((SCHEME_OBJECT *) pc))
+#ifdef ENABLE_SMP
+ else if (SHARED_HEAP_ADDRESS_P ((SCHEME_OBJECT *) pc))
{
- SCHEME_OBJECT * block_addr = (find_constant_address (pc));
- if (block_addr == 0)
- return (pcl_unknown);
- if (r_block_addr != 0)
- (*r_block_addr) = block_addr;
- return (pcl_constant);
+ block_addr = (find_shared_heap_address (pc));
+ type = pcl_shared_heap;
}
- if (ADDRESS_UCODE_P (pc))
+#endif
+ else if (ADDRESS_IN_CONSTANT_P ((SCHEME_OBJECT *) pc))
+ {
+ block_addr = (find_constant_address (pc));
+ type = pcl_constant;
+ }
+ else if (ADDRESS_UCODE_P (pc))
{
int index = (pc_to_builtin_index (pc));
if (index >= 0)
if ((OBJECT_TYPE (GET_PRIMITIVE)) == TC_PRIMITIVE)
return (pcl_primitive);
}
+
+ if (r_block_addr != 0)
+ (*r_block_addr) = block_addr;
+ return (type);
}
#else
if ((ADDRESS_UCODE_P (pc))
n += Find_In_Area("Constant Space",
constant_start, constant_alloc_next, Obj,
Find_Mode, print_p, store_p);
+#ifndef ENABLE_SMP
n += Find_In_Area("the Heap",
heap_start, Saved_Free, Obj,
Find_Mode, print_p, store_p);
+#else
+ n += Find_In_Area("the local Heap",
+ heap_start, Saved_Free, Obj,
+ Find_Mode, print_p, store_p);
+ n += Find_In_Area("the shared Heap",
+ shared_heap_start, shared_heap_free, Obj,
+ Find_Mode, print_p, store_p);
+#endif
n += Find_In_Area("the Stack",
stack_pointer, stack_end, Obj,
Find_Mode, print_p, store_p);
(lambda ()
(call-with-current-continuation
(lambda (continuation)
- ;; GC cannot be allowed before the fixed-objects-vector
- ;; is reset after restoring.
- (with-absolutely-no-interrupts
- (lambda ()
- (let ((fixed-objects (get-fixed-objects-vector)))
- ((ucode-primitive call-with-current-continuation)
- (lambda (restart)
- (with-interrupt-mask interrupt-mask/gc-ok
- (lambda (interrupt-mask)
- interrupt-mask
- (gc-flip)
- (do ()
- (((ucode-primitive dump-band) restart filename))
- (with-simple-restart 'RETRY "Try again."
- (lambda ()
- (error "Disk save failed:" filename))))
- (continuation
- (lambda ()
- (set! time-world-saved time)
- (if (string? id) unspecific #f)))))))
- ((ucode-primitive set-fixed-objects-vector!) fixed-objects))))
+ (if (implemented-primitive-procedure?
+ (ucode-primitive smp-count 0))
+ (smp-drop-band continuation filename id time)
+ (drop-band continuation filename id time))
(read-microcode-tables!)
(lambda ()
(set! time-world-saved time)
(else
(event-distributor/invoke! event:after-restart)
#t))))))))))
+
+(define (drop-band continuation filename id time)
+ ;; GC cannot be allowed before the fixed-objects-vector
+ ;; is reset after restoring.
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let ((fixed-objects (get-fixed-objects-vector)))
+ ((ucode-primitive call-with-current-continuation)
+ (lambda (restart)
+ (with-interrupt-mask interrupt-mask/gc-ok
+ (lambda (interrupt-mask)
+ interrupt-mask
+ (gc-flip)
+ (do ()
+ (((ucode-primitive dump-band) restart filename))
+ (with-simple-restart 'RETRY "Try again."
+ (lambda ()
+ (error "Disk save failed:" filename))))
+ (continuation
+ (lambda ()
+ (set! time-world-saved time)
+ (if (string? id) unspecific #f)))))))
+ ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))))
+
+(define (smp-drop-band continuation filename id time)
+ ;; Just like drop-band, except dump-band starts the flip
+ ;; and RESTART will finish it as well as restore the
+ ;; fixed-objects.
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let ((fixed-objects (get-fixed-objects-vector)))
+ (define-integrable (trigger-primitive-gc-daemons!)
+ ((vector-ref fixed-objects #x0B)))
+ ((ucode-primitive call-with-current-continuation)
+ (lambda (restart)
+ (do ()
+ (((ucode-primitive dump-band) restart filename))
+ (trigger-primitive-gc-daemons!)
+ (with-interrupt-mask interrupt-mask/gc-ok
+ (lambda (interrupt-mask)
+ interrupt-mask
+ (with-simple-restart 'RETRY "Try again."
+ (lambda ()
+ (error "Disk save failed:" filename))))))
+ (continuation
+ (lambda ()
+ (trigger-primitive-gc-daemons!)
+ (set! time-world-saved time)
+ (if (string? id) unspecific #f)))))
+ ((ucode-primitive set-fixed-objects-vector!) fixed-objects)
+ (trigger-primitive-gc-daemons!)))))
\f
(define (disk-restore #!optional filename)
;; Force order of events -- no need to run event:before-exit if
projects / mit-scheme.git / commitdiff