/* Returns NULL on failure; errno set */
static void *
my_mmap (void *addr, W_ size, int operation)
{
void *ret;
#if darwin_HOST_OS
// Without MAP_FIXED, Apple's mmap ignores addr.
// With MAP_FIXED, it overwrites already mapped regions, whic
// mmap(0, ... MAP_FIXED ...) is worst of all: It unmaps the program text
// and replaces it with zeroes, causing instant death.
// This behaviour seems to be conformant with IEEE Std 1003.1-2001.
// Let's just use the underlying Mach Microkernel calls directly,
// they're much nicer.
kern_return_t err = 0;
ret = addr;
if(operation & MEM_RESERVE)
{
if(addr) // try to allocate at address
err = vm_allocate(mach_task_self(),(vm_address_t*) &ret,
size, false);
if(!addr || err) // try to allocate anywhere
err = vm_allocate(mach_task_self(),(vm_address_t*) &ret,
size, true);
}
if(err) {
// don't know what the error codes mean exactly, assume it's
// not our problem though.
errorBelch("memory allocation failed (requested %" FMT_Word " bytes)",
size);
stg_exit(EXIT_FAILURE);
}
if(operation & MEM_COMMIT) {
vm_protect(mach_task_self(), (vm_address_t)ret, size, false,
VM_PROT_READ|VM_PROT_WRITE);
}
#else
int prot, flags;
if (operation & MEM_COMMIT)
prot = PROT_READ | PROT_WRITE;
else
prot = PROT_NONE;
if (operation == MEM_RESERVE)
# if defined(MAP_NORESERVE)
flags = MAP_NORESERVE;
# else
# ifdef USE_LARGE_ADDRESS_SPACE
# error USE_LARGE_ADDRESS_SPACE needs MAP_NORESERVE
# endif
errorBelch("my_mmap(,,MEM_RESERVE) not supported on this platform");
# endif
else if (operation == MEM_COMMIT)
void
OutOfHeapHook (W_ request_size, W_ heap_size) /* both sizes in bytes */
{
/* fprintf(stderr, "Heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse `+RTS -H<size>' to increase the total heap size.\n", */
(void)request_size; /* keep gcc -Wall happy */
if (heap_size > 0) {
errorBelch("Heap exhausted;\nCurrent maximum heap size is %" FMT_Word " bytes (%" FMT_Word " MB);\nuse `+RTS -M<size>' to increase it.",
heap_size, heap_size / (1024*1024));
} else {
errorBelch("out of memory");
}
}
/* Hack: we assume that we're building a batch-mode system unless
* INTERPRETER is set
*/
#ifndef INTERPRETER /* Hack */
static void real_main(void)
{
int exit_status;
SchedulerStatus status;
/* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */
startupHaskell(progargc,progargv,NULL);
/* kick off the computation by creating the main thread with a pointer
to mainIO_closure representing the computation of the overall program;
then enter the scheduler with this thread and off we go;
the same for GranSim (we have only one instance of this code)
in a parallel setup, where we have many instances of this code
running on different PEs, we should do this only for the main PE
(IAmMainThread is set in startupHaskell)
*/
/* ToDo: want to start with a larger stack size */
{
Capability *cap = rts_lock();
cap = rts_evalLazyIO(cap,progmain_closure, NULL);
status = rts_getSchedStatus(cap);
taskTimeStamp(myTask());
rts_unlock(cap);
}
/* check the status of the entire Haskell computation */
switch (status) {
case Killed:
errorBelch("main thread exited (uncaught exception)");
exit_status = EXIT_KILLED;
break;
case Interrupted:
errorBelch("interrupted");
exit_status = EXIT_INTERRUPTED;
break;
case HeapExhausted:
exit_status = EXIT_HEAPOVERFLOW;
break;
case Success:
exit_status = EXIT_SUCCESS;
break;
default:
barf("main thread completed with invalid status");
}
shutdownHaskellAndExit(exit_status);
}
void *osReserveHeapMemory (void *startAddress, W_ *len)
{
void *start;
heap_base = VirtualAlloc(startAddress, *len + MBLOCK_SIZE,
MEM_RESERVE, PAGE_READWRITE);
if (heap_base == NULL) {
if (GetLastError() == ERROR_NOT_ENOUGH_MEMORY) {
errorBelch("out of memory");
} else {
sysErrorBelch(
"osReserveHeapMemory: VirtualAlloc MEM_RESERVE %llu bytes \
at address %p bytes failed",
len + MBLOCK_SIZE, startAddress);
}
stg_exit(EXIT_FAILURE);
}
// VirtualFree MEM_RELEASE must always match a
// previous MEM_RESERVE call, in address and size
// so we necessarily leak some address space here,
// before and after the aligned area
// It is not a huge problem because we never commit
// that memory
start = MBLOCK_ROUND_UP(heap_base);
return start;
}
static
alloc_rec*
allocNew(uint32_t n) {
alloc_rec* rec;
rec = (alloc_rec*)stgMallocBytes(sizeof(alloc_rec),"getMBlocks: allocNew");
rec->size = ((W_)n+1)*MBLOCK_SIZE;
rec->base =
VirtualAlloc(NULL, rec->size, MEM_RESERVE, PAGE_READWRITE);
if(rec->base==0) {
stgFree((void*)rec);
rec=0;
if (GetLastError() == ERROR_NOT_ENOUGH_MEMORY) {
errorBelch("Out of memory\n");
stg_exit(EXIT_HEAPOVERFLOW);
} else {
sysErrorBelch(
"getMBlocks: VirtualAlloc MEM_RESERVE %d blocks failed", n);
}
} else {
alloc_rec temp;
temp.base=0; temp.size=0; temp.next=allocs;
alloc_rec* it;
it=&temp;
for(; it->next!=0 && it->next->base<rec->base; it=it->next) ;
rec->next=it->next;
it->next=rec;
allocs=temp.next;
}
return rec;
}
fdOutOfRange (int fd)
{
errorBelch("file descriptor %d out of range for select (0--%d).\n"
"Recompile with -threaded to work around this.",
fd, (int)FD_SETSIZE);
stg_exit(EXIT_FAILURE);
}
void *
osGetMBlocks(nat n)
{
caddr_t ret;
W_ size = MBLOCK_SIZE * (W_)n;
if (next_request == 0) {
// use gen_map_mblocks the first time.
ret = gen_map_mblocks(size);
} else {
ret = my_mmap(next_request, size, MEM_RESERVE_AND_COMMIT);
if (((W_)ret & MBLOCK_MASK) != 0) {
// misaligned block!
#if 0 // defined(DEBUG)
errorBelch("warning: getMBlock: misaligned block %p returned "
"when allocating %d megablock(s) at %p",
ret, n, next_request);
#endif
// unmap this block...
if (munmap(ret, size) == -1) {
barf("getMBlock: munmap failed");
}
// and do it the hard way
ret = gen_map_mblocks(size);
}
}
// Next time, we'll try to allocate right after the block we just got.
// ToDo: check that we haven't already grabbed the memory at next_request
next_request = ret + size;
return ret;
}
/* Returns 0 if physical memory size cannot be identified */
StgWord64 getPhysicalMemorySize (void)
{
static StgWord64 physMemSize = 0;
if (!physMemSize) {
#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
/* So, darwin doesn't support _SC_PHYS_PAGES, but it does
support getting the raw memory size in bytes through
sysctlbyname(hw.memsize); */
size_t len = sizeof(physMemSize);
int ret = -1;
/* Note hw.memsize is in bytes, so no need to multiply by page size. */
ret = sysctlbyname("hw.memsize", &physMemSize, &len, NULL, 0);
if (ret == -1) {
physMemSize = 0;
return 0;
}
#else
/* We'll politely assume we have a system supporting _SC_PHYS_PAGES
* otherwise. */
W_ pageSize = getPageSize();
long ret = sysconf(_SC_PHYS_PAGES);
if (ret == -1) {
#if defined(DEBUG)
errorBelch("warning: getPhysicalMemorySize: cannot get "
"physical memory size");
#endif
return 0;
}
physMemSize = ret * pageSize;
#endif /* darwin_HOST_OS */
}
return physMemSize;
}
void getProcessTimes(Time *user, Time *elapsed)
{
static nat ClockFreq = 0;
if (ClockFreq == 0) {
#if defined(HAVE_SYSCONF)
long ticks;
ticks = sysconf(_SC_CLK_TCK);
if ( ticks == -1 ) {
sysErrorBelch("sysconf");
stg_exit(EXIT_FAILURE);
}
ClockFreq = ticks;
#elif defined(CLK_TCK) /* defined by POSIX */
ClockFreq = CLK_TCK;
#elif defined(HZ)
ClockFreq = HZ;
#elif defined(CLOCKS_PER_SEC)
ClockFreq = CLOCKS_PER_SEC;
#else
errorBelch("can't get clock resolution");
stg_exit(EXIT_FAILURE);
#endif
}
struct tms t;
clock_t r = times(&t);
*user = SecondsToTime(t.tms_utime) / ClockFreq;
*elapsed = SecondsToTime(r) / ClockFreq;
}
static void decommitBlocks(char *addr, W_ nBytes)
{
alloc_rec *p;
p = allocs;
while ((p != NULL) && (addr >= (p->base + p->size))) {
p = p->next;
}
while (nBytes > 0) {
if ((p == NULL) || (p->base > addr)) {
errorBelch("Memory to be freed isn't allocated\n");
stg_exit(EXIT_FAILURE);
}
if (p->base + p->size >= addr + nBytes) {
if (!VirtualFree(addr, nBytes, MEM_DECOMMIT)) {
sysErrorBelch("osFreeMBlocks: VirtualFree MEM_DECOMMIT failed");
stg_exit(EXIT_FAILURE);
}
nBytes = 0;
}
else {
W_ bytesToFree = p->base + p->size - addr;
if (!VirtualFree(addr, bytesToFree, MEM_DECOMMIT)) {
sysErrorBelch("osFreeMBlocks: VirtualFree MEM_DECOMMIT failed");
stg_exit(EXIT_FAILURE);
}
addr += bytesToFree;
nBytes -= bytesToFree;
p = p->next;
}
}
}
/*
* Function: rts_InstallConsoleEvent()
*
* Install/remove a console event handler.
*/
int
rts_InstallConsoleEvent(int action, StgStablePtr *handler)
{
StgInt previous_hdlr = console_handler;
switch (action) {
case STG_SIG_IGN:
console_handler = STG_SIG_IGN;
if ( !SetConsoleCtrlHandler(NULL, true) ) {
errorBelch("warning: unable to ignore console events");
}
break;
case STG_SIG_DFL:
console_handler = STG_SIG_IGN;
if ( !SetConsoleCtrlHandler(NULL, false) ) {
errorBelch("warning: unable to restore default console event "
"handling");
}
break;
case STG_SIG_HAN:
#ifdef THREADED_RTS
// handler is stored in an MVar in the threaded RTS
console_handler = STG_SIG_HAN;
#else
console_handler = (StgInt)*handler;
#endif
if (previous_hdlr < 0 || previous_hdlr == STG_SIG_HAN) {
/* Only install generic_handler() once */
if ( !SetConsoleCtrlHandler(generic_handler, true) ) {
errorBelch("warning: unable to install console event handler");
}
}
break;
}
if (previous_hdlr == STG_SIG_DFL ||
previous_hdlr == STG_SIG_IGN ||
previous_hdlr == STG_SIG_HAN) {
return previous_hdlr;
} else {
if (handler != NULL) {
*handler = (StgStablePtr)previous_hdlr;
}
return STG_SIG_HAN;
}
}
// Used for detecting a non-empty FPU stack on x86 (see #4914)
void checkFPUStack(void)
{
#ifdef x86_HOST_ARCH
static unsigned char buf[108];
asm("FSAVE %0":"=m" (buf));
if(buf[8]!=255 || buf[9]!=255) {
errorBelch("NONEMPTY FPU Stack, TAG = %x %x\n",buf[8],buf[9]);
abort();
}
#endif
}
void __unregister_hs_exception_handler( void )
{
if (__hs_handle != NULL)
{
// Should the return value be checked? we're terminating anyway.
RemoveVectoredExceptionHandler(__hs_handle);
__hs_handle = NULL;
}
else
{
errorBelch("__unregister_hs_exception_handler() called without having called __register_hs_exception_handler() first.");
}
}
void __register_hs_exception_handler( void )
{
// Allow the VEH handler to be registered only once.
if (NULL == __hs_handle)
{
__hs_handle = AddVectoredExceptionHandler(CALL_FIRST, __hs_exception_handler);
// should the handler not be registered this will return a null.
assert(__hs_handle);
}
else
{
errorBelch("There is no need to call __register_hs_exception_handler() twice, VEH handlers are global per process.");
}
}
void freeMyTask (void)
{
Task *task;
task = myTask();
if (task == NULL) return;
if (!task->stopped) {
errorBelch(
"freeMyTask() called, but the Task is not stopped; ignoring");
return;
}
if (task->worker) {
errorBelch("freeMyTask() called on a worker; ignoring");
return;
}
ACQUIRE_LOCK(&all_tasks_mutex);
if (task->all_prev) {
task->all_prev->all_next = task->all_next;
} else {
all_tasks = task->all_next;
}
if (task->all_next) {
task->all_next->all_prev = task->all_prev;
}
taskCount--;
RELEASE_LOCK(&all_tasks_mutex);
freeTask(task);
setMyTask(NULL);
}
/* Returns 0 if physical memory size cannot be identified */
StgWord64 getPhysicalMemorySize (void)
{
static StgWord64 physMemSize = 0;
if (!physMemSize) {
MEMORYSTATUSEX status;
status.dwLength = sizeof(status);
if (!GlobalMemoryStatusEx(&status)) {
#if defined(DEBUG)
errorBelch("warning: getPhysicalMemorySize: cannot get physical memory size");
#endif
return 0;
}
physMemSize = status.ullTotalPhys;
}
return physMemSize;
}
/* ---------------------------------------------------------------------------
* Function: initCapabilities()
*
* Purpose: set up the Capability handling. For the THREADED_RTS build,
* we keep a table of them, the size of which is
* controlled by the user via the RTS flag -N.
*
* ------------------------------------------------------------------------- */
void
initCapabilities( void )
{
#if defined(THREADED_RTS)
nat i;
#ifndef REG_Base
// We can't support multiple CPUs if BaseReg is not a register
if (RtsFlags.ParFlags.nNodes > 1) {
errorBelch("warning: multiple CPUs not supported in this build, reverting to 1");
RtsFlags.ParFlags.nNodes = 1;
}
#endif
n_capabilities = RtsFlags.ParFlags.nNodes;
if (n_capabilities == 1) {
capabilities = &MainCapability;
// THREADED_RTS must work on builds that don't have a mutable
// BaseReg (eg. unregisterised), so in this case
// capabilities[0] must coincide with &MainCapability.
} else {
capabilities = stgMallocBytes(n_capabilities * sizeof(Capability),
"initCapabilities");
}
for (i = 0; i < n_capabilities; i++) {
initCapability(&capabilities[i], i);
}
debugTrace(DEBUG_sched, "allocated %d capabilities", n_capabilities);
#else /* !THREADED_RTS */
n_capabilities = 1;
capabilities = &MainCapability;
initCapability(&MainCapability, 0);
#endif
// There are no free capabilities to begin with. We will start
// a worker Task to each Capability, which will quickly put the
// Capability on the free list when it finds nothing to do.
last_free_capability = &capabilities[0];
}
Task *
newBoundTask (void)
{
Task *task;
if (!tasksInitialized) {
errorBelch("newBoundTask: RTS is not initialised; call hs_init() first");
stg_exit(EXIT_FAILURE);
}
task = allocTask();
task->stopped = rtsFalse;
newInCall(task);
debugTrace(DEBUG_sched, "new task (taskCount: %d)", taskCount);
return task;
}
void osBindMBlocksToNode(
void *addr,
StgWord size,
uint32_t node)
{
if (osNumaAvailable())
{
void* temp;
if (RtsFlags.GcFlags.numa) {
/* Note [base memory]
I would like to use addr here to specify the base
memory of allocation. The problem is that the address
we are requesting is too high. I can't figure out if it's
because of my NUMA-emulation or a bug in the code.
On windows also -xb is broken, it does nothing so that can't
be used to tweak it (see #12577). So for now, just let the OS decide.
*/
temp = VirtualAllocExNuma(
GetCurrentProcess(),
NULL, // addr? See base memory
size,
MEM_RESERVE | MEM_COMMIT,
PAGE_READWRITE,
node
);
if (!temp) {
if (GetLastError() == ERROR_NOT_ENOUGH_MEMORY) {
errorBelch("out of memory");
}
else {
sysErrorBelch(
"osBindMBlocksToNode: VirtualAllocExNuma MEM_RESERVE %" FMT_Word " bytes "
"at address %p bytes failed",
size, addr);
}
stg_exit(EXIT_FAILURE);
}
}
}
}
void
sendIOManagerEvent (HsWord32 event)
{
#if defined(THREADED_RTS)
ACQUIRE_LOCK(&event_buf_mutex);
// debugBelch("sendIOManagerEvent: %d\n", event);
if (io_manager_event != INVALID_HANDLE_VALUE) {
if (next_event == EVENT_BUFSIZ) {
errorBelch("event buffer overflowed; event dropped");
} else {
if (!SetEvent(io_manager_event)) {
sysErrorBelch("sendIOManagerEvent");
stg_exit(EXIT_FAILURE);
}
event_buf[next_event++] = (StgWord32)event;
}
}
RELEASE_LOCK(&event_buf_mutex);
#endif
}
/* ---------------------------------------------------------------------------
* Function: initCapabilities()
*
* Purpose: set up the Capability handling. For the THREADED_RTS build,
* we keep a table of them, the size of which is
* controlled by the user via the RTS flag -N.
*
* ------------------------------------------------------------------------- */
void
initCapabilities( void )
{
/* Declare a couple capability sets representing the process and
clock domain. Each capability will get added to these capsets. */
traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
traceCapsetCreate(CAPSET_CLOCKDOMAIN_DEFAULT, CapsetTypeClockdomain);
#if defined(THREADED_RTS)
#ifndef REG_Base
// We can't support multiple CPUs if BaseReg is not a register
if (RtsFlags.ParFlags.nNodes > 1) {
errorBelch("warning: multiple CPUs not supported in this build, reverting to 1");
RtsFlags.ParFlags.nNodes = 1;
}
#endif
n_capabilities = 0;
moreCapabilities(0, RtsFlags.ParFlags.nNodes);
n_capabilities = RtsFlags.ParFlags.nNodes;
#else /* !THREADED_RTS */
n_capabilities = 1;
capabilities = stgMallocBytes(sizeof(Capability*), "initCapabilities");
capabilities[0] = &MainCapability;
initCapability(&MainCapability, 0);
#endif
enabled_capabilities = n_capabilities;
// There are no free capabilities to begin with. We will start
// a worker Task to each Capability, which will quickly put the
// Capability on the free list when it finds nothing to do.
last_free_capability = capabilities[0];
}
/* ---------------------------------------------------------------------------
* Function: initCapabilities()
*
* Purpose: set up the Capability handling. For the THREADED_RTS build,
* we keep a table of them, the size of which is
* controlled by the user via the RTS flag -N.
*
* ------------------------------------------------------------------------- */
void initCapabilities (void)
{
uint32_t i;
/* Declare a couple capability sets representing the process and
clock domain. Each capability will get added to these capsets. */
traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
traceCapsetCreate(CAPSET_CLOCKDOMAIN_DEFAULT, CapsetTypeClockdomain);
// Initialise NUMA
if (!RtsFlags.GcFlags.numa) {
n_numa_nodes = 1;
for (i = 0; i < MAX_NUMA_NODES; i++) {
numa_map[i] = 0;
}
} else {
uint32_t nNodes = osNumaNodes();
if (nNodes > MAX_NUMA_NODES) {
barf("Too many NUMA nodes (max %d)", MAX_NUMA_NODES);
}
StgWord mask = RtsFlags.GcFlags.numaMask & osNumaMask();
uint32_t logical = 0, physical = 0;
for (; physical < MAX_NUMA_NODES; physical++) {
if (mask & 1) {
numa_map[logical++] = physical;
}
mask = mask >> 1;
}
n_numa_nodes = logical;
if (logical == 0) {
barf("%s: available NUMA node set is empty");
}
}
#if defined(THREADED_RTS)
#ifndef REG_Base
// We can't support multiple CPUs if BaseReg is not a register
if (RtsFlags.ParFlags.nCapabilities > 1) {
errorBelch("warning: multiple CPUs not supported in this build, reverting to 1");
RtsFlags.ParFlags.nCapabilities = 1;
}
#endif
n_capabilities = 0;
moreCapabilities(0, RtsFlags.ParFlags.nCapabilities);
n_capabilities = RtsFlags.ParFlags.nCapabilities;
#else /* !THREADED_RTS */
n_capabilities = 1;
capabilities = stgMallocBytes(sizeof(Capability*), "initCapabilities");
capabilities[0] = &MainCapability;
initCapability(&MainCapability, 0);
#endif
enabled_capabilities = n_capabilities;
// There are no free capabilities to begin with. We will start
// a worker Task to each Capability, which will quickly put the
// Capability on the free list when it finds nothing to do.
for (i = 0; i < n_numa_nodes; i++) {
last_free_capability[i] = capabilities[0];
}
}
void
initStorage (void)
{
nat g;
if (generations != NULL) {
// multi-init protection
return;
}
initMBlocks();
/* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
* doing something reasonable.
*/
/* We use the NOT_NULL variant or gcc warns that the test is always true */
ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL((StgWord)&stg_BLOCKING_QUEUE_CLEAN_info));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.heapSizeSuggestion >
RtsFlags.GcFlags.maxHeapSize) {
RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
}
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.minAllocAreaSize >
RtsFlags.GcFlags.maxHeapSize) {
errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
}
initBlockAllocator();
#if defined(THREADED_RTS)
initMutex(&sm_mutex);
#endif
ACQUIRE_SM_LOCK;
/* allocate generation info array */
generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
* sizeof(struct generation_),
"initStorage: gens");
/* Initialise all generations */
for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
initGeneration(&generations[g], g);
}
/* A couple of convenience pointers */
g0 = &generations[0];
oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
/* Set up the destination pointers in each younger gen. step */
for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
generations[g].to = &generations[g+1];
}
oldest_gen->to = oldest_gen;
/* The oldest generation has one step. */
if (RtsFlags.GcFlags.compact || RtsFlags.GcFlags.sweep) {
if (RtsFlags.GcFlags.generations == 1) {
errorBelch("WARNING: compact/sweep is incompatible with -G1; disabled");
} else {
oldest_gen->mark = 1;
if (RtsFlags.GcFlags.compact)
oldest_gen->compact = 1;
}
}
generations[0].max_blocks = 0;
dyn_caf_list = (StgIndStatic*)END_OF_CAF_LIST;
debug_caf_list = (StgIndStatic*)END_OF_CAF_LIST;
revertible_caf_list = (StgIndStatic*)END_OF_CAF_LIST;
/* initialise the allocate() interface */
large_alloc_lim = RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W;
exec_block = NULL;
#ifdef THREADED_RTS
initSpinLock(&gc_alloc_block_sync);
#ifdef PROF_SPIN
whitehole_spin = 0;
#endif
#endif
N = 0;
next_nursery = 0;
storageAddCapabilities(0, n_capabilities);
IF_DEBUG(gc, statDescribeGens());
RELEASE_SM_LOCK;
traceEventHeapInfo(CAPSET_HEAP_DEFAULT,
RtsFlags.GcFlags.generations,
RtsFlags.GcFlags.maxHeapSize * BLOCK_SIZE_W * sizeof(W_),
RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W * sizeof(W_),
MBLOCK_SIZE_W * sizeof(W_),
BLOCK_SIZE_W * sizeof(W_));
}
void
setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
{
rtsBool error = rtsFalse;
I_ mode;
I_ arg, total_arg;
setProgName (argv);
total_arg = *argc;
arg = 1;
*argc = 1;
*rts_argc = 0;
// process arguments from the ghc_rts_opts global variable first.
// (arguments from the GHCRTS environment variable and the command
// line override these).
{
if (ghc_rts_opts != NULL) {
splitRtsFlags(ghc_rts_opts, rts_argc, rts_argv);
}
}
// process arguments from the GHCRTS environment variable next
// (arguments from the command line override these).
{
char *ghc_rts = getenv("GHCRTS");
if (ghc_rts != NULL) {
if (rtsOptsEnabled != rtsOptsNone) {
splitRtsFlags(ghc_rts, rts_argc, rts_argv);
}
else {
errorBelch("Warning: Ignoring GHCRTS variable as RTS options are disabled.\n Link with -rtsopts to enable them.");
// We don't actually exit, just warn
}
}
}
// Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts
// argv[0] must be PGM argument -- leave in argv
for (mode = PGM; arg < total_arg; arg++) {
// The '--RTS' argument disables all future +RTS ... -RTS processing.
if (strequal("--RTS", argv[arg])) {
arg++;
break;
}
// The '--' argument is passed through to the program, but
// disables all further +RTS ... -RTS processing.
else if (strequal("--", argv[arg])) {
break;
}
else if (strequal("+RTS", argv[arg])) {
if (rtsOptsEnabled != rtsOptsNone) {
mode = RTS;
}
else {
errorBelch("RTS options are disabled. Link with -rtsopts to enable them.");
stg_exit(EXIT_FAILURE);
}
}
else if (strequal("-RTS", argv[arg])) {
mode = PGM;
}
else if (mode == RTS && *rts_argc < MAX_RTS_ARGS-1) {
rts_argv[(*rts_argc)++] = argv[arg];
}
else if (mode == PGM) {
argv[(*argc)++] = argv[arg];
}
else {
barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
}
}
// process remaining program arguments
for (; arg < total_arg; arg++) {
argv[(*argc)++] = argv[arg];
}
argv[*argc] = (char *) 0;
rts_argv[*rts_argc] = (char *) 0;
// Process RTS (rts_argv) part: mainly to determine statsfile
for (arg = 0; arg < *rts_argc; arg++) {
if (rts_argv[arg][0] != '-') {
fflush(stdout);
errorBelch("unexpected RTS argument: %s", rts_argv[arg]);
error = rtsTrue;
} else {
switch(rts_argv[arg][1]) {
case '-':
if (strequal("info", &rts_argv[arg][2])) {
printRtsInfo();
stg_exit(0);
}
break;
default:
break;
}
if (rtsOptsEnabled != rtsOptsAll)
{
errorBelch("Most RTS options are disabled. Link with -rtsopts to enable them.");
stg_exit(EXIT_FAILURE);
}
switch(rts_argv[arg][1]) {
/* process: general args, then PROFILING-only ones, then
CONCURRENT-only, TICKY-only (same order as defined in
RtsFlags.lh); within those groups, mostly in
case-insensitive alphabetical order. Final group is
x*, which allows for more options.
*/
#ifdef TICKY_TICKY
# define TICKY_BUILD_ONLY(x) x
#else
# define TICKY_BUILD_ONLY(x) \
errorBelch("the flag %s requires the program to be built with -ticky", rts_argv[arg]); \
error = rtsTrue;
#endif
#ifdef PROFILING
# define PROFILING_BUILD_ONLY(x) x
#else
# define PROFILING_BUILD_ONLY(x) \
errorBelch("the flag %s requires the program to be built with -prof", rts_argv[arg]); \
error = rtsTrue;
#endif
#ifdef TRACING
# define TRACING_BUILD_ONLY(x) x
#else
# define TRACING_BUILD_ONLY(x) \
errorBelch("the flag %s requires the program to be built with -eventlog or -debug", rts_argv[arg]); \
error = rtsTrue;
#endif
#ifdef THREADED_RTS
# define THREADED_BUILD_ONLY(x) x
#else
# define THREADED_BUILD_ONLY(x) \
errorBelch("the flag %s requires the program to be built with -threaded", rts_argv[arg]); \
error = rtsTrue;
#endif
#ifdef DEBUG
# define DEBUG_BUILD_ONLY(x) x
#else
# define DEBUG_BUILD_ONLY(x) \
errorBelch("the flag %s requires the program to be built with -debug", rts_argv[arg]); \
error = rtsTrue;
#endif
/* =========== GENERAL ========================== */
case '?':
error = rtsTrue;
break;
/* This isn't going to allow us to keep related options
together as we add more --* flags. We really need a
proper options parser. */
case '-':
if (strequal("install-signal-handlers=yes",
&rts_argv[arg][2])) {
RtsFlags.MiscFlags.install_signal_handlers = rtsTrue;
}
else if (strequal("install-signal-handlers=no",
&rts_argv[arg][2])) {
RtsFlags.MiscFlags.install_signal_handlers = rtsFalse;
}
else if (strequal("machine-readable",
&rts_argv[arg][2])) {
RtsFlags.MiscFlags.machineReadable = rtsTrue;
}
else if (strequal("info",
&rts_argv[arg][2])) {
printRtsInfo();
stg_exit(0);
}
else {
errorBelch("unknown RTS option: %s",rts_argv[arg]);
error = rtsTrue;
}
break;
case 'A':
RtsFlags.GcFlags.minAllocAreaSize
= decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_INT_MAX)
/ BLOCK_SIZE;
break;
#ifdef USE_PAPI
case 'a':
switch(rts_argv[arg][2]) {
case '1':
RtsFlags.PapiFlags.eventType = PAPI_FLAG_CACHE_L1;
break;
case '2':
RtsFlags.PapiFlags.eventType = PAPI_FLAG_CACHE_L2;
break;
case 'b':
RtsFlags.PapiFlags.eventType = PAPI_FLAG_BRANCH;
break;
case 's':
RtsFlags.PapiFlags.eventType = PAPI_FLAG_STALLS;
break;
case 'e':
RtsFlags.PapiFlags.eventType = PAPI_FLAG_CB_EVENTS;
break;
case '+':
case '#':
if (RtsFlags.PapiFlags.numUserEvents >= MAX_PAPI_USER_EVENTS) {
errorBelch("maximum number of PAPI events reached");
stg_exit(EXIT_FAILURE);
}
nat eventNum = RtsFlags.PapiFlags.numUserEvents++;
char kind = rts_argv[arg][2];
nat eventKind = kind == '+' ? PAPI_PRESET_EVENT_KIND : PAPI_NATIVE_EVENT_KIND;
RtsFlags.PapiFlags.userEvents[eventNum] = rts_argv[arg] + 3;
RtsFlags.PapiFlags.eventType = PAPI_USER_EVENTS;
RtsFlags.PapiFlags.userEventsKind[eventNum] = eventKind;
break;
default:
bad_option( rts_argv[arg] );
}
break;
#endif
case 'B':
RtsFlags.GcFlags.ringBell = rtsTrue;
break;
case 'c':
if (rts_argv[arg][2] != '\0') {
RtsFlags.GcFlags.compactThreshold =
atof(rts_argv[arg]+2);
} else {
RtsFlags.GcFlags.compact = rtsTrue;
}
break;
case 'w':
RtsFlags.GcFlags.sweep = rtsTrue;
break;
case 'F':
RtsFlags.GcFlags.oldGenFactor = atof(rts_argv[arg]+2);
if (RtsFlags.GcFlags.oldGenFactor < 0)
bad_option( rts_argv[arg] );
break;
case 'D':
DEBUG_BUILD_ONLY(
{
char *c;
for (c = rts_argv[arg] + 2; *c != '\0'; c++) {
switch (*c) {
case 's':
RtsFlags.DebugFlags.scheduler = rtsTrue;
break;
case 'i':
RtsFlags.DebugFlags.interpreter = rtsTrue;
break;
case 'w':
RtsFlags.DebugFlags.weak = rtsTrue;
break;
case 'G':
RtsFlags.DebugFlags.gccafs = rtsTrue;
break;
case 'g':
RtsFlags.DebugFlags.gc = rtsTrue;
break;
case 'b':
RtsFlags.DebugFlags.block_alloc = rtsTrue;
break;
case 'S':
RtsFlags.DebugFlags.sanity = rtsTrue;
break;
case 't':
RtsFlags.DebugFlags.stable = rtsTrue;
break;
case 'p':
RtsFlags.DebugFlags.prof = rtsTrue;
break;
case 'l':
RtsFlags.DebugFlags.linker = rtsTrue;
break;
case 'a':
RtsFlags.DebugFlags.apply = rtsTrue;
break;
case 'm':
RtsFlags.DebugFlags.stm = rtsTrue;
break;
case 'z':
RtsFlags.DebugFlags.squeeze = rtsTrue;
break;
case 'c':
RtsFlags.DebugFlags.hpc = rtsTrue;
break;
case 'r':
RtsFlags.DebugFlags.sparks = rtsTrue;
break;
default:
bad_option( rts_argv[arg] );
}
}
// -Dx also turns on -v. Use -l to direct trace
// events to the .eventlog file instead.
RtsFlags.TraceFlags.tracing = TRACE_STDERR;
})
break;
case 'K':
RtsFlags.GcFlags.maxStkSize =
decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
break;
case 'k':
switch(rts_argv[arg][2]) {
case 'c':
RtsFlags.GcFlags.stkChunkSize =
decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
break;
case 'b':
RtsFlags.GcFlags.stkChunkBufferSize =
decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
break;
case 'i':
RtsFlags.GcFlags.initialStkSize =
decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
break;
default:
RtsFlags.GcFlags.initialStkSize =
decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) / sizeof(W_);
break;
}
break;
case 'M':
RtsFlags.GcFlags.maxHeapSize =
decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) / BLOCK_SIZE;
/* user give size in *bytes* but "maxHeapSize" is in *blocks* */
break;
case 'm':
RtsFlags.GcFlags.pcFreeHeap = atof(rts_argv[arg]+2);
if (RtsFlags.GcFlags.pcFreeHeap < 0 ||
RtsFlags.GcFlags.pcFreeHeap > 100)
bad_option( rts_argv[arg] );
break;
case 'G':
RtsFlags.GcFlags.generations =
decodeSize(rts_argv[arg], 2, 1, HS_INT_MAX);
break;
case 'H':
if (rts_argv[arg][2] == '\0') {
RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue;
} else {
RtsFlags.GcFlags.heapSizeSuggestion =
(nat)(decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) / BLOCK_SIZE);
}
break;
#ifdef RTS_GTK_FRONTPANEL
case 'f':
RtsFlags.GcFlags.frontpanel = rtsTrue;
break;
#endif
case 'I': /* idle GC delay */
if (rts_argv[arg][2] == '\0') {
/* use default */
} else {
I_ cst; /* tmp */
/* Convert to millisecs */
cst = (I_) ((atof(rts_argv[arg]+2) * 1000));
RtsFlags.GcFlags.idleGCDelayTime = cst;
}
break;
case 'S':
RtsFlags.GcFlags.giveStats = VERBOSE_GC_STATS;
goto stats;
case 's':
RtsFlags.GcFlags.giveStats = SUMMARY_GC_STATS;
goto stats;
case 't':
RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS;
goto stats;
stats:
{
int r;
r = open_stats_file(arg, *argc, argv,
*rts_argc, rts_argv, NULL,
&RtsFlags.GcFlags.statsFile);
if (r == -1) { error = rtsTrue; }
}
break;
case 'Z':
RtsFlags.GcFlags.squeezeUpdFrames = rtsFalse;
break;
/* =========== PROFILING ========================== */
case 'P': /* detailed cost centre profiling (time/alloc) */
case 'p': /* cost centre profiling (time/alloc) */
PROFILING_BUILD_ONLY(
switch (rts_argv[arg][2]) {
case 'x':
RtsFlags.CcFlags.doCostCentres = COST_CENTRES_XML;
break;
case 'a':
RtsFlags.CcFlags.doCostCentres = COST_CENTRES_ALL;
break;
default:
if (rts_argv[arg][1] == 'P') {
RtsFlags.CcFlags.doCostCentres =
COST_CENTRES_VERBOSE;
} else {
RtsFlags.CcFlags.doCostCentres =
COST_CENTRES_SUMMARY;
}
break;
}
) break;
case 'R':
PROFILING_BUILD_ONLY(
RtsFlags.ProfFlags.maxRetainerSetSize = atof(rts_argv[arg]+2);
) break;
case 'L':
PROFILING_BUILD_ONLY(
RtsFlags.ProfFlags.ccsLength = atof(rts_argv[arg]+2);
if(RtsFlags.ProfFlags.ccsLength <= 0) {
bad_option(rts_argv[arg]);
}
) break;
void
initStorage( void )
{
nat g, n;
if (generations != NULL) {
// multi-init protection
return;
}
initMBlocks();
/* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
* doing something reasonable.
*/
/* We use the NOT_NULL variant or gcc warns that the test is always true */
ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL((StgWord)&stg_BLOCKING_QUEUE_CLEAN_info));
ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.heapSizeSuggestion >
RtsFlags.GcFlags.maxHeapSize) {
RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion;
}
if (RtsFlags.GcFlags.maxHeapSize != 0 &&
RtsFlags.GcFlags.minAllocAreaSize >
RtsFlags.GcFlags.maxHeapSize) {
errorBelch("maximum heap size (-M) is smaller than minimum alloc area size (-A)");
RtsFlags.GcFlags.minAllocAreaSize = RtsFlags.GcFlags.maxHeapSize;
}
initBlockAllocator();
#if defined(THREADED_RTS)
initMutex(&sm_mutex);
#endif
ACQUIRE_SM_LOCK;
/* allocate generation info array */
generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations
* sizeof(struct generation_),
"initStorage: gens");
/* Initialise all generations */
for(g = 0; g < RtsFlags.GcFlags.generations; g++) {
initGeneration(&generations[g], g);
}
/* A couple of convenience pointers */
g0 = &generations[0];
oldest_gen = &generations[RtsFlags.GcFlags.generations-1];
nurseries = stgMallocBytes(n_capabilities * sizeof(struct nursery_),
"initStorage: nurseries");
/* Set up the destination pointers in each younger gen. step */
for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
generations[g].to = &generations[g+1];
}
oldest_gen->to = oldest_gen;
/* The oldest generation has one step. */
if (RtsFlags.GcFlags.compact || RtsFlags.GcFlags.sweep) {
if (RtsFlags.GcFlags.generations == 1) {
errorBelch("WARNING: compact/sweep is incompatible with -G1; disabled");
} else {
oldest_gen->mark = 1;
if (RtsFlags.GcFlags.compact)
oldest_gen->compact = 1;
}
}
generations[0].max_blocks = 0;
/* The allocation area. Policy: keep the allocation area
* small to begin with, even if we have a large suggested heap
* size. Reason: we're going to do a major collection first, and we
* don't want it to be a big one. This vague idea is borne out by
* rigorous experimental evidence.
*/
allocNurseries();
weak_ptr_list = NULL;
caf_list = END_OF_STATIC_LIST;
revertible_caf_list = END_OF_STATIC_LIST;
/* initialise the allocate() interface */
large_alloc_lim = RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W;
exec_block = NULL;
#ifdef THREADED_RTS
initSpinLock(&gc_alloc_block_sync);
whitehole_spin = 0;
#endif
N = 0;
// allocate a block for each mut list
for (n = 0; n < n_capabilities; n++) {
for (g = 1; g < RtsFlags.GcFlags.generations; g++) {
capabilities[n].mut_lists[g] = allocBlock();
}
}
initGcThreads();
IF_DEBUG(gc, statDescribeGens());
RELEASE_SM_LOCK;
}
static void *
my_mmap (void *addr, W_ size, int operation)
{
void *ret;
#if darwin_HOST_OS
// Without MAP_FIXED, Apple's mmap ignores addr.
// With MAP_FIXED, it overwrites already mapped regions, whic
// mmap(0, ... MAP_FIXED ...) is worst of all: It unmaps the program text
// and replaces it with zeroes, causing instant death.
// This behaviour seems to be conformant with IEEE Std 1003.1-2001.
// Let's just use the underlying Mach Microkernel calls directly,
// they're much nicer.
kern_return_t err = 0;
ret = addr;
if(operation & MEM_RESERVE)
{
if(addr) // try to allocate at address
err = vm_allocate(mach_task_self(),(vm_address_t*) &ret,
size, FALSE);
if(!addr || err) // try to allocate anywhere
err = vm_allocate(mach_task_self(),(vm_address_t*) &ret,
size, TRUE);
}
if(err) {
// don't know what the error codes mean exactly, assume it's
// not our problem though.
errorBelch("memory allocation failed (requested %" FMT_Word " bytes)",
size);
stg_exit(EXIT_FAILURE);
}
if(operation & MEM_COMMIT) {
vm_protect(mach_task_self(), (vm_address_t)ret, size, FALSE,
VM_PROT_READ|VM_PROT_WRITE);
}
#else
int prot, flags;
if (operation & MEM_COMMIT)
prot = PROT_READ | PROT_WRITE;
else
prot = PROT_NONE;
if (operation == MEM_RESERVE)
flags = MAP_NORESERVE;
else if (operation == MEM_COMMIT)
flags = MAP_FIXED;
else
flags = 0;
#if defined(irix_HOST_OS)
{
if (operation & MEM_RESERVE)
{
int fd = open("/dev/zero",O_RDONLY);
ret = mmap(addr, size, prot, flags | MAP_PRIVATE, fd, 0);
close(fd);
}
else
{
ret = mmap(addr, size, prot, flags | MAP_PRIVATE, -1, 0);
}
}
#elif hpux_HOST_OS
ret = mmap(addr, size, prot, flags | MAP_ANONYMOUS | MAP_PRIVATE, -1, 0);
#elif linux_HOST_OS
ret = mmap(addr, size, prot, flags | MAP_ANON | MAP_PRIVATE, -1, 0);
if (ret == (void *)-1 && errno == EPERM) {
// Linux may return EPERM if it tried to give us
// a chunk of address space below mmap_min_addr,
// See Trac #7500.
if (addr != 0 && (operation & MEM_RESERVE)) {
// Try again with no hint address.
// It's not clear that this can ever actually help,
// but since our alternative is to abort, we may as well try.
ret = mmap(0, size, prot, flags | MAP_ANON | MAP_PRIVATE, -1, 0);
}
if (ret == (void *)-1 && errno == EPERM) {
// Linux is not willing to give us any mapping,
// so treat this as an out-of-memory condition
// (really out of virtual address space).
errno = ENOMEM;
}
}
#else
ret = mmap(addr, size, prot, flags | MAP_ANON | MAP_PRIVATE, -1, 0);
#endif
#endif
if (ret == (void *)-1) {
if (errno == ENOMEM ||
(errno == EINVAL && sizeof(void*)==4 && size >= 0xc0000000)) {
// If we request more than 3Gig, then we get EINVAL
// instead of ENOMEM (at least on Linux).
errorBelch("out of memory (requested %" FMT_Word " bytes)", size);
stg_exit(EXIT_FAILURE);
} else {
barf("getMBlock: mmap: %s", strerror(errno));
}
}
return ret;
}
/*
* Function: initDefaultHandlers()
*
* Install any default signal/console handlers. Currently we install a
* Ctrl+C handler that shuts down the RTS in an orderly manner.
*/
void initDefaultHandlers(void)
{
if ( !SetConsoleCtrlHandler(shutdown_handler, true) ) {
errorBelch("warning: failed to install default console handler");
}
}
int main (int argc, char *argv[])
{
testfun *f;
int i, r;
RtsConfig conf = defaultRtsConfig;
conf.rts_opts_enabled = RtsOptsAll;
hs_init_ghc(&argc, &argv, conf);
initLinker_(0);
loadPackages();
for (i=0; i < ITERATIONS; i++) {
r = loadObj(OBJPATH);
if (!r) {
errorBelch("loadObj(%s) failed", OBJPATH);
exit(1);
}
r = resolveObjs();
if (!r) {
errorBelch("resolveObjs failed");
exit(1);
}
#if LEADING_UNDERSCORE
f = lookupSymbol("_f");
#else
f = lookupSymbol("f");
#endif
if (!f) {
errorBelch("lookupSymbol failed");
exit(1);
}
r = f(3);
if (r != 4) {
errorBelch("call failed; %d", r);
exit(1);
}
unloadObj(OBJPATH);
performMajorGC();
printf("%d ", i);
fflush(stdout);
}
for (i=0; i < ITERATIONS; i++) {
r = loadObj(OBJPATH);
if (!r) {
errorBelch("loadObj(%s) failed", OBJPATH);
exit(1);
}
r = resolveObjs();
if (!r) {
errorBelch("resolveObjs failed");
exit(1);
}
#if LEADING_UNDERSCORE
f = lookupSymbol("_f");
#else
f = lookupSymbol("f");
#endif
if (!f) {
errorBelch("lookupSymbol failed");
exit(1);
}
r = f(3);
if (r != 4) {
errorBelch("call failed; %d", r);
exit(1);
}
// check that we can purge first, then unload
purgeObj(OBJPATH);
performMajorGC();
unloadObj(OBJPATH);
performMajorGC();
printf("%d ", i);
fflush(stdout);
}
hs_exit();
exit(0);
}
void resetDefaultHandlers(void)
{
if ( !SetConsoleCtrlHandler(shutdown_handler, false) ) {
errorBelch("warning: failed to uninstall default console handler");
}
}