Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORDHANDLE(code)); switch (c) { case 1: return exportNative(taskData, args); // Export case 2: raise_syscall(taskData, "C Export has been withdrawn", 0); return 0; case 3: return exportPortable(taskData, args); // Export as portable format case 9: // Return the GIT version if appropriate { return SAVE(C_string_to_Poly(taskData, GitVersion)); } case 10: // Return the RTS version string. { const char *version; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: version = "Portable-" TextVersion; break; case MA_I386: version = "I386-" TextVersion; break; case MA_X86_64: version = "X86_64-" TextVersion; break; default: version = "Unknown-" TextVersion; break; } return SAVE(C_string_to_Poly(taskData, version)); } case 11: // Return the RTS copyright string return SAVE(C_string_to_Poly(taskData, poly_runtime_system_copyright)); case 12: // Return the architecture { const char *arch; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: arch = "Interpreted"; break; case MA_I386: arch = "I386"; break; case MA_X86_64: arch = "X86_64"; break; default: arch = "Unknown"; break; } return SAVE(C_string_to_Poly(taskData, arch)); } case 13: // Share common immutable data. { ShareData(taskData, args); return SAVE(TAGGED(0)); } // ObjSize and ShowSize have their own IO vector entries but really they don't // need them. Include them here and add ObjProfile. case 14: return ObjSize(taskData, args); case 15: return ShowSize(taskData, args); case 16: return ObjProfile(taskData, args); /* 17 and 18 are no longer used. */ case 19: // Return the RTS argument help string. return SAVE(C_string_to_Poly(taskData, RTSArgHelp())); case 20: // Write a saved state file. return SaveState(taskData, args); case 21: // Load a saved state file and any ancestors. return LoadState(taskData, false, args); case 22: // Show the hierarchy. return ShowHierarchy(taskData); case 23: // Change the name of the immediate parent stored in a child return RenameParent(taskData, args); case 24: // Return the name of the immediate parent stored in a child return ShowParent(taskData, args); case 25: // Old statistics - now removed case 26: raise_exception_string(taskData, EXC_Fail, "No statistics available"); case 27: // Get number of user statistics available return Make_arbitrary_precision(taskData, N_PS_USER); case 28: // Set an entry in the user stats table. { unsigned index = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(0)); if (index >= N_PS_USER) raise_exception0(taskData, EXC_subscript); POLYSIGNED value = getPolySigned(taskData, DEREFHANDLE(args)->Get(1)); globalStats.setUserCounter(index, value); Make_arbitrary_precision(taskData, 0); } case 29: // Get local statistics. return globalStats.getLocalStatistics(taskData); case 30: // Get remote statistics. The argument is the process ID to get the statistics. return globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, DEREFHANDLE(args))); case 31: // Store a module return StoreModule(taskData, args); case 32: // Load a module return LoadModule(taskData, args); case 33: // Load hierarchy. This provides a complete list of children and parents. return LoadState(taskData, true, args); case 34: // Return the system directory for modules. This is configured differently // in Unix and in Windows. #if (defined(MODULEDIR)) return SAVE(C_string_to_Poly(taskData, Xstr(MODULEDIR))); #elif (defined(_WIN32) && ! defined(__CYGWIN__)) { // This registry key is configured when Poly/ML is installed using the installer. // It gives the path to the Poly/ML installation directory. We return the // Modules subdirectory. HKEY hk; if (RegOpenKeyEx(HKEY_LOCAL_MACHINE, _T("SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\PolyML.exe"), 0, KEY_QUERY_VALUE, &hk) == ERROR_SUCCESS) { DWORD valSize; if (RegQueryValueEx(hk, _T("Path"), 0, NULL, NULL, &valSize) == ERROR_SUCCESS) { #define MODULEDIR _T("Modules") TempString buff((TCHAR*)malloc(valSize + (_tcslen(MODULEDIR) + 1)*sizeof(TCHAR))); DWORD dwType; if (RegQueryValueEx(hk, _T("Path"), 0, &dwType, (LPBYTE)(LPTSTR)buff, &valSize) == ERROR_SUCCESS) { RegCloseKey(hk); // The registry entry should end with a backslash. _tcscat(buff, MODULEDIR); return SAVE(C_string_to_Poly(taskData, buff)); } } RegCloseKey(hk); } return SAVE(C_string_to_Poly(taskData, "")); } #else return SAVE(C_string_to_Poly(taskData, "")); #endif case 50: // GCD return gcd_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1))); case 51: // LCM return lcm_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1))); // These next ones were originally in process_env and have now been moved here, case 100: /* Return the maximum word segment size. */ return taskData->saveVec.push(TAGGED(MAX_OBJECT_SIZE)); case 101: /* Return the maximum string size (in bytes). It is the maximum number of bytes in a segment less one word for the length field. */ return taskData->saveVec.push(TAGGED((MAX_OBJECT_SIZE)*sizeof(PolyWord) - sizeof(PolyWord))); case 102: /* Test whether the supplied address is in the io area. This was previously done by having get_flags return 256 but this was changed so that get_flags simply returns the top byte of the length word. */ { PolyWord *pt = (PolyWord*)DEREFWORDHANDLE(args); if (gMem.IsIOPointer(pt)) return Make_arbitrary_precision(taskData, 1); else return Make_arbitrary_precision(taskData, 0); } case 103: /* Return the register mask for the given function. This is used by the code-generator to find out which registers are modified by the function and so need to be saved if they are used by the caller. */ { PolyObject *pt = DEREFWORDHANDLE(args); if (gMem.IsIOPointer(pt)) { /* IO area. We need to get this from the vector. */ int i; for (i=0; i < POLY_SYS_vecsize; i++) { if (pt == (PolyObject*)IoEntry(i)) { int regMask = taskData->GetIOFunctionRegisterMask(i); POLYUNSIGNED props = rtsProperties(taskData, i); return taskData->saveVec.push(TAGGED(regMask | props)); } } raise_exception_string(taskData, EXC_Fail, "Io pointer not found"); } else { /* We may have a pointer to the code or a pointer to a closure. If it's a closure we have to find the code. */ if (! pt->IsCodeObject() && ! pt->IsByteObject()) pt = pt->Get(0).AsObjPtr(); /* Should now be a code object. */ if (pt->IsCodeObject()) { /* Compiled code. This is the second constant in the constant area. */ PolyWord *codePt = pt->ConstPtrForCode(); PolyWord mask = codePt[1]; // A real mask will be an integer. if (IS_INT(mask)) return SAVE(mask); else raise_exception_string(taskData, EXC_Fail, "Invalid mask"); } else raise_exception_string(taskData, EXC_Fail, "Not a code pointer"); } } case 104: return Make_arbitrary_precision(taskData, POLY_version_number); case 105: /* Get the name of the function. */ { PolyObject *pt = DEREFWORDHANDLE(args); if (gMem.IsIOPointer(pt)) { /* IO area. */ int i; for (i=0; i < POLY_SYS_vecsize; i++) { if (pt == (PolyObject*)IoEntry(i)) { char buff[8]; sprintf(buff, "RTS%d", i); return SAVE(C_string_to_Poly(taskData, buff)); } } raise_syscall(taskData, "Io pointer not found", 0); } else if (pt->IsCodeObject()) /* Should now be a code object. */ { /* Compiled code. This is the first constant in the constant area. */ PolyWord *codePt = pt->ConstPtrForCode(); PolyWord name = codePt[0]; /* May be zero indicating an anonymous segment - return null string. */ if (name == PolyWord::FromUnsigned(0)) return SAVE(C_string_to_Poly(taskData, "")); else return SAVE(name); } else raise_syscall(taskData, "Not a code pointer", 0); } default: { char msg[100]; sprintf(msg, "Unknown poly-specific function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } }
Handle timing_dispatch_c(TaskData *taskData, Handle args, Handle code) { unsigned c = get_C_unsigned(taskData, DEREFWORDHANDLE(code)); switch (c) { case 0: /* Get ticks per microsecond. */ return Make_arbitrary_precision(taskData, TICKS_PER_MICROSECOND); case 1: /* Return time since the time base. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ft; GetSystemTimeAsFileTime(&ft); return Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif } case 2: /* Return the base year. This is the year which corresponds to zero in the timing sequence. */ #if (defined(_WIN32) && ! defined(__CYGWIN__)) return Make_arbitrary_precision(taskData, 1601); #else return Make_arbitrary_precision(taskData, 1970); #endif case 3: /* In both Windows and Unix the time base is 1st of January in the base year. This function is provided just in case we are running on a system with a different base. It returns the number of seconds after 1st January of the base year that corresponds to zero of the time base. */ return Make_arbitrary_precision(taskData, 0); case 4: /* Return the time offset which applied/will apply at the specified time (in seconds). */ { int localoff = 0; time_t theTime; int day = 0; #if (defined(HAVE_GMTIME_R) || defined(HAVE_LOCALTIME_R)) struct tm result; #endif #if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Although the offset is in seconds it is since 1601. */ FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */ ULARGE_INTEGER liTime; liTime.HighPart = ftSeconds.dwHighDateTime; liTime.LowPart = ftSeconds.dwLowDateTime; theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else theTime = get_C_long(taskData, DEREFWORDHANDLE(args)); /* May raise exception. */ #endif { #ifdef HAVE_GMTIME_R struct tm *loctime = gmtime_r(&theTime, &result); #else PLocker lock(&timeLock); struct tm *loctime = gmtime(&theTime); #endif if (loctime == NULL) raise_exception0(taskData, EXC_size); localoff = (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec; day = loctime->tm_yday; } { #ifdef HAVE_LOCALTIME_R struct tm *loctime = localtime_r(&theTime, &result); #else PLocker lock(&timeLock); struct tm *loctime = localtime(&theTime); #endif if (loctime == NULL) raise_exception0(taskData, EXC_size); localoff -= (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec; if (loctime->tm_yday != day) { // Different day - have to correct it. We can assume that there // is at most one day to correct. if (day == loctime->tm_yday+1 || (day == 0 && loctime->tm_yday >= 364)) localoff += 24*60*60; else localoff -= 24*60*60; } } return Make_arbitrary_precision(taskData, localoff); } case 5: /* Find out if Summer Time (daylight saving) was/will be in effect. */ { time_t theTime; #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */ ULARGE_INTEGER liTime; liTime.HighPart = ftSeconds.dwHighDateTime; liTime.LowPart = ftSeconds.dwLowDateTime; theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else theTime = get_C_long(taskData, DEREFWORDHANDLE(args)); /* May raise exception. */ #endif int isDst = 0; #ifdef HAVE_LOCALTIME_R struct tm result; struct tm *loctime = localtime_r(&theTime, &result); isDst = loctime->tm_isdst; #else { PLocker lock(&timeLock); struct tm *loctime = localtime(&theTime); if (loctime == NULL) raise_exception0(taskData, EXC_size); isDst = loctime->tm_isdst; } #endif return Make_arbitrary_precision(taskData, isDst); } case 6: /* Call strftime. It would be possible to do much of this in ML except that it requires the current locale. */ { struct tm time; char *format, buff[2048]; Handle resString; /* Get the format string. */ format = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); /* Copy the time information. */ time.tm_year = get_C_int(taskData, DEREFHANDLE(args)->Get(1)) - 1900; time.tm_mon = get_C_int(taskData, DEREFHANDLE(args)->Get(2)); time.tm_mday = get_C_int(taskData, DEREFHANDLE(args)->Get(3)); time.tm_hour = get_C_int(taskData, DEREFHANDLE(args)->Get(4)); time.tm_min = get_C_int(taskData, DEREFHANDLE(args)->Get(5)); time.tm_sec = get_C_int(taskData, DEREFHANDLE(args)->Get(6)); time.tm_wday = get_C_int(taskData, DEREFHANDLE(args)->Get(7)); time.tm_yday = get_C_int(taskData, DEREFHANDLE(args)->Get(8)); time.tm_isdst = get_C_int(taskData, DEREFHANDLE(args)->Get(9)); #if (defined(_WIN32) && ! defined(__CYGWIN__)) _tzset(); /* Make sure we set the current locale. */ #else setlocale(LC_TIME, ""); #endif /* It would be better to dynamically allocate the string rather than use a fixed size but Unix unlike Windows does not distinguish between an error in the input and the buffer being too small. */ if (strftime(buff, sizeof(buff), format, &time) <= 0) { /* Error */ free(format); raise_exception0(taskData, EXC_size); } resString = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); free(format); return resString; } case 7: /* Return User CPU time since the start. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ut, ct, et, kt; if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", 0-GetLastError()); return Make_arb_from_Filetime(taskData, ut); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #endif } case 8: /* Return System CPU time since the start. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ct, et, kt, ut; if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", 0-GetLastError()); return Make_arb_from_Filetime(taskData, kt); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #endif } case 9: /* Return GC time since the start. */ return gHeapSizeParameters.getGCUtime(taskData); case 10: /* Return real time since the start. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) FILETIME ft; GetSystemTimeAsFileTime(&ft); subFiletimes(&ft, &startTime); return Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); subTimevals(&tv, &startTime); return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #endif } /* These next two are used only in the Posix structure. */ case 11: /* Return User CPU time used by child processes. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) return Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #endif } case 12: /* Return System CPU time used by child processes. */ { #if (defined(_WIN32) && ! defined(__CYGWIN__)) return Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #endif } case 13: /* Return GC system time since the start. */ return gHeapSizeParameters.getGCStime(taskData); default: { char msg[100]; sprintf(msg, "Unknown timing function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); return 0; } } }