diff --git a/PolyImp/PolyImport.vcxproj b/PolyImp/PolyImport.vcxproj
index 63901399..c04d17c7 100644
--- a/PolyImp/PolyImport.vcxproj
+++ b/PolyImp/PolyImport.vcxproj
@@ -1,517 +1,517 @@
Debug32in64Win32Debug32in64x64DebugWin32Int32in64DebugWin32Int32in64Debugx64Int32In64ReleaseWin32Int32In64Releasex64IntDebugWin32IntDebugx64IntReleaseWin32IntReleasex64Release32in64Win32Release32in64x64ReleaseWin32Debugx64Releasex64{1BA3E7A2-D64F-4CE3-9FE5-7846B855C19F}PolyImport
- 10.0.15063.0
+ 10.0Applicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3DisabledtrueMultiThreadedDebugtruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0falseLevel3MaxSpeedtruetruetrueMultiThreadedtruetruetruetrueWindows6.0false{0ba5d5b5-f85b-4c49-8a27-67186fa68922}
\ No newline at end of file
diff --git a/PolyML/PolyML.vcxproj b/PolyML/PolyML.vcxproj
index 92b90fc7..4f5e70ac 100644
--- a/PolyML/PolyML.vcxproj
+++ b/PolyML/PolyML.vcxproj
@@ -1,949 +1,949 @@
Debug32in64Win32Debug32in64x64DebugWin32Int32in64DebugWin32Int32in64Debugx64Int32In64ReleaseWin32Int32In64Releasex64IntDebugWin32IntDebugx64IntReleaseWin32IntReleasex64Release32in64Win32Release32in64x64ReleaseWin32Debugx64Releasex64{0326c47a-00af-42cb-b87d-0369a241b570}{0ba5d5b5-f85b-4c49-8a27-67186fa68922}{1ba3e7a2-d64f-4ce3-9fe5-7846b855c19f}truetruetruetruetruetruetruetruecopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txttruetruetruetruetruetruefalsefalsetruetruefalsefalsetruetruetruetruetruetruetruetruecopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txttruetruetruetruetruetruetruetruetruetruefalsetruetruetruefalsetruecopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txt..\polytemp.txtcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.objcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.objcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.objcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.smlcd ..
$(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.obj$(IntDir)polyexport.objcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txttruetruetruetruetruetruetruetruefalsetruetruetruefalsetruetruetruecopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt..\polytemp.txttruetruetruetruetruetruetruetruetruetruefalsetruetruetruetruefalsecopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txtcopy "%(FullPath)" ..\polytemp.txt..\polytemp.txt{DF3B373E-67DF-4AB4-8B1E-F54C5810E2CF}Win32ProjPolyML
- 10.0.15063.0
+ 10.0Applicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationtrue
- v141
+ v142UnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodeApplicationfalse
- v141
+ v142trueUnicodetruetruetruetruetruetruetruetruefalsefalsefalsefalsefalsefalsefalsefalseNotUsingLevel3DisabledWIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseNotUsingLevel3DisabledWIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseNotUsingLevel3DisabledWIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseNotUsingLevel3DisabledWIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseNotUsingLevel3Disabled_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseNotUsingLevel3Disabled_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseNotUsingLevel3Disabled_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseNotUsingLevel3Disabled_DEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruelibcmtd.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueWIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueWIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueWIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueWIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueNDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueNDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueNDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0falseLevel3NotUsingMaxSpeedtruetrueNDEBUG;_WINDOWS;%(PreprocessorDefinitions)Windowstruetruetruelibcmt.lib;kernel32.lib;user32.lib;gdi32.lib;winspool.lib;comdlg32.lib;advapi32.lib;shell32.lib;ole32.lib;oleaut32.lib;uuid.lib;odbc32.lib;odbccp32.lib;%(AdditionalDependencies)true6.0false
\ No newline at end of file
diff --git a/PolyPerf/PolyPerf.vcxproj b/PolyPerf/PolyPerf.vcxproj
index 0c312127..ee6b009b 100644
--- a/PolyPerf/PolyPerf.vcxproj
+++ b/PolyPerf/PolyPerf.vcxproj
@@ -1,369 +1,369 @@
Debug32in64Win32Debug32in64x64DebugWin32Int32in64DebugWin32Int32in64Debugx64Int32In64ReleaseWin32Int32In64Releasex64Release32in64Win32Release32in64x64ReleaseWin32Debugx64Releasex64{D9F58E8D-5FCD-4401-8D88-0C28732BD77B}PolyPerf
- 10.0.15063.0
+ 10.0DynamicLibrarytrue
- v141
+ v142MultiByteDynamicLibrarytrue
- v141
+ v142MultiByteDynamicLibrarytrue
- v141
+ v142MultiByteDynamicLibraryfalse
- v141
+ v142trueMultiByteDynamicLibraryfalse
- v141
+ v142trueMultiByteDynamicLibraryfalse
- v141
+ v142trueMultiByteDynamicLibrarytrue
- v141
+ v142MultiByteDynamicLibrarytrue
- v141
+ v142MultiByteDynamicLibrarytrue
- v141
+ v142MultiByteDynamicLibraryfalse
- v141
+ v142trueMultiByteDynamicLibraryfalse
- v141
+ v142trueMultiByteDynamicLibraryfalse
- v141
+ v142trueMultiByteLevel3Disabledtrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truepsapi.lib;%(AdditionalDependencies)WindowsLevel3Disabledtrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truepsapi.lib;%(AdditionalDependencies)WindowsLevel3Disabledtrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truepsapi.lib;%(AdditionalDependencies)WindowsLevel3Disabledtrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truepsapi.lib;%(AdditionalDependencies)WindowsLevel3Disabledtrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truepsapi.lib;%(AdditionalDependencies)WindowsLevel3Disabledtrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truepsapi.lib;%(AdditionalDependencies)WindowsLevel3MaxSpeedtruetruetrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truetruetruepsapi.lib;%(AdditionalDependencies)WindowsLevel3MaxSpeedtruetruetrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truetruetruepsapi.lib;%(AdditionalDependencies)WindowsLevel3MaxSpeedtruetruetrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truetruetruepsapi.lib;%(AdditionalDependencies)WindowsLevel3MaxSpeedtruetruetrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truetruetruepsapi.lib;%(AdditionalDependencies)WindowsLevel3MaxSpeedtruetruetrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truetruetruepsapi.lib;%(AdditionalDependencies)WindowsLevel3MaxSpeedtruetruetrue_CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions)truetruetruepsapi.lib;%(AdditionalDependencies)Windows
\ No newline at end of file
diff --git a/Tests/Succeed/Test189.ML b/Tests/Succeed/Test189.ML
index 89c8ee8c..5a6983a8 100644
--- a/Tests/Succeed/Test189.ML
+++ b/Tests/Succeed/Test189.ML
@@ -1,34 +1,19 @@
-(* Unix socket test - Test078 converted to Unix socket *)
-case #lookupStruct (PolyML.globalNameSpace) "UnixSock" of
+(* Test Unix.execute. *)
+case #lookupStruct (PolyML.globalNameSpace) "Unix" of
SOME _ => ()
| NONE => raise NotApplicable;
-val x = UnixSock.Strm.socket(): Socket.passive UnixSock.stream_sock
-and y = UnixSock.Strm.socket(): Socket.active UnixSock.stream_sock;
+if OS.FileSys.access("/bin/ls", [OS.FileSys.A_EXEC]) then () else raise NotApplicable;
-val name = OS.FileSys.tmpName();
-OS.FileSys.remove name handle OS.SysErr _ => ();
+val dirExec: (TextIO.instream, TextIO.outstream) Unix.proc = Unix.execute("/bin/ls", ["."]);
+TextIO.closeOut(Unix.textOutstreamOf dirExec);
+val instr = Unix.textInstreamOf dirExec;
+TextIO.inputAll instr;
+TextIO.closeIn instr;
+(* This is defined to be able to repeatedly return a result. *)
+val res1 = Unix.reap dirExec;
+val res2 = Unix.reap dirExec;
-Socket.bind(x, UnixSock.toAddr name);
-Socket.listen(x, 5);
+OS.Process.isSuccess res1;
+OS.Process.isSuccess res2;
-Socket.connect(y, UnixSock.toAddr name);
-
-val (cnct, _) = Socket.accept x;
-
-(* Send the data. Use a separate thread so there's no possibility of blocking. *)
-let
- fun sendData() =
- (Socket.sendVec(y, Word8VectorSlice.full(Byte.stringToBytes "A test")); ())
-in
- Thread.Thread.fork(sendData, [])
-end;
-
-if Byte.bytesToString(Socket.recvVec(cnct, 6)) <> "A test"
-then raise Fail "failed"
-else ();
-
-Socket.close cnct;
-Socket.close x;
-Socket.close y;
-OS.FileSys.remove name handle OS.SysErr _ => ();
diff --git a/Tests/Succeed/Test190.ML b/Tests/Succeed/Test190.ML
new file mode 100644
index 00000000..1bbbad3a
--- /dev/null
+++ b/Tests/Succeed/Test190.ML
@@ -0,0 +1,18 @@
+(* After a Posix fork there is only one thread in the child.
+ There could be a GC before any exec so this is a check that it works. *)
+case #lookupStruct (PolyML.globalNameSpace) "Posix" of
+ SOME _ => ()
+| NONE => raise NotApplicable;
+
+let
+ open Posix.Process
+in
+case fork() of
+ NONE =>
+ (
+ PolyML.fullGC();
+ exit 0w0
+ )
+ | SOME pid => waitpid(W_CHILD pid, [])
+end;
+
diff --git a/Tests/Succeed/Test189.ML b/Tests/Succeed/Test191.ML
similarity index 100%
copy from Tests/Succeed/Test189.ML
copy to Tests/Succeed/Test191.ML
diff --git a/basis/Posix.sml b/basis/Posix.sml
index b8274b00..b016e2f8 100644
--- a/basis/Posix.sml
+++ b/basis/Posix.sml
@@ -1,1706 +1,1710 @@
(*
Title: Standard Basis Library: Posix structure and signature.
Copyright David Matthews 2000, 2016-17, 2019
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*)
signature POSIX_ERROR =
sig
type syserror = OS.syserror (* G&R 2004 has an error *)
val toWord : syserror -> SysWord.word
val fromWord : SysWord.word -> syserror
val errorMsg : syserror -> string
val errorName : syserror -> string
val syserror : string -> syserror option
val acces : syserror
val again : syserror
val badf : syserror
val badmsg : syserror
val busy : syserror
val canceled (* sic *) : syserror
val child : syserror
val deadlk : syserror
val dom : syserror
val exist : syserror
val fault : syserror
val fbig : syserror
val inprogress : syserror
val intr : syserror
val inval : syserror
val io : syserror
val isdir : syserror
val loop : syserror
val mfile : syserror
val mlink : syserror
val msgsize : syserror
val nametoolong : syserror
val nfile : syserror
val nodev : syserror
val noent : syserror
val noexec : syserror
val nolck : syserror
val nomem : syserror
val nospc : syserror
val nosys : syserror
val notdir : syserror
val notempty : syserror
val notsup : syserror
val notty : syserror
val nxio : syserror
val perm : syserror
val pipe : syserror
val range : syserror
val rofs : syserror
val spipe : syserror
val srch : syserror
val toobig : syserror
val xdev : syserror
end;
signature POSIX_SIGNAL =
sig
eqtype signal
val toWord : signal -> SysWord.word
val fromWord : SysWord.word -> signal
val abrt : signal
val alrm : signal
val bus : signal
val fpe : signal
val hup : signal
val ill : signal
val int : signal
val kill : signal
val pipe : signal
val quit : signal
val segv : signal
val term : signal
val usr1 : signal
val usr2 : signal
val chld : signal
val cont : signal
val stop : signal
val tstp : signal
val ttin : signal
val ttou : signal
end;
signature POSIX_PROCESS =
sig
eqtype signal
eqtype pid
val wordToPid : SysWord.word -> pid
val pidToWord : pid -> SysWord.word
val fork : unit -> pid option
val exec : string * string list -> 'a
val exece : string * string list * string list -> 'a
val execp : string * string list -> 'a
datatype waitpid_arg =
W_ANY_CHILD | W_CHILD of pid | W_SAME_GROUP | W_GROUP of pid
datatype exit_status =
W_EXITED | W_EXITSTATUS of Word8.word
| W_SIGNALED (* sic *) of signal | W_STOPPED of signal
val fromStatus : OS.Process.status -> exit_status
structure W:
sig
include BIT_FLAGS
val untraced : flags
end
val wait : unit -> pid * exit_status
val waitpid : waitpid_arg * W.flags list -> pid * exit_status
val waitpid_nh : waitpid_arg * W.flags list -> (pid * exit_status) option
val exit : Word8.word -> 'a
datatype killpid_arg = K_PROC of pid | K_SAME_GROUP | K_GROUP of pid
val kill : killpid_arg * signal -> unit
val alarm : Time.time -> Time.time
val pause : unit -> unit
val sleep : Time.time -> Time.time
end;
signature POSIX_PROC_ENV =
sig
eqtype pid
eqtype uid
eqtype gid
eqtype file_desc
val uidToWord : uid -> SysWord.word
val wordToUid : SysWord.word -> uid
val gidToWord : gid -> SysWord.word
val wordToGid : SysWord.word -> gid
val getpid : unit -> pid
val getppid : unit -> pid
val getuid : unit -> uid
val geteuid : unit -> uid
val getgid : unit -> gid
val getegid : unit -> gid
val setuid : uid -> unit
val setgid : gid -> unit
val getgroups : unit -> gid list
val getlogin : unit -> string
val getpgrp : unit -> pid
val setsid : unit -> pid
val setpgid : {pid : pid option, pgid : pid option} -> unit
val uname : unit -> (string * string) list
val time : unit -> Time.time
val times : unit
-> {
elapsed : Time.time,
utime : Time.time,
stime : Time.time,
cutime : Time.time,
cstime : Time.time
}
val getenv : string -> string option
val environ : unit -> string list
val ctermid : unit -> string
val ttyname : file_desc -> string
val isatty : file_desc -> bool
val sysconf : string -> SysWord.word
end;
signature POSIX_FILE_SYS =
sig
eqtype uid
eqtype gid
eqtype file_desc
val fdToWord : file_desc -> SysWord.word
val wordToFD : SysWord.word -> file_desc
val fdToIOD : file_desc -> OS.IO.iodesc
val iodToFD : OS.IO.iodesc -> file_desc option
type dirstream
val opendir : string -> dirstream
val readdir : dirstream -> string option
val rewinddir : dirstream -> unit
val closedir : dirstream -> unit
val chdir : string -> unit
val getcwd : unit -> string
val stdin : file_desc
val stdout : file_desc
val stderr : file_desc
structure S :
sig
eqtype mode
include BIT_FLAGS
where type flags = mode
val irwxu : mode
val irusr : mode
val iwusr : mode
val ixusr : mode
val irwxg : mode
val irgrp : mode
val iwgrp : mode
val ixgrp : mode
val irwxo : mode
val iroth : mode
val iwoth : mode
val ixoth : mode
val isuid : mode
val isgid : mode
end
structure O:
sig
include BIT_FLAGS
val append : flags
val excl : flags
val noctty : flags
val nonblock : flags
val sync : flags
val trunc : flags
end
datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR
val openf : string * open_mode * O.flags -> file_desc
val createf : string * open_mode * O.flags * S.mode -> file_desc
val creat : string * S.mode -> file_desc
val umask : S.mode -> S.mode
val link : {old : string, new : string} -> unit
val mkdir : string * S.mode -> unit
val mkfifo : string * S.mode -> unit
val unlink : string -> unit
val rmdir : string -> unit
val rename : {old : string, new : string} -> unit
val symlink : {old : string, new : string} -> unit
val readlink : string -> string
eqtype dev
val wordToDev : SysWord.word -> dev
val devToWord : dev -> SysWord.word
eqtype ino
val wordToIno : SysWord.word -> ino
val inoToWord : ino -> SysWord.word
structure ST:
sig
type stat
val isDir : stat -> bool
val isChr : stat -> bool
val isBlk : stat -> bool
val isReg : stat -> bool
val isFIFO : stat -> bool
val isLink : stat -> bool
val isSock : stat -> bool
val mode : stat -> S.mode
val ino : stat -> ino
val dev : stat -> dev
val nlink : stat -> int
val uid : stat -> uid
val gid : stat -> gid
val size : stat -> Position.int
val atime : stat -> Time.time
val mtime : stat -> Time.time
val ctime : stat -> Time.time
end
val stat : string -> ST.stat
val lstat : string -> ST.stat
val fstat : file_desc -> ST.stat
datatype access_mode = A_READ | A_WRITE | A_EXEC
val access : string * access_mode list -> bool
val chmod : string * S.mode -> unit
val fchmod : file_desc * S.mode -> unit
val chown : string * uid * gid -> unit
val fchown : file_desc * uid * gid -> unit
val utime : string * {actime : Time.time, modtime : Time.time} option -> unit
val ftruncate : file_desc * Position.int -> unit
val pathconf : string * string -> SysWord.word option
val fpathconf : file_desc * string -> SysWord.word option
end;
signature POSIX_IO =
sig
eqtype file_desc
eqtype pid
val pipe: unit -> {infd : file_desc, outfd : file_desc}
val dup: file_desc -> file_desc
val dup2: {old : file_desc, new : file_desc} -> unit
val close: file_desc -> unit
val readVec : file_desc * int -> Word8Vector.vector
val readArr: file_desc * Word8ArraySlice.slice -> int
val writeVec: file_desc * Word8VectorSlice.slice -> int
val writeArr: file_desc * Word8ArraySlice.slice -> int
datatype whence = SEEK_SET | SEEK_CUR | SEEK_END
structure FD:
sig
include BIT_FLAGS
val cloexec: flags
end
structure O:
sig
include BIT_FLAGS
val append : flags
val nonblock : flags
val sync : flags
end
datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR
val dupfd : {old : file_desc, base : file_desc} -> file_desc
val getfd : file_desc -> FD.flags
val setfd : file_desc * FD.flags -> unit
val getfl : file_desc -> O.flags * open_mode
val setfl : file_desc * O.flags -> unit
val lseek : file_desc * Position.int * whence -> Position.int
val fsync : file_desc -> unit
datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK
structure FLock:
sig
type flock
val flock : {
ltype : lock_type,
whence : whence,
start : Position.int,
len : Position.int,
pid : pid option
} -> flock
val ltype : flock -> lock_type
val whence : flock -> whence
val start : flock -> Position.int
val len : flock -> Position.int
val pid : flock -> pid option
end
val getlk : file_desc * FLock.flock -> FLock.flock
val setlk : file_desc * FLock.flock -> FLock.flock
val setlkw : file_desc * FLock.flock -> FLock.flock
val mkBinReader:
{ fd : file_desc, name : string, initBlkMode : bool } -> BinPrimIO.reader
val mkTextReader:
{ fd : file_desc, name : string, initBlkMode : bool } -> TextPrimIO.reader
val mkBinWriter:
{ fd : file_desc, name : string, appendMode : bool,
initBlkMode : bool, chunkSize : int } -> BinPrimIO.writer
val mkTextWriter:
{ fd : file_desc, name : string, appendMode : bool,
initBlkMode : bool, chunkSize : int } -> TextPrimIO.writer
end;
signature POSIX_SYS_DB =
sig
eqtype uid
eqtype gid
structure Passwd :
sig
type passwd
val name : passwd -> string
val uid : passwd -> uid
val gid : passwd -> gid
val home : passwd -> string
val shell : passwd -> string
end
structure Group :
sig
type group
val name : group -> string
val gid : group -> gid
val members : group -> string list
end
val getgrgid : gid -> Group.group
val getgrnam : string -> Group.group
val getpwuid : uid -> Passwd.passwd
val getpwnam : string -> Passwd.passwd
end;
signature POSIX_TTY =
sig
eqtype pid
eqtype file_desc
structure V :
sig
val eof : int
val eol : int
val erase : int
val intr : int
val kill : int
val min : int
val quit : int
val susp : int
val time : int
val start : int
val stop : int
val nccs : int
type cc
val cc : (int * char) list -> cc
val update : cc * (int * char) list -> cc
val sub : cc * int -> char
end
structure I :
sig
include BIT_FLAGS
val brkint : flags
val icrnl : flags
val ignbrk : flags
val igncr : flags
val ignpar : flags
val inlcr : flags
val inpck : flags
val istrip : flags
val ixoff : flags
val ixon : flags
val parmrk : flags
end
structure O :
sig
include BIT_FLAGS
val opost : flags
end
structure C :
sig
include BIT_FLAGS
val clocal : flags
val cread : flags
val cs5 : flags
val cs6 : flags
val cs7 : flags
val cs8 : flags
val csize : flags
val cstopb : flags
val hupcl : flags
val parenb : flags
val parodd : flags
end
structure L :
sig
include BIT_FLAGS
val echo : flags
val echoe : flags
val echok : flags
val echonl : flags
val icanon : flags
val iexten : flags
val isig : flags
val noflsh : flags
val tostop : flags
end
eqtype speed
val compareSpeed : speed * speed -> order
val speedToWord : speed -> SysWord.word
val wordToSpeed : SysWord.word -> speed
val b0 : speed
val b50 : speed
val b75 : speed
val b110 : speed
val b134 : speed
val b150 : speed
val b200 : speed
val b300 : speed
val b600 : speed
val b1200 : speed
val b1800 : speed
val b2400 : speed
val b4800 : speed
val b9600 : speed
val b19200 : speed
val b38400 : speed
type termios
val termios : {
iflag : I.flags,
oflag : O.flags,
cflag : C.flags,
lflag : L.flags,
cc : V.cc,
ispeed : speed,
ospeed : speed
} -> termios
val fieldsOf : termios
-> {
iflag : I.flags,
oflag : O.flags,
cflag : C.flags,
lflag : L.flags,
cc : V.cc,
ispeed : speed,
ospeed : speed
}
val getiflag : termios -> I.flags
val getoflag : termios -> O.flags
val getcflag : termios -> C.flags
val getlflag : termios -> L.flags
val getcc : termios -> V.cc
structure CF :
sig
val getospeed : termios -> speed
val setospeed : termios * speed -> termios
val getispeed : termios -> speed
val setispeed : termios * speed -> termios
end
structure TC :
sig
eqtype set_action
val sanow : set_action
val sadrain : set_action
val saflush : set_action
eqtype flow_action
val ooff : flow_action
val oon : flow_action
val ioff : flow_action
val ion : flow_action
eqtype queue_sel
val iflush : queue_sel
val oflush : queue_sel
val ioflush : queue_sel
val getattr : file_desc -> termios
val setattr : file_desc * set_action * termios -> unit
val sendbreak : file_desc * int -> unit
val drain : file_desc -> unit
val flush : file_desc * queue_sel -> unit
val flow : file_desc * flow_action -> unit
end
val getpgrp : file_desc -> pid
val setpgrp : file_desc * pid -> unit
end;
signature POSIX =
sig
structure Error : POSIX_ERROR
structure Signal : POSIX_SIGNAL
structure Process : POSIX_PROCESS
where type signal = Signal.signal
structure ProcEnv : POSIX_PROC_ENV
where type pid = Process.pid
structure FileSys : POSIX_FILE_SYS
where type file_desc = ProcEnv.file_desc
where type uid = ProcEnv.uid
where type gid = ProcEnv.gid
structure IO : POSIX_IO
where type pid = Process.pid
where type file_desc = ProcEnv.file_desc
where type open_mode = FileSys.open_mode
structure SysDB : POSIX_SYS_DB
where type uid = ProcEnv.uid
where type gid = ProcEnv.gid
structure TTY : POSIX_TTY
where type pid = Process.pid
where type file_desc = ProcEnv.file_desc
end;
structure Posix :>
sig include POSIX
(* I'm not sure if it's legal to use where type with
a datatype. The alternative is to copy the whole
of the signature and use datatype replication. *)
where type FileSys.access_mode = OS.FileSys.access_mode
sharing type Process.pid = ProcEnv.pid = IO.pid = TTY.pid
sharing type ProcEnv.uid = FileSys.uid = SysDB.uid
sharing type ProcEnv.gid = FileSys.gid = SysDB.gid
sharing type ProcEnv.file_desc = FileSys.file_desc =
IO.file_desc = TTY.file_desc
end
(* Posix.Signal.signal is made the same as int so that we can
pass the values directly to our (non-standard) Signal.signal
function. Since there isn't a standard way of handling
signals this is the best we can do. *)
where type Signal.signal = int
where type FileSys.dirstream = OS.FileSys.dirstream
=
struct
local
val osSpecificGeneralCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral"
in
fun osSpecificGeneral(code: int, arg:'a):'b = RunCall.unsafeCast(osSpecificGeneralCall(RunCall.unsafeCast(code, arg)))
end
fun getConst i : SysWord.word = osSpecificGeneral (4, i)
structure BitFlags =
(* This structure is used as the basis of all the BIT_FLAGS structures. *)
struct
type flags = SysWord.word
fun toWord f = f
fun fromWord f = f
val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0
fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1
fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0
fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2)
end
structure Error =
struct
type syserror = OS.syserror (* Implemented as a SysWord.word value. *)
val errorMsg = OS.errorMsg
val toWord = LibrarySupport.syserrorToWord
and fromWord = LibrarySupport.syserrorFromWord
val toobig = fromWord(getConst 0)
and acces = fromWord(getConst 1)
and again = fromWord(getConst 2)
and badf = fromWord(getConst 3)
and badmsg = fromWord(getConst 4)
and busy = fromWord(getConst 5)
and canceled (* sic *) = fromWord(getConst 6)
and child = fromWord(getConst 7)
and deadlk = fromWord(getConst 8)
and dom = fromWord(getConst 9)
and exist = fromWord(getConst 10)
and fault = fromWord(getConst 11)
and fbig = fromWord(getConst 12)
and inprogress = fromWord(getConst 13)
and intr = fromWord(getConst 14)
and inval = fromWord(getConst 15)
and io = fromWord(getConst 16)
and isdir = fromWord(getConst 17)
and loop = fromWord(getConst 18)
and mfile = fromWord(getConst 19)
and mlink = fromWord(getConst 20)
and msgsize = fromWord(getConst 21)
and nametoolong = fromWord(getConst 22)
and nfile = fromWord(getConst 23)
and nodev = fromWord(getConst 24)
and noent = fromWord(getConst 25)
and noexec = fromWord(getConst 26)
and nolck = fromWord(getConst 27)
and nomem = fromWord(getConst 28)
and nospc = fromWord(getConst 29)
and nosys = fromWord(getConst 30)
and notdir = fromWord(getConst 31)
and notempty = fromWord(getConst 32)
and notsup = fromWord(getConst 33)
and notty = fromWord(getConst 34)
and nxio = fromWord(getConst 35)
and perm = fromWord(getConst 36)
and pipe = fromWord(getConst 37)
and range = fromWord(getConst 38)
and rofs = fromWord(getConst 39)
and spipe = fromWord(getConst 40)
and srch = fromWord(getConst 41)
and xdev = fromWord(getConst 42)
val errNames =
[
(acces, "acces"),
(again, "again"),
(badf, "badf"),
(badmsg, "badmsg"),
(busy, "busy"),
(canceled, "canceled"),
(child, "child"),
(deadlk, "deadlk"),
(dom, "dom"),
(exist, "exist"),
(fault, "fault"),
(fbig, "fbig"),
(inprogress, "inprogress"),
(intr, "intr"),
(inval, "inval"),
(io, "io"),
(isdir, "isdir"),
(loop, "loop"),
(mfile, "mfile"),
(mlink, "mlink"),
(msgsize, "msgsize"),
(nametoolong, "nametoolong"),
(nfile, "nfile"),
(nodev, "nodev"),
(noent, "noent"),
(noexec, "noexec"),
(nolck, "nolck"),
(nomem, "nomem"),
(nospc, "nospc"),
(nosys, "nosys"),
(notdir, "notdir"),
(notempty, "notempty"),
(notsup, "notsup"),
(notty, "notty"),
(nxio, "nxio"),
(perm, "perm"),
(pipe, "pipe"),
(range, "range"),
(rofs, "rofs"),
(spipe, "spipe"),
(srch, "srch"),
(toobig, "toobig"),
(xdev, "xdev")
]
(* These are defined to return the names above. *)
fun errorName n =
case List.find (fn (e, _) => e = n) errNames of
SOME(_, s) => s
| NONE => OS.errorName n
fun syserror s =
case List.find (fn (_, t) => s = t) errNames of
SOME(e, _) => SOME e
| NONE => OS.syserror s
end;
structure Signal =
struct
type signal = int
val toWord = SysWord.fromInt
and fromWord = SysWord.toInt
(* These signal values are probably defined to correspond
to particular numbers but there's no harm in getting
them from the RTS. *)
val abrt = fromWord(getConst 43)
and alrm = fromWord(getConst 44)
and bus = fromWord(getConst 45)
and fpe = fromWord(getConst 46)
and hup = fromWord(getConst 47)
and ill = fromWord(getConst 48)
and int = fromWord(getConst 49)
and kill = fromWord(getConst 50)
and pipe = fromWord(getConst 51)
and quit = fromWord(getConst 52)
and segv = fromWord(getConst 53)
and term = fromWord(getConst 54)
and usr1 = fromWord(getConst 55)
and usr2 = fromWord(getConst 56)
and chld = fromWord(getConst 57)
and cont = fromWord(getConst 58)
and stop = fromWord(getConst 59)
and tstp = fromWord(getConst 60)
and ttin = fromWord(getConst 61)
and ttou = fromWord(getConst 62)
end;
structure Process =
struct
type signal = Signal.signal
type pid = int
val pidToWord = SysWord.fromInt
and wordToPid = SysWord.toInt
datatype waitpid_arg =
W_ANY_CHILD | W_CHILD of pid | W_SAME_GROUP | W_GROUP of pid
datatype exit_status =
W_EXITED | W_EXITSTATUS of Word8.word
| W_SIGNALED of signal | W_STOPPED of signal
datatype killpid_arg = K_PROC of pid | K_SAME_GROUP | K_GROUP of pid
structure W =
struct
open BitFlags
val untraced = getConst 133
val nohang = getConst 134 (* Not exported. *)
val all = flags [ untraced, nohang]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
local
val doCall = osSpecificGeneral
in
fun fork () =
case doCall(5, ()) of
0 => NONE (* Parent *)
| n => SOME n (* Child *)
end
local
val doCall = osSpecificGeneral
in
(* Map the pid argument to positive, zero or
negative. *)
fun kill (K_PROC pid, si) = doCall(6,(pid, si))
| kill (K_SAME_GROUP, si) = doCall(6, (0, si))
| kill (K_GROUP pid, si) = doCall(6, (~pid, si))
end
local
val doCall = osSpecificGeneral
in
(* The format of a result may well be sufficiently fixed
that we could decode it without calling the RTS. It's
probably worth the small cost to make maintenance easier. *)
fun fromStatus (stat: OS.Process.status): exit_status =
case (doCall(15, stat)) of
(1, 0) => W_EXITED
| (1, n) => W_EXITSTATUS(Word8.fromInt n)
| (2, n) => W_SIGNALED n
| (3, n) => W_STOPPED n
| _ => raise Fail "Unknown result status"
end
local
val doCall = osSpecificGeneral
fun doWait(kind: int, pid: pid, flags: W.flags list) =
let
val (pid, status) =
doCall(14, (kind, pid,
SysWord.toInt(W.flags flags)))
in
(pid, fromStatus status)
end
in
fun waitpid(W_ANY_CHILD, flags) = doWait(0, 0, flags)
| waitpid(W_CHILD pid, flags) = doWait(1, pid, flags)
| waitpid(W_SAME_GROUP, flags) = doWait(2, 0, flags)
| waitpid(W_GROUP pid, flags) = doWait(3, pid, flags)
fun wait() = waitpid(W_ANY_CHILD, [])
fun waitpid_nh(wpa, flags) =
let
val (pid, status) = waitpid(wpa, W.nohang :: flags)
in
if pid = 0 then NONE else SOME(pid, status)
end
end
fun exec(p, args) =
osSpecificGeneral(17, (p, args))
and exece(p, args, env) =
osSpecificGeneral(18, (p, args, env))
and execp(p, args) =
osSpecificGeneral(19, (p, args))
(* The definition of "exit" is obviously designed to allow
OS.Process.exit to be defined in terms of it. In particular
it doesn't execute the functions registered with atExit. *)
local
val doExit: Word8.word -> unit = RunCall.rtsCallFull1 "PolyFinish"
in
fun exit w =
(
doExit w;
raise Bind (* Never executed but gives the correct result type.*)
)
end
local
val doCall = osSpecificGeneral
in
(* This previously used absolute times. Now uses relative. *)
fun alarm t = doCall(20, t)
end
local
(* The underlying call waits for up to a second. It takes the count of signals that
have been received and returns the last count. This is necessary in case
a signal is received while we are in ML between calls to the RTS. *)
val doCall: int * int -> int = RunCall.rtsCallFull2 "PolyPosixSleep"
in
(* Sleep for a period. Returns the unused wait time. *)
fun sleep sleepTime =
let
val endTime = sleepTime + Time.now()
val maxWait = 1000 (* Wait for up to a second *)
val initialCount = doCall (0, 0)
fun doWait () =
let
val timeToGo =
LargeInt.min(Time.toMilliseconds(endTime-Time.now()), LargeInt.fromInt maxWait)
in
if timeToGo <= 0 orelse doCall(LargeInt.toInt timeToGo, initialCount) <> initialCount
then (* Time has expired or we were interrupted. *)
let
val now = Time.now()
in
if endTime > now
then endTime-now
else Time.fromSeconds 0
end
else doWait() (* Resume the wait *)
end
in
doWait()
end
and pause() =
let
val initialCount = doCall(0, 0)
fun doPause() = if doCall(1000, initialCount) <> initialCount then () else doPause()
in
doPause()
end
end
end;
structure ProcEnv =
struct
type pid = Process.pid and file_desc = OS.IO.iodesc
type uid = int and gid = int
val uidToWord = SysWord.fromInt
and wordToUid = SysWord.toInt
and gidToWord = SysWord.fromInt
and wordToGid = SysWord.toInt
local
val doCall = osSpecificGeneral
in
fun getpid () = doCall(7, ())
and getppid () = doCall(8, ())
and getuid () = doCall(9, ())
and geteuid () = doCall(10, ())
and getgid () = doCall(11, ())
and getegid () = doCall(12, ())
and getpgrp () = doCall(13, ())
and setsid () = doCall(27, ())
end
val getenv = OS.Process.getEnv
val environ = RunCall.rtsCallFull0 "PolyGetEnvironment"
local
val doCall = osSpecificGeneral
in
fun setuid(u: uid) = doCall(23, u)
and setgid(g: gid) = doCall(24, g)
end
local
val doCall = osSpecificGeneral
in
fun getgroups() = doCall(25, ())
end
local
val doCall = osSpecificGeneral
in
fun getlogin() = doCall(26, ())
and ctermid() = doCall(30, ())
end
local
val doCall = osSpecificGeneral
in
(* In each case NONE as an argument is taken as 0. *)
fun setpgid{pid, pgid} = doCall(28, (getOpt(pid, 0), getOpt(pgid, 0)))
end
local
val doCall = osSpecificGeneral
in
fun uname() = doCall(29, ())
end
val time = Time.now
local
(* Apart from the child times all these could be obtained by calling the Timer functions. *)
val getUserTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetUser"
and getSysTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetSystem"
and getRealTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetReal"
and getChildUserTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetChildUser"
and getChildSysTime: unit -> Time.time = RunCall.rtsCallFull0 "PolyTimingGetChildSystem"
in
fun times() =
{ elapsed=getRealTime(), utime=getUserTime(), stime=getSysTime(),
cutime=getChildUserTime(), cstime=getChildSysTime()}
end
local
val doCall = osSpecificGeneral
in
fun ttyname(f: file_desc) = doCall(31, f)
end
local
val doCall = osSpecificGeneral
in
fun isatty(f: file_desc) = doCall(32, f)
end
local
val doCall = osSpecificGeneral
in
fun sysconf(s: string) = SysWord.fromInt(doCall(33, s))
end
end;
structure FileSys =
struct
type uid = ProcEnv.uid and gid = ProcEnv.gid
type file_desc = OS.IO.iodesc
type dirstream = OS.FileSys.dirstream
datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR
structure O =
struct
open BitFlags
val append = getConst 66
and excl = getConst 67
and noctty = getConst 68
and nonblock = getConst 69
and sync = getConst 70
and trunc = getConst 71
val all = flags [append, excl, noctty, nonblock, sync, trunc]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
local
val doIo: int*file_desc*unit -> int = RunCall.rtsCallFull3 "PolyBasicIOGeneral"
in
fun fdToWord (f: file_desc) = SysWord.fromInt(doIo(30, f, ()))
end
local
val doIo: int*unit*int -> file_desc = RunCall.rtsCallFull3 "PolyBasicIOGeneral"
in
fun wordToFD(s: SysWord.word): file_desc =
doIo(31, (), SysWord.toInt s)
end
(* file_desc and OS.IO.iodesc are the same. *)
fun fdToIOD i = i
and iodToFD i = SOME i
val opendir = OS.FileSys.openDir
and readdir = OS.FileSys.readDir
and rewinddir = OS.FileSys.rewindDir
and closedir = OS.FileSys.closeDir
and chdir = OS.FileSys.chDir
and getcwd = OS.FileSys.getDir
and unlink = OS.FileSys.remove
and rmdir = OS.FileSys.rmDir
and rename = OS.FileSys.rename
and readlink = OS.FileSys.readLink
- val stdin : file_desc = RunCall.unsafeCast 0
- and stdout : file_desc = RunCall.unsafeCast 1
- and stderr : file_desc = RunCall.unsafeCast 2
+ local
+ val persistentFD: int -> file_desc = RunCall.rtsCallFull1 "PolyPosixCreatePersistentFD"
+ in
+ val stdin : file_desc = persistentFD 0
+ and stdout : file_desc = persistentFD 1
+ and stderr : file_desc = persistentFD 2
+ end
structure S =
struct
open BitFlags
type mode = flags
val irusr : mode = getConst 145
and iwusr : mode = getConst 146
and ixusr : mode = getConst 147
val irwxu : mode = flags[irusr, iwusr, ixusr]
val irgrp : mode = getConst 148
and iwgrp : mode = getConst 149
and ixgrp : mode = getConst 150
val irwxg : mode = flags[irgrp, iwgrp, ixgrp]
val iroth : mode = getConst 151
and iwoth : mode = getConst 152
and ixoth : mode = getConst 153
val irwxo : mode = flags[iroth, iwoth, ixoth]
val isuid : mode = getConst 154
val isgid : mode = getConst 155
val all = flags [irwxu, irwxg, irwxo, isuid, isgid]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
local
val o_rdonly = getConst 63
and o_wronly = getConst 64
and o_rdwr = getConst 65
fun toBits O_RDONLY = o_rdonly
| toBits O_WRONLY = o_wronly
| toBits O_RDWR = o_rdwr
val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral"
in
fun openf(name, mode, flags) =
let
val bits = SysWord.orb(flags, toBits mode)
in
doIo(70, 0, (name, SysWord.toInt bits, 0))
end
and createf(name, mode, flags, smode) =
let
val bits = SysWord.orb(flags, toBits mode)
in
doIo(71, 0, (name, SysWord.toInt bits, SysWord.toInt smode))
end
end
fun creat(s, m) = createf(s, O_WRONLY, O.trunc, m)
local
val doCall = osSpecificGeneral
in
fun umask m = SysWord.fromInt(doCall(50, SysWord.toInt m))
end
local
val doCall = osSpecificGeneral
in
fun link{old, new} = doCall(51, (old, new))
and symlink{old, new} = doCall(54, (old, new))
end
local
val doCall = osSpecificGeneral
in
fun mkdir(name, mode) = doCall(52, (name, SysWord.toInt mode))
and mkfifo(name, mode) = doCall(53, (name, SysWord.toInt mode))
and chmod(name, mode) = doCall(59, (name, SysWord.toInt mode))
end
type dev = LargeInt.int and ino = LargeInt.int
val wordToDev = SysWord.toLargeInt
and devToWord = SysWord.fromLargeInt
and wordToIno = SysWord.toLargeInt
and inoToWord = SysWord.fromLargeInt
structure ST =
struct
type stat = { mode: S.mode, kind: int, ino: ino, dev: dev,
nlink: int, uid: uid, gid: gid, size: Position.int,
atime: Time.time, mtime: Time.time, ctime: Time.time }
(* The "kind" information is encoded by "stat" *)
fun isDir({ kind, ...} : stat) = kind = 1
and isChr({ kind, ...} : stat) = kind = 2
and isBlk({ kind, ...} : stat) = kind = 3
and isReg({ kind, ...} : stat) = kind = 0
and isFIFO({ kind, ...} : stat) = kind = 4
and isLink({ kind, ...} : stat) = kind = 5
and isSock({ kind, ...} : stat) = kind = 6
val mode : stat -> S.mode = #mode
and ino : stat -> ino = #ino
val dev : stat -> dev = #dev
val nlink : stat -> int = #nlink
val uid : stat -> uid = #uid
val gid : stat -> gid = #gid
val size : stat -> Position.int = #size
val atime : stat -> Time.time = #atime
val mtime : stat -> Time.time = #mtime
val ctime : stat -> Time.time = #ctime
end
local
val doCall1 = osSpecificGeneral
val doCall2 = osSpecificGeneral
fun convStat(mode, kind, ino, dev, nlink, uid, gid, size,
atime, mtime, ctime) =
{ mode = SysWord.fromInt mode, kind = kind, ino = ino,
dev = dev, nlink = nlink, uid = uid, gid = gid,
size = size, atime = atime, mtime = mtime, ctime = ctime }
in
fun stat name = convStat(doCall1(55, name))
and lstat name = convStat(doCall1(56, name))
and fstat f = convStat(doCall2(57, f))
end
datatype access_mode = datatype OS.FileSys.access_mode
local
val doCall = osSpecificGeneral
val rOK = getConst 156 and wOK = getConst 157
and eOK = getConst 158 and fOK = getConst 159
fun abit A_READ = rOK
| abit A_WRITE = wOK
| abit A_EXEC = eOK
val abits = List.foldl (fn (a, b) => SysWord.orb(abit a,b)) 0w0
in
(* If the bits are nil it tests for existence of the file. *)
fun access(name, []) = doCall(58, (name, SysWord.toInt(fOK)))
| access(name, al) = doCall(58, (name, SysWord.toInt(abits al)))
end
local
val doCall = osSpecificGeneral
in
fun fchmod(fd, mode) = doCall(60, (fd, SysWord.toInt mode))
end
local
val doCall = osSpecificGeneral
in
fun chown(name, uid, gid) = doCall(61, (name, uid, gid))
end
local
val doCall = osSpecificGeneral
in
fun fchown(fd, uid, gid) = doCall(62, (fd, uid, gid))
end
local
val doCall1 = osSpecificGeneral
and doCall2 = osSpecificGeneral
in
fun utime (name, NONE) = doCall1(64, name)
| utime (name, SOME{actime, modtime}) =
doCall2(63, (name, actime, modtime))
end
local
val doCall = osSpecificGeneral
in
fun ftruncate(fd, size) = doCall(65, (fd, size))
end
local
val doCall = osSpecificGeneral
in
fun pathconf(name, var) =
let
val res = doCall(66, (name, var))
in
if res < 0 then NONE
else SOME(SysWord.fromInt res)
end
end
local
val doCall = osSpecificGeneral
in
fun fpathconf(fd, var) =
let
val res = doCall(67, (fd, var))
in
if res < 0 then NONE
else SOME(SysWord.fromInt res)
end
end
end;
structure IO =
struct
type file_desc = OS.IO.iodesc and pid = Process.pid
structure FD =
struct
open BitFlags
val cloexec: flags = getConst 132
val all = flags [cloexec]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
(* Posix.IO.O seems to be a cut-down version of Posix.FileSys.O.
It seems to me that one structure would suffice. *)
structure O = FileSys.O
datatype open_mode = datatype FileSys.open_mode
local
val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral"
in
fun close (strm: file_desc): unit = doIo(7, strm, 0)
end
local
val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral"
in
fun readVec (strm: file_desc, len: int): Word8Vector.vector =
doIo(26, strm, len)
end
local
val doCall = osSpecificGeneral
in
fun pipe() =
let
val (inf, outf) = doCall(110, ())
in
{ infd=inf, outfd=outf }
end
end
local
val doCall = osSpecificGeneral
in
fun dup fd = doCall(111, fd)
end
local
val doCall = osSpecificGeneral
in
fun dup2{old, new} = doCall(112, (old, new))
end
local
val doCall = osSpecificGeneral
in
fun dupfd{old, base} = doCall(113, (old, base))
end
local
val doCall = osSpecificGeneral
val o_rdonly = getConst 63
and o_wronly = getConst 64
and o_accmode = getConst 166 (* Access mode mask. *)
in
fun getfd fd = SysWord.fromInt(doCall(114, fd))
and getfl fd =
let
val res = SysWord.fromInt(doCall(116, fd))
(* Separate out the mode bits. *)
val flgs = SysWord.andb(res, SysWord.notb o_accmode)
val mode = SysWord.andb(res, o_accmode)
val omode = if mode = o_rdonly then O_RDONLY
else if mode = o_wronly then O_WRONLY
else O_RDWR
in
(flgs, omode)
end
end
local
val doCall = osSpecificGeneral
in
fun setfd(fd, flags) = doCall(115, (fd, SysWord.toInt flags))
and setfl(fd, flags) = doCall(117, (fd, SysWord.toInt flags))
end
datatype whence = SEEK_SET | SEEK_CUR | SEEK_END
local
val seekSet = SysWord.toInt(getConst 160)
and seekCur = SysWord.toInt(getConst 161)
and seekEnd = SysWord.toInt(getConst 162)
in
(* Convert the datatype to the corresponding int. *)
fun seekWhence SEEK_SET = seekSet
| seekWhence SEEK_CUR = seekCur
| seekWhence SEEK_END = seekEnd
fun whenceSeek s =
if s = seekSet then SEEK_SET
else if s = seekCur then SEEK_CUR
else SEEK_END
end
local
val doCall = osSpecificGeneral
in
fun lseek(fd, pos, whence) = doCall(118, (fd, pos, seekWhence whence))
end
local
val doCall = osSpecificGeneral
in
fun fsync fd = doCall(119, fd)
end
datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK
structure FLock =
struct
val fRdlck = SysWord.toInt(getConst 163)
and fWrlck = SysWord.toInt(getConst 164)
and fUnlck = SysWord.toInt(getConst 165)
type flock = int (* lock type *) *
int (* whence *) *
Position.int (* start *) *
Position.int (* len *) *
pid
fun flock{ltype, whence, start, len, pid} =
let
val lt =
case ltype of
F_RDLCK => fRdlck
| F_WRLCK => fWrlck
| F_UNLCK => fUnlck
in
(lt, seekWhence whence, start, len, getOpt(pid, ~1))
end
fun ltype (lt, _, _, _, _) =
if lt = fRdlck then F_RDLCK
else if lt = fWrlck then F_WRLCK
else F_UNLCK
fun whence (fl: flock) = whenceSeek(#2 fl)
val start : flock -> Position.int = #3
val len : flock -> Position.int = #4
fun pid (_, _, _, _, pid) = if pid < 0 then NONE else SOME pid
end
local
val doCall = osSpecificGeneral
in
fun getlk(fd, (t, w, s, l, p)) = doCall(120, (fd, t, w, s, l, p))
(* Note: the return type of setlk and setlkw is Flock.lock
not unit. I assume they simply return their argument. *)
and setlk(fd, (t, w, s, l, p)) = doCall(121, (fd, t, w, s, l, p))
and setlkw(fd, (t, w, s, l, p)) = doCall(122, (fd, t, w, s, l, p))
end
val readArr = LibraryIOSupport.readBinArray
and writeVec = LibraryIOSupport.writeBinVec
and writeArr = LibraryIOSupport.writeBinArray
val mkTextReader = LibraryIOSupport.wrapInFileDescr
and mkTextWriter = LibraryIOSupport.wrapOutFileDescr
val mkBinReader = LibraryIOSupport.wrapBinInFileDescr
and mkBinWriter = LibraryIOSupport.wrapBinOutFileDescr
end;
structure SysDB =
struct
type uid = ProcEnv.uid and gid = ProcEnv.gid
structure Passwd =
struct
type passwd = string * uid * gid * string * string
val name: passwd->string = #1
and uid: passwd->uid = #2
and gid: passwd->gid = #3
and home: passwd->string = #4
and shell: passwd->string = #5
end
structure Group =
struct
type group = string * gid * string list
val name: group->string = #1
and gid: group->gid = #2
and members: group->string list = #3
end
local
val doCall = osSpecificGeneral
in
fun getpwnam (s: string): Passwd.passwd = doCall(100, s)
end
local
val doCall = osSpecificGeneral
in
fun getpwuid (u: uid): Passwd.passwd = doCall(101, u)
end
local
val doCall = osSpecificGeneral
in
fun getgrnam (s: string): Group.group = doCall(102, s)
end
local
val doCall = osSpecificGeneral
in
fun getgrgid (g: gid): Group.group = doCall(103, g)
end
end;
structure TTY =
struct
type pid = Process.pid and file_desc = OS.IO.iodesc
structure V =
struct
val eof = SysWord.toInt(getConst 72)
and eol = SysWord.toInt(getConst 73)
and erase = SysWord.toInt(getConst 74)
and intr = SysWord.toInt(getConst 75)
and kill = SysWord.toInt(getConst 76)
and min = SysWord.toInt(getConst 77)
and quit = SysWord.toInt(getConst 78)
and susp = SysWord.toInt(getConst 79)
and time = SysWord.toInt(getConst 80)
and start = SysWord.toInt(getConst 81)
and stop = SysWord.toInt(getConst 82)
and nccs = SysWord.toInt(getConst 83)
type cc = string
fun cc l =
(* Generate a string using the values given and
defaulting the rest to NULL. *)
let
fun find [] _ = #"\000"
| find ((n, c)::l) i =
if i = n then c else find l i
in
CharVector.tabulate(nccs, find l)
end
(* Question: What order does this take? E.g. What is
the result of update(cc, [(eof, #"a"), (eof, #"b")]) ?
Assume that earlier entries take precedence. That
also affects the processing of exceptions. *)
fun update(cc, l) =
let
fun find [] i = String.sub(cc, i)
| find ((n, c)::l) i =
if i = n then c else find l i
in
CharVector.tabulate(nccs, find l)
end
val sub = String.sub
end
structure I =
struct
open BitFlags
val brkint = getConst 84
and icrnl = getConst 85
and ignbrk = getConst 86
and igncr = getConst 87
and ignpar = getConst 88
and inlcr = getConst 89
and inpck = getConst 90
and istrip = getConst 91
and ixoff = getConst 92
and ixon = getConst 93
and parmrk = getConst 94
val all = flags [brkint, icrnl, ignbrk, igncr, ignpar,
inlcr, inpck, istrip, ixoff, ixon, parmrk]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
structure O =
struct
open BitFlags
val opost = getConst 95
val all = flags [opost]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
structure C =
struct
open BitFlags
val clocal = getConst 96
and cread = getConst 97
and cs5 = getConst 98
and cs6 = getConst 99
and cs7 = getConst 100
and cs8 = getConst 101
and csize = getConst 102
and cstopb = getConst 103
and hupcl = getConst 104
and parenb = getConst 105
and parodd = getConst 106
val all = flags [clocal, cread, cs5, cs6, cs7, cs8, csize,
cstopb, hupcl, parenb, parodd]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
structure L =
struct
open BitFlags
val echo = getConst 107
and echoe = getConst 108
and echok = getConst 109
and echonl = getConst 110
and icanon = getConst 111
and iexten = getConst 112
and isig = getConst 113
and noflsh = getConst 114
and tostop = getConst 115
val all = flags [echo, echoe, echok, echonl, icanon,
iexten, isig, noflsh, tostop]
val intersect = List.foldl (fn (a, b) => SysWord.andb(a, b)) all
end
type speed = int
(* compareSpeed is supposed to compare by the baud rate, not
by the encoding. Provided the encoding maintains the
ordering then that's fine. Maybe we should have an RTS call. *)
val compareSpeed : speed * speed -> order = Int.compare
and speedToWord : speed -> SysWord.word = SysWord.fromInt
and wordToSpeed : SysWord.word -> speed = SysWord.toInt
val b0 : speed = SysWord.toInt(getConst 116)
and b50 : speed = SysWord.toInt(getConst 117)
and b75 : speed = SysWord.toInt(getConst 118)
and b110 : speed = SysWord.toInt(getConst 119)
and b134 : speed = SysWord.toInt(getConst 120)
and b150 : speed = SysWord.toInt(getConst 121)
and b200 : speed = SysWord.toInt(getConst 122)
and b300 : speed = SysWord.toInt(getConst 123)
and b600 : speed = SysWord.toInt(getConst 124)
and b1200 : speed = SysWord.toInt(getConst 125)
and b1800 : speed = SysWord.toInt(getConst 126)
and b2400 : speed = SysWord.toInt(getConst 127)
and b4800 : speed = SysWord.toInt(getConst 128)
and b9600 : speed = SysWord.toInt(getConst 129)
and b19200 : speed = SysWord.toInt(getConst 130)
and b38400 : speed = SysWord.toInt(getConst 131)
type termios = {
iflag : I.flags,
oflag : O.flags,
cflag : C.flags,
lflag : L.flags,
cc : V.cc,
ispeed : speed,
ospeed : speed
}
fun termios t = t
and fieldsOf t = t
val getiflag : termios -> I.flags = #iflag
and getoflag : termios -> O.flags = #oflag
and getcflag : termios -> C.flags = #cflag
and getlflag : termios -> L.flags = #lflag
and getcc : termios -> V.cc = #cc
structure CF =
struct
val getospeed : termios -> speed = #ospeed
and getispeed : termios -> speed = #ispeed
fun setospeed ({ iflag, oflag, cflag, lflag, cc, ispeed, ... }, speed) =
{ iflag=iflag, oflag=oflag, cflag=cflag, lflag=lflag,
cc=cc, ispeed = ispeed, ospeed = speed }
fun setispeed ({ iflag, oflag, cflag, lflag, cc, ospeed, ... }, speed) =
{ iflag=iflag, oflag=oflag, cflag=cflag, lflag=lflag,
cc=cc, ispeed = speed, ospeed = ospeed }
end
structure TC =
struct
type set_action = int
val sanow : set_action = SysWord.toInt(getConst 135)
val sadrain : set_action = SysWord.toInt(getConst 136)
val saflush : set_action = SysWord.toInt(getConst 137)
type flow_action = int
val ooff : flow_action = SysWord.toInt(getConst 138)
val oon : flow_action = SysWord.toInt(getConst 139)
val ioff : flow_action = SysWord.toInt(getConst 140)
val ion : flow_action = SysWord.toInt(getConst 141)
type queue_sel = int
val iflush : queue_sel = SysWord.toInt(getConst 142)
val oflush : queue_sel = SysWord.toInt(getConst 143)
val ioflush : queue_sel = SysWord.toInt(getConst 144)
local
val doCall = osSpecificGeneral
in
fun getattr f =
let
val (iflag, oflag, cflag, lflag, cc, ispeed, ospeed)
= doCall(150, f)
in
{
iflag=SysWord.fromInt iflag,
oflag=SysWord.fromInt oflag,
cflag=SysWord.fromInt cflag,
lflag=SysWord.fromInt lflag,
cc=cc,
ispeed = ispeed,
ospeed = ospeed }
end
end
local
val doCall = osSpecificGeneral
in
fun setattr (f, sa,
{iflag, oflag, cflag, lflag, cc, ispeed, ospeed}) =
doCall(151, (f, sa, SysWord.toInt iflag,
SysWord.toInt oflag, SysWord.toInt cflag,
SysWord.toInt lflag, cc, ispeed, ospeed))
end
local
val doCall = osSpecificGeneral
in
fun sendbreak (f, d) = doCall(152, (f, d))
end
local
val doCall = osSpecificGeneral
in
fun drain f = doCall(153, f)
end
local
val doCall = osSpecificGeneral
in
fun flush (f, qs) = doCall(154, (f, qs))
end
local
val doCall = osSpecificGeneral
in
fun flow (f, fa) = doCall(155, (f, fa))
end
end
local
val doCall = osSpecificGeneral
in
fun getpgrp (f: file_desc): pid = doCall(156, f)
end
local
val doCall = osSpecificGeneral
in
fun setpgrp (f: file_desc, p: pid): unit = doCall(157, (f,p))
end
end
end;
local
(* Install the pretty printers for pid, uid, gid. Don't install one for signal
because it's now the same as int. *)
fun ppid _ _ x = PolyML.PrettyString(Int.toString(SysWord.toInt(Posix.Process.pidToWord x)))
and puid _ _ x = PolyML.PrettyString(Int.toString(SysWord.toInt(Posix.ProcEnv.uidToWord x)))
and pgid _ _ x = PolyML.PrettyString(Int.toString(SysWord.toInt(Posix.ProcEnv.gidToWord x)))
in
val () = PolyML.addPrettyPrinter ppid
val () = PolyML.addPrettyPrinter puid
val () = PolyML.addPrettyPrinter pgid
end;
diff --git a/basis/Unix.sml b/basis/Unix.sml
index c584f6b4..f04ae5b8 100644
--- a/basis/Unix.sml
+++ b/basis/Unix.sml
@@ -1,220 +1,218 @@
(*
Title: Standard Basis Library: Unix structure and signature.
Author: David Matthews
- Copyright David Matthews 2000,2008
+ Copyright David Matthews 2000,2008, 2019
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*)
signature UNIX =
sig
type ('a,'b) proc
type signal
datatype exit_status
= W_EXITED
| W_EXITSTATUS of Word8.word
| W_SIGNALED (* sic *) of signal
| W_STOPPED of signal
val fromStatus : OS.Process.status -> exit_status
val executeInEnv : string * string list * string list -> ('a, 'b) proc
val execute : string * string list -> ('a, 'b) proc
val textInstreamOf : (TextIO.instream, 'a) proc -> TextIO.instream
val binInstreamOf : (BinIO.instream, 'a) proc -> BinIO.instream
val textOutstreamOf : ('a, TextIO.outstream) proc -> TextIO.outstream
val binOutstreamOf : ('a, BinIO.outstream) proc -> BinIO.outstream
val streamsOf : (TextIO.instream, TextIO.outstream) proc
-> TextIO.instream * TextIO.outstream
val reap : ('a, 'b) proc -> OS.Process.status
val kill : ('a, 'b) proc * signal -> unit
val exit : Word8.word -> 'a
end;
structure Unix :>
sig
(* We have to copy the signature since we can't establish the
connection between exit_status and Posix.Process.exit_status
with a "where type". *)
type ('a,'b) proc
type signal = Posix.Signal.signal
datatype exit_status = datatype Posix.Process.exit_status
val fromStatus : OS.Process.status -> exit_status
val executeInEnv : string * string list * string list -> ('a, 'b) proc
val execute : string * string list -> ('a, 'b) proc
val textInstreamOf : (TextIO.instream, 'a) proc -> TextIO.instream
val binInstreamOf : (BinIO.instream, 'a) proc -> BinIO.instream
val textOutstreamOf : ('a, TextIO.outstream) proc -> TextIO.outstream
val binOutstreamOf : ('a, BinIO.outstream) proc -> BinIO.outstream
val streamsOf : (TextIO.instream, TextIO.outstream) proc
-> TextIO.instream * TextIO.outstream
val reap : ('a, 'b) proc -> OS.Process.status
val kill : ('a, 'b) proc * signal -> unit
val exit : Word8.word -> 'a
end =
struct
type ('a,'b) proc =
{ pid: Posix.Process.pid,
infd: Posix.IO.file_desc,
outfd: Posix.IO.file_desc,
(* We have to remember the result status. *)
result: OS.Process.status option ref
}
type signal = Posix.Signal.signal
datatype exit_status = datatype Posix.Process.exit_status
val fromStatus = Posix.Process.fromStatus
fun kill({pid, ... }: ('a, 'b) proc, signal) =
Posix.Process.kill(Posix.Process.K_PROC pid, signal)
(* Create a new process running a command and with pipes connecting the
standard input and output.
The command is supposed to be an executable and we should raise an
exception if it is not. Since the exece is only done in the child we
need to test whether we have an executable at the beginning.
The definition does not say whether the first of the user-supplied
arguments includes the command or not. Assume that only the "real"
arguments are provided and pass the last component of the command
name in the exece call. *)
fun executeInEnv (cmd, args, env) =
let
open Posix
(* Test first for presence of the file and then that we
have correct access rights. *)
val s = FileSys.stat cmd (* Raises SysErr if the file doesn't exist. *)
val () =
if not (FileSys.ST.isReg s) orelse not (FileSys.access(cmd, [FileSys.A_EXEC]))
then raise OS.SysErr(OS.errorMsg Error.acces, SOME Error.acces)
else ()
val toChild = IO.pipe()
and fromChild = IO.pipe()
in
case Process.fork() of
NONE => (* In the child *)
((
(* Should really clean up the signals here and
turn off timers. *)
(* Close the unwanted ends of the pipes and
set the required ends up as stdin and stdout. *)
IO.close(#outfd toChild);
IO.close(#infd fromChild);
- IO.dup2{old= #infd toChild,
- new=FileSys.wordToFD 0w0};
- IO.dup2{old= #outfd fromChild,
- new= FileSys.wordToFD 0w1};
+ IO.dup2{old= #infd toChild, new=Posix.FileSys.stdin};
+ IO.dup2{old= #outfd fromChild, new=Posix.FileSys.stdout};
IO.close(#infd toChild);
IO.close(#outfd fromChild);
(* Run the command. *)
Process.exece(cmd, OS.Path.file cmd :: args, env);
(* If we get here the exec must have failed -
terminate this process. We're supposed to
set the error code to 126 in this case. *)
Process.exit 0w126
) handle _ => Process.exit 0w126)
| SOME pid => (* In the parent *)
(
IO.close(#infd toChild);
IO.close(#outfd fromChild);
{pid=pid, infd= #infd fromChild, outfd= #outfd toChild, result = ref NONE}
)
end
fun execute (cmd, args) =
executeInEnv(cmd, args, Posix.ProcEnv.environ())
local (* Internal function to get the preferred buffer size. *)
val doIo = RunCall.rtsCallFull3 "PolyBasicIOGeneral"
in
fun sys_get_buffsize (strm: OS.IO.iodesc): int = doIo(15, strm, 0)
end
fun textInstreamOf {infd, ...} =
let
val n = Posix.FileSys.fdToIOD infd
val textPrimRd =
LibraryIOSupport.wrapInFileDescr
{fd=n, name="TextPipeInput", initBlkMode=true}
val streamIo = TextIO.StreamIO.mkInstream(textPrimRd, "")
in
TextIO.mkInstream streamIo
end
fun textOutstreamOf {outfd, ...} =
let
val n = Posix.FileSys.fdToIOD outfd
val buffSize = sys_get_buffsize n
val textPrimWr =
LibraryIOSupport.wrapOutFileDescr{fd=n, name="TextPipeOutput",
appendMode=false, initBlkMode=true, chunkSize=buffSize}
(* Construct a stream. *)
val streamIo = TextIO.StreamIO.mkOutstream(textPrimWr, IO.LINE_BUF)
in
TextIO.mkOutstream streamIo
end
fun binInstreamOf {infd, ...} =
let
val n = Posix.FileSys.fdToIOD infd
val binPrimRd =
LibraryIOSupport.wrapBinInFileDescr{fd=n, name="BinPipeInput", initBlkMode=true}
val streamIo =
BinIO.StreamIO.mkInstream(binPrimRd, Word8Vector.fromList [])
in
BinIO.mkInstream streamIo
end
fun binOutstreamOf {outfd, ...} =
let
val n = Posix.FileSys.fdToIOD outfd
val buffSize = sys_get_buffsize n
val binPrimWr =
LibraryIOSupport.wrapBinOutFileDescr{fd=n, name="BinPipeOutput",
appendMode=false, chunkSize=buffSize, initBlkMode=true}
(* Construct a stream. *)
val streamIo = BinIO.StreamIO.mkOutstream(binPrimWr, IO.LINE_BUF)
in
BinIO.mkOutstream streamIo
end
fun streamsOf p = (textInstreamOf p, textOutstreamOf p)
(* Internal function - inverse of Posix.Process.fromStatus. *)
local
val doCall = RunCall.rtsCallFull2 "PolyOSSpecificGeneral"
in
fun toStatus W_EXITED: OS.Process.status = doCall(16, (1, 0))
| toStatus(W_EXITSTATUS w) = doCall(16, (1, Word8.toInt w))
| toStatus(W_SIGNALED s) =
doCall(16, (2, SysWord.toInt(Posix.Signal.toWord s)))
| toStatus(W_STOPPED s) =
doCall(16, (3, SysWord.toInt(Posix.Signal.toWord s)))
end
fun reap {result = ref(SOME r), ...} = r
| reap(p as {pid, infd, outfd, result}) =
let
val () = Posix.IO.close infd;
val () = Posix.IO.close outfd;
val (_, status) =
Posix.Process.waitpid(Posix.Process.W_CHILD pid, [])
in
(* If the process is only stopped we need to wait again. *)
case status of
W_STOPPED _ => reap p
| _ => let val s = toStatus status in result := SOME s; s end
end
fun exit w = OS.Process.exit(toStatus (W_EXITSTATUS w))
end;
diff --git a/configure.ac b/configure.ac
index 57f61865..24a2e617 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,643 +1,620 @@
# -*- Autoconf -*-
# Process this file with autoconf to produce a configure script.
AC_INIT([Poly/ML],[5.8],[polyml AT polyml DOT org],[polyml])
AM_INIT_AUTOMAKE
AC_PREREQ(2.69)
# libtoolize recommends this line.
AC_CONFIG_MACRO_DIR([m4])
ac_debug_mode="no"
AC_ARG_ENABLE([debug],
[ --enable-debug Compiles without optimisation for debugging ],
[ac_debug_mode="yes"])
if test "$ac_debug_mode" != "yes"; then
# Default to maximum optimisation. -O2 is not good enough.
# Set CCASFLAGS to empty so that it doesn't get set to CFLAGS.
# The -g option on assembler causes problems on Sparc/Solaris 10.
# test X || Y is equivalent to if !X then Y
test "${CFLAGS+set}" = set || CFLAGS="-O3"
test "${CXXFLAGS+set}" = set || CXXFLAGS="-O3"
test "${CCASFLAGS+set}" = set || CCASFLAGS=""
else
test "${CFLAGS+set}" = set || CFLAGS="-g"
test "${CXXFLAGS+set}" = set || CXXFLAGS="-g"
test "${CCASFLAGS+set}" = set || CCASFLAGS=""
fi
AC_CANONICAL_HOST
-# Set the OS flag. This should not really be required but is still used in
-# a few places for OS-specific quirks that can't be handled by more specific tests.
-# Check also for mingw in which case we want to build native Windows.
-poly_native_windows=no
+
+# If the compiler defines _WIN32 we're building for native Windows otherwise we're
+# building for something else.
+AC_CHECK_DECL([_WIN32], [poly_native_windows=yes], [poly_native_windows=no])
+
# If we are building on cygwin or mingw we need to give the -no-defined flag to
# build a DLL. We also have to use Windows calling conventions rather than
# SysV on 64-bit.
poly_use_windowscc=no
poly_need_macosopt=no
case "${host_os}" in
darwin*)
AC_SUBST([OSFLAG], [-DMACOSX])
poly_need_macosopt=yes
;;
sunos* | solaris*)
AC_SUBST([OSFLAG], [-DSOLARIS])
;;
- *mingw*)
- AC_SUBST([OSFLAG], ["-DUNICODE -D_UNICODE -D_WIN32_WINNT=0x600"])
- AC_CHECK_TOOL(WINDRES, windres)
- poly_native_windows=yes
+ *mingw* | *cygwin*)
poly_no_undefined=yes
poly_use_windowscc=yes
- CFLAGS="$CFLAGS -mthreads"
- CXXFLAGS="$CXXFLAGS -mthreads"
- ;;
- *cygwin*)
- poly_no_undefined=yes
- poly_use_windowscc=yes
- if test "$ac_cv_c_compiler_gnu" = "yes"; then
- if $CC -dumpmachine | grep -q mingw; then
- AC_SUBST([OSFLAG], ["-DUNICODE -D_UNICODE -D_WIN32_WINNT=0x600"])
- poly_native_windows=yes
- CFLAGS="$CFLAGS -mthreads"
- CXXFLAGS="$CXXFLAGS -mthreads"
- fi
- fi
;;
esac
-# Enable/Disable the GUI in Windows. Should this only be present if
-# building on mingw?
-AC_ARG_ENABLE([windows-gui],
- [AS_HELP_STRING([--enable-windows-gui],
- [create a GUI in Windows. If this is disabled use a Windows console. @<:@default=yes@:>@])],
- [case "${enableval}" in
- yes) enablegui=true ;;
- no) enablegui=false ;;
- *) AC_MSG_ERROR([bad value ${enableval} for --enable-windows-gui]) ;;
- esac],
- [enablegui=true])
-AM_CONDITIONAL([WINDOWSGUI], [test x$enablegui = xtrue])
-
# libpolyml can be a DLL but libpolymain can't.
# Enable shared libraries by default. It complicates installation a bit if the
# the library is installed to a non-standard location but simplifies polyc.
LT_INIT([win32-dll])
AM_MAINTAINER_MODE
# Check we're in the right directory
AC_CONFIG_SRCDIR([polyexports.h])
AC_CONFIG_HEADER([config.h])
# Checks for programs.
AC_PROG_CXX
# The following check was supposed to check that there was actually a
# C++ compiler but doesn't work properly if CXX is set by the user.
#AC_CHECK_PROG(check_cpp, $CXX, "yes", "no")
#if test "$check_cpp" != "yes"; then
# AC_MSG_ERROR([No C++ compiler found. Unable to build Poly/ML.])
#fi
AC_PROG_CC
AC_PROG_MAKE_SET
AC_PROG_CPP
AM_PROG_AS
# Activate large file mode if needed
AC_SYS_LARGEFILE
# Checks for libraries.
AC_CHECK_LIB(gcc, main)
AC_CHECK_LIB(gcc_s, main)
AC_CHECK_LIB(stdc++, main)
# These can sometimes be in the standard libraries
AC_SEARCH_LIBS([dlopen], [dl dld])
AC_SEARCH_LIBS([floor], [m])
-# The next two are only used with mingw. We mustn't include ws2_32 in Cygwin64 because
-# the "select" function gets used instead of Cygwin's own.
-if test "x$poly_native_windows" = xyes; then
- AC_CHECK_LIB(ws2_32, main)
- AC_CHECK_LIB(gdi32, main)
-fi
-
## External names on Win64. They have no leading underscores as per
## the X64 ABI published by MS. Earlier versions of GCC (anything
## prior to 4.5.0) were faulty.
LT_SYS_SYMBOL_USCORE
if test x$sys_symbol_underscore = xyes; then
AC_DEFINE(SYMBOLS_REQUIRE_UNDERSCORE, [1], [Defined if external symbols are prefixed by underscores])
fi
-# Solaris needs -lsocket, -lnsl and -lrt
-AC_SEARCH_LIBS([gethostbyname], [nsl])
-AC_SEARCH_LIBS([getsockopt], [socket])
-AC_SEARCH_LIBS([sem_wait], [rt])
-
-# Check for X and Motif headers and libraries
-AC_PATH_X
-
-if test "x${with_x}" = "xyes"; then
-
- AC_DEFINE([WITH_XWINDOWS], [1], [Define if the X-Windows interface should be built])
-
- if test "$x_includes" != "" ; then
- if test "$x_includes" != "NONE" ; then
- CFLAGS="$CFLAGS -I$x_includes"
- CXXFLAGS="$CXXFLAGS -I$x_includes"
- CPPFLAGS="$CPPFLAGS -I$x_includes"
- fi
- fi
- if test "$x_libraries" != "" ; then
- if test "$x_libraries" != "NONE" ; then
- LIBS="-L$x_libraries $LIBS"
- fi
- fi
- AC_CHECK_LIB(X11, XCreateGC)
- AC_CHECK_LIB(Xt, XtMalloc)
- AC_CHECK_LIB(Xext, XextAddDisplay)
-
- if test "$xm_includes" != "" ; then
- if test "$xm_includes" != "NONE" ; then
- CFLAGS="$CFLAGS -I$xm_includes"
- CXXFLAGS="$CXXFLAGS -I$xm_includes"
- CPPFLAGS="$CPPFLAGS -I$xm_includes"
- fi
- fi
- if test "$xm_libraries" != "" ; then
- if test "$xm_libraries" != "NONE" ; then
- LIBS="-L$xm_libraries $LIBS"
- fi
- fi
- AC_CHECK_LIB(Xm, XmGetDestination)
-
-fi
-
-# TODO: May need AC_PATH_XTRA for Solaris
-
# Check for headers
AC_FUNC_ALLOCA
AC_HEADER_DIRENT
AC_HEADER_STDC
AC_HEADER_SYS_WAIT
AC_CHECK_HEADERS([stdio.h time.h fcntl.h float.h limits.h locale.h malloc.h netdb.h netinet/in.h stddef.h])
AC_CHECK_HEADERS([stdlib.h string.h sys/file.h sys/ioctl.h sys/param.h sys/socket.h sys/systeminfo.h])
AC_CHECK_HEADERS([sys/time.h unistd.h values.h dlfcn.h signal.h ucontext.h])
AC_CHECK_HEADERS([assert.h ctype.h direct.h errno.h excpt.h fenv.h fpu_control.h grp.h])
AC_CHECK_HEADERS([ieeefp.h io.h math.h memory.h netinet/tcp.h arpa/inet.h poll.h pwd.h siginfo.h])
AC_CHECK_HEADERS([stdarg.h sys/errno.h sys/filio.h sys/mman.h sys/resource.h])
AC_CHECK_HEADERS([sys/signal.h sys/sockio.h sys/stat.h termios.h sys/termios.h sys/times.h])
AC_CHECK_HEADERS([sys/types.h sys/uio.h sys/un.h sys/utsname.h sys/select.h sys/sysctl.h])
AC_CHECK_HEADERS([sys/elf_SPARC.h sys/elf_386.h sys/elf_amd64.h asm/elf.h])
AC_CHECK_HEADERS([windows.h tchar.h semaphore.h])
AC_CHECK_HEADERS([stdint.h inttypes.h])
# Only check for the X headers if the user said --with-x.
if test "${with_x+set}" = set; then
AC_CHECK_HEADERS([X11/Xlib.h Xm/Xm.h])
fi
PKG_PROG_PKG_CONFIG
# Check for GMP
AC_ARG_WITH([gmp],
[AS_HELP_STRING([--with-gmp],
[use the GMP library for arbitrary precision arithmetic @<:@default=check@:>@])],
[],
[with_gmp=check])
# If we want GMP check that the library and headers are installed.
if test "x$with_gmp" != "xno"; then
AC_CHECK_LIB([gmp], [__gmpn_tdiv_qr],
[AC_DEFINE([HAVE_LIBGMP], [1],
[Define to 1 if you have libgmp])
[LIBS="-lgmp $LIBS"]
AC_CHECK_HEADER([gmp.h],
[AC_DEFINE([HAVE_GMP_H], [1],
[Define to 1 if you have the gmp.h header file])],
[if test "x$with_gmp" != "xcheck"; then
AC_MSG_FAILURE(
[--with-gmp was given, but gmp.h header file is not installed])
fi
])
],
[if test "x$with_gmp" != "xcheck"; then
AC_MSG_FAILURE(
[--with-gmp was given, but gmp library (version 4 or later) is not installed])
fi
])
fi
# libffi
# libffi must be configured even if we are not building with it so that things like "make dist" work.
AC_CONFIG_SUBDIRS([libpolyml/libffi])
# Use the internal version unless --with-system-libffi is given.
AC_ARG_WITH([system-libffi],
[AS_HELP_STRING([--with-system-libffi],
[use the version of libffi installed on your system rather than the version supplied with poly @<:@default=no@:>@])],
[],
[with_system_libffi=no])
# Libffi uses pkg-config.
if test "x$with_system_libffi" = "xyes"; then
PKG_CHECK_MODULES([FFI], [libffi],
[LIBS="$FFI_LIBS $LIBS" CFLAGS="$FFI_CFLAGS $CFLAGS"],
[AC_CHECK_LIB([ffi], [ffi_prep_closure_loc],
[
[LIBS="-lffi $LIBS"]
AC_CHECK_HEADER([ffi.h], [],
[ AC_MSG_FAILURE([--with-system-libffi was given, but ffi.h header file cannot be found]) ])
],
[AC_MSG_FAILURE([--with-system-libffi was given, but the ffi library is not installed])]
)
]
)
else
# Use internal libffi
CFLAGS="$CFLAGS -Ilibffi/include"
CXXFLAGS="$CXXFLAGS -Ilibffi/include"
fi
AM_CONDITIONAL([INTERNAL_LIBFFI], [test "x$with_system_libffi" != "xyes"])
+# Special configuration for Windows or Unix.
+poly_windows_enablegui=false
-# Check for pthreads. Mainly, this allows a single-threaded build on OSes such as Mac OS X
-# that don't have proper multi-threaded profiling.
-AC_ARG_WITH([threads],
- [AS_HELP_STRING([--with-threads],
- [use the pthread library for multi-threading @<:@default=check@:>@])],
- [],
- [with_threads=check])
+if test "x$poly_native_windows" = xyes; then
+ # The next two are only used with mingw. We mustn't include ws2_32 in Cygwin64 because
+ # the "select" function gets used instead of Cygwin's own.
+ AC_CHECK_LIB(ws2_32, main)
+ AC_CHECK_LIB(gdi32, main)
-# If we want pthreads check that the library and headers are installed.
-# On Android pthread_create is in the standard library
-if test "x$with_threads" != "xno"; then
+ CFLAGS="$CFLAGS -mthreads"
+ CXXFLAGS="$CXXFLAGS -mthreads"
+ AC_SUBST([OSFLAG], ["-DUNICODE -D_UNICODE -D_WIN32_WINNT=0x600"])
+ AC_CHECK_TOOL(WINDRES, windres)
+
+ # Enable/Disable the GUI in Windows.
+ AC_ARG_ENABLE([windows-gui],
+ [AS_HELP_STRING([--enable-windows-gui],
+ [create a GUI in Windows. If this is disabled use a Windows console. @<:@default=yes@:>@])],
+ [case "${enableval}" in
+ yes) poly_windows_enablegui=true ;;
+ no) poly_windows_enablegui=false ;;
+ *) AC_MSG_ERROR([bad value ${enableval} for --enable-windows-gui]) ;;
+ esac],
+ [poly_windows_enablegui=true])
+
+else
+ # Unix or similar e.g. Cygwin. We need pthreads.
+ # On Android pthread_create is in the standard library
AC_SEARCH_LIBS([pthread_create], [pthread],
[AC_DEFINE([HAVE_LIBPTHREAD], [1],
[Define to 1 if you have the `pthread' library (-lpthread).])
AC_CHECK_HEADER([pthread.h],
[AC_DEFINE([HAVE_PTHREAD_H], [1],
[Define to 1 if you have the header file.])],
- [if test "x$with_threads" != "xcheck"; then
- AC_MSG_FAILURE(
- [--with-threads was given, but pthread.h header file is not installed])
- fi
+ [
+ AC_MSG_FAILURE([pthread.h header file is not installed])
])
],
- [if test "x$with_threads" != "xcheck"; then
- AC_MSG_FAILURE(
- [--with-threads was given, but pthread library is not installed])
- fi
+ [
+ AC_MSG_FAILURE([pthread library is not installed])
])
-fi
+ # Solaris needs -lsocket, -lnsl and -lrt
+ AC_SEARCH_LIBS([gethostbyname], [nsl])
+ AC_SEARCH_LIBS([getsockopt], [socket])
+ AC_SEARCH_LIBS([sem_wait], [rt])
+
+ # Check for X and Motif headers and libraries
+ AC_PATH_X
+
+ if test "x${with_x}" = "xyes"; then
+
+ AC_DEFINE([WITH_XWINDOWS], [1], [Define if the X-Windows interface should be built])
+
+ if test "$x_includes" != "" ; then
+ if test "$x_includes" != "NONE" ; then
+ CFLAGS="$CFLAGS -I$x_includes"
+ CXXFLAGS="$CXXFLAGS -I$x_includes"
+ CPPFLAGS="$CPPFLAGS -I$x_includes"
+ fi
+ fi
+ if test "$x_libraries" != "" ; then
+ if test "$x_libraries" != "NONE" ; then
+ LIBS="-L$x_libraries $LIBS"
+ fi
+ fi
+ AC_CHECK_LIB(X11, XCreateGC)
+ AC_CHECK_LIB(Xt, XtMalloc)
+ AC_CHECK_LIB(Xext, XextAddDisplay)
+
+ if test "$xm_includes" != "" ; then
+ if test "$xm_includes" != "NONE" ; then
+ CFLAGS="$CFLAGS -I$xm_includes"
+ CXXFLAGS="$CXXFLAGS -I$xm_includes"
+ CPPFLAGS="$CPPFLAGS -I$xm_includes"
+ fi
+ fi
+ if test "$xm_libraries" != "" ; then
+ if test "$xm_libraries" != "NONE" ; then
+ LIBS="-L$xm_libraries $LIBS"
+ fi
+ fi
+ AC_CHECK_LIB(Xm, XmGetDestination)
+
+ fi
+
+ # TODO: May need AC_PATH_XTRA for Solaris
+
+fi
+# End of Windows/Unix configuration.
# Find out which type of object code exporter to use.
# If we have winnt use PECOFF. This really only applies to cygwin here.
# If we have elf.h use ELF.
# If we have mach-o/reloc.h use Mach-O
# Otherwise use the C source code exporter.
AC_CHECK_TYPES([IMAGE_FILE_HEADER],
[AC_DEFINE([HAVE_PECOFF], [], [Define to 1 if you have the PE/COFF types.])]
[polyexport=pecoff],
[AC_CHECK_HEADER([elf.h],
[AC_DEFINE([HAVE_ELF_H], [], [Define to 1 if you have the header file.])]
[polyexport=elf],
[AC_CHECK_HEADER([mach-o/reloc.h],
[AC_DEFINE([HAVE_MACH_O_RELOC_H], [], [Define to 1 if you have the header file.])]
[polyexport=macho],
[AC_CHECK_HEADERS([elf_abi.h machine/reloc.h],
[AC_DEFINE([HAVE_ELF_ABI_H], [], [Define to 1 if you have and header files.])]
[polyexport=elf] )]
)]
)],
[#include ]
)
AM_CONDITIONAL([EXPPECOFF], [test "$polyexport" = pecoff])
AM_CONDITIONAL([EXPELF], [test "$polyexport" = elf])
AM_CONDITIONAL([EXPMACHO], [test "$polyexport" = macho])
# Checks for typedefs, structures, and compiler characteristics.
AC_HEADER_STDBOOL
AC_C_CONST
AC_TYPE_INT16_T
AC_TYPE_UINT16_T
AC_TYPE_INT32_T
AC_TYPE_UINT32_T
AC_TYPE_INT64_T
AC_TYPE_UINT64_T
AC_TYPE_INTPTR_T
AC_TYPE_UINTPTR_T
AC_TYPE_UID_T
AC_TYPE_MODE_T
AC_TYPE_OFF_T
AC_TYPE_PID_T
AC_TYPE_SIZE_T
AC_TYPE_SSIZE_T
AC_HEADER_TIME
AC_STRUCT_TM
# Check for the various sub-second fields of the stat structure.
AC_CHECK_MEMBERS([struct stat.st_atim, struct stat.st_atimespec,
struct stat.st_atimensec, struct stat.st_atime_n, struct stat.st_uatime])
# Mac OS X, at any rate, needs signal.h to be included first.
AC_CHECK_TYPES([ucontext_t], , , [#include "signal.h"
#include "ucontext.h"])
AC_CHECK_TYPES([struct sigcontext, stack_t, sighandler_t, sig_t], , ,[#include "signal.h"])
AC_CHECK_TYPES([socklen_t],,,[#include "sys/types.h"
#include "sys/socket.h"])
AC_CHECK_TYPES([SYSTEM_LOGICAL_PROCESSOR_INFORMATION],,,[#include "windows.h"])
AC_CHECK_TYPES(long long)
AC_CHECK_TYPES(ssize_t)
AC_CHECK_SIZEOF(void*)
AC_CHECK_SIZEOF(long)
AC_CHECK_SIZEOF(int)
AC_CHECK_SIZEOF(long long)
AC_CHECK_SIZEOF(double)
AC_CHECK_SIZEOF(float)
AC_C_BIGENDIAN
# Checks for library functions.
AC_FUNC_ERROR_AT_LINE
AC_FUNC_GETGROUPS
AC_FUNC_GETPGRP
AC_PROG_GCC_TRADITIONAL
AC_FUNC_SELECT_ARGTYPES
AC_FUNC_STAT
AC_FUNC_STRTOD
AC_CHECK_FUNCS([dlopen strtod dtoa getpagesize sigaltstack mmap mkstemp])
## There does not seem to be a declaration for fpsetmask in mingw64.
AC_CHECK_DECLS([fpsetmask], [], [], [[#include ]])
AC_CHECK_FUNCS([sysctl sysctlbyname])
AC_CHECK_FUNCS([localtime_r gmtime_r])
AC_CHECK_FUNCS([ctermid tcdrain])
-# Where are the registers?
+# Where are the registers when we get a signal? Used in time profiling.
#Linux:
AC_CHECK_MEMBERS([mcontext_t.gregs, mcontext_t.regs, mcontext_t.mc_esp],,,[#include "ucontext.h"])
#Mac OS X:
AC_CHECK_MEMBERS([struct mcontext.ss, struct __darwin_mcontext.ss, struct __darwin_mcontext.__ss,
struct __darwin_mcontext32.ss, struct __darwin_mcontext32.__ss,
struct __darwin_mcontext64.ss, struct __darwin_mcontext64.__ss],,,
[#include "signal.h"
#include "ucontext.h"])
# FreeBSD includes a sun_len member in struct sockaddr_un
AC_CHECK_MEMBERS([struct sockaddr_un.sun_len],,,
[#include ])
-# Build 32-bit in 64-bits. For the moment this is independent of the architecture.
-AC_ARG_ENABLE([compact32bit],
- [AS_HELP_STRING([--enable-compact32bit],
- [use 32-bit values rather than native 64-bits.])])
-
-if test "x$enable_compact32bit" = "xyes"; then
- if test X"$ac_cv_sizeof_voidp" != X8; then
- AC_MSG_ERROR([--enable-compact32bit is only available on 64-bit architectures])
- fi
-fi
-
# This option enables the native code generator. More precisely it allows
# the byte code interpreter to be built on X86.
AC_ARG_ENABLE([native-codegeneration],
[AS_HELP_STRING([--disable-native-codegeneration],
[disable the native code generator and use the slow byte code interpreter instead.])],
[case "${enableval}" in
no) with_portable=yes ;;
yes) with_portable=no ;;
*) AC_MSG_ERROR([bad value ${enableval} for --enable-native-codegeneration]) ;;
esac],
[with_portable=check])
# Check which CPU we're building for. Can we use a native pre-built compiler
-# or do we need to fall back to the interpreter?
+# or do we need to fall back to the interpreter? Most of these settings are to tweak
+# the ELF exporter.
case "${host_cpu}" in
i[[3456]]86*)
AC_DEFINE([HOSTARCHITECTURE_X86], [1], [Define if the host is an X86 (32-bit)])
polyarch=i386
;;
x86_64* | amd64*)
if test X"$ac_cv_sizeof_voidp" = X8; then
AC_DEFINE([HOSTARCHITECTURE_X86_64], [1], [Define if the host is an X86 (64-bit)])
- if test "x$enable_compact32bit" = "xyes"; then
- AC_DEFINE([POLYML32IN64], [1], [Define if this should use 32-bit values in 64-bit architectures])
- polyarch=x86_32in64
- else
- polyarch=x86_64
- fi
- else
+ polyarch=x86_64
+ else
AC_DEFINE([HOSTARCHITECTURE_X32], [1], [Define if the host is an X86 (32-bit ABI, 64-bit processor)])
polyarch=interpret
fi
;;
sparc64*)
AC_DEFINE([HOSTARCHITECTURE_SPARC64], [1], [Define if the host is a Sparc (64-bit)])
polyarch=interpret
;;
sparc*)
AC_DEFINE([HOSTARCHITECTURE_SPARC], [1], [Define if the host is a Sparc (32-bit)])
polyarch=interpret
;;
powerpc64* | ppc64*)
AC_DEFINE([HOSTARCHITECTURE_PPC64], [1], [Define if the host is a PowerPC (64-bit)])
polyarch=interpret
;;
power* | ppc*)
AC_DEFINE([HOSTARCHITECTURE_PPC], [1], [Define if the host is a PowerPC (32-bit)])
polyarch=interpret
;;
arm*)
AC_DEFINE([HOSTARCHITECTURE_ARM], [1], [Define if the host is an ARM (32-bit)])
polyarch=interpret
;;
aarch64*)
AC_DEFINE([HOSTARCHITECTURE_AARCH64], [1], [Define if the host is an ARM (64-bit)])
polyarch=interpret
;;
hppa*)
AC_DEFINE([HOSTARCHITECTURE_HPPA], [1], [Define if the host is an HP PA-RISC (32-bit)])
polyarch=interpret
;;
ia64*)
AC_DEFINE([HOSTARCHITECTURE_IA64], [1], [Define if the host is an Itanium])
polyarch=interpret
;;
m68k*)
AC_DEFINE([HOSTARCHITECTURE_M68K], [1], [Define if the host is a Motorola 68000])
polyarch=interpret
;;
mips64*)
AC_DEFINE([HOSTARCHITECTURE_MIPS64], [1], [Define if the host is a MIPS (64-bit)])
polyarch=interpret
;;
mips*)
AC_DEFINE([HOSTARCHITECTURE_MIPS], [1], [Define if the host is a MIPS (32-bit)])
polyarch=interpret
;;
s390x*)
AC_DEFINE([HOSTARCHITECTURE_S390X], [1], [Define if the host is an S/390 (64-bit)])
polyarch=interpret
;;
s390*)
AC_DEFINE([HOSTARCHITECTURE_S390], [1], [Define if the host is an S/390 (32-bit)])
polyarch=interpret
;;
sh*)
AC_DEFINE([HOSTARCHITECTURE_SH], [1], [Define if the host is a SuperH (32-bit)])
polyarch=interpret
;;
alpha*)
AC_DEFINE([HOSTARCHITECTURE_ALPHA], [1], [Define if the host is an Alpha (64-bit)])
polyarch=interpret
# GCC defaults to non-conforming floating-point, and does not respect the rounding mode
# in the floating-point control register, so we force it to conform to IEEE and use the
# dynamic suffix on the floating-point instructions it produces.
CFLAGS="$CFLAGS -mieee -mfp-rounding-mode=d"
CXXFLAGS="$CXXFLAGS -mieee -mfp-rounding-mode=d"
;;
riscv32)
AC_DEFINE([HOSTARCHITECTURE_RISCV32], [1], [Define if the host is a RISC-V (32-bit)])
polyarch=interpret
;;
riscv64)
AC_DEFINE([HOSTARCHITECTURE_RISCV64], [1], [Define if the host is a RISC-V (64-bit)])
polyarch=interpret
;;
*) AC_MSG_ERROR([Poly/ML is not supported for this architecture]) ;;
esac
# If we explicitly asked to use the interpreter set the architecture to interpreted.
if test "x$with_portable" = "xyes" ; then
if test "x$polyarch" != "xinterpret" ; then
AC_MSG_WARN(
[*******You have disabled native code generation. Are you really sure you want to do that?*******])
fi
polyarch=interpret
fi
# If we asked not to use the interpreter check we have native code support.
if test "x$with_portable" = "xno" ; then
if test "x$polyarch" = "xinterpret" ; then
AC_MSG_ERROR(
[--enable-native-codegeneration was given but native code is not supported on this platform])
fi
fi
if test "x$polyarch" != "xinterpret" ; then
# Check for .note.GNU-stack support, used for marking the stack as non-executable.
# Only do this check if we're using the native X86 versions. We don't need this if
# we're using the interpreter and the assembler on other architectures may choke.
AC_MSG_CHECKING([whether as supports .note.GNU-stack])
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[__asm__(".section .note.GNU-stack,\"\",@progbits");]])],
[AC_MSG_RESULT([yes])] [AC_DEFINE([HAVE_GNU_STACK], [1],
[Define to 1 if you have .note.GNU-stack support in the assembler.])],
[AC_MSG_RESULT([no])])
fi
+# Build 32-bit in 64-bits. This is only allowed when building on native 64-bit X86.
+AC_ARG_ENABLE([compact32bit],
+ [AS_HELP_STRING([--enable-compact32bit],
+ [use 32-bit values rather than native 64-bits.])])
+
+if test "x$enable_compact32bit" = "xyes"; then
+ if test X"$polyarch" = "Xx86_64" ; then
+ AC_DEFINE([POLYML32IN64], [1], [Define if this should use 32-bit values in 64-bit architectures])
+ polyarch=x86_32in64
+ else
+ AC_MSG_ERROR([--enable-compact32bit is only available on X86/64])
+ fi
+fi
+
# Put this test at the end where it's less likely to be missed.
# If we're compiling on Cygwin (and mingw?) and /usr/bin/file is not present
# the link step will produce some strange warning messages of the form:
# "Warning: linker path does not have real file for library -lXXX". I think
# that's really a bug in autoconf but to explain what's happening to the user
# add a test here.
if test "$lt_cv_file_magic_cmd" = "func_win32_libid";
then
if test \! -x /usr/bin/file;
then
echo ""
echo "*** Warning: You are building Poly/ML on Cygwin/Mingw but '/usr/bin/file' cannot be found."
echo "*** You can still go ahead and build Poly/ML but libpolyml will not be built as a"
echo "*** shared library and you may get strange warning messages from the linker step."
echo "*** Install the 'file' package to correct this problem."
echo ""
fi
fi
AM_CONDITIONAL([ARCHI386], [test "$polyarch" = i386])
AM_CONDITIONAL([ARCHX86_64], [test "$polyarch" = x86_64])
AM_CONDITIONAL([ARCHINTERPRET], [test "$polyarch" = interpret -a X"$ac_cv_sizeof_voidp" = X4])
AM_CONDITIONAL([ARCHINTERPRET64], [test "$polyarch" = interpret -a X"$ac_cv_sizeof_voidp" = X8])
AM_CONDITIONAL([ARCHX8632IN64], [test "$polyarch" = x86_32in64])
# If we are targeting Windows rather than *nix we need the pre=built compiler with Windows conventions.
AM_CONDITIONAL([WINDOWSCALLCONV], [test "$poly_use_windowscc" = yes])
# This is true if we are building for native Windows rather than Cygwin
AM_CONDITIONAL([NATIVE_WINDOWS], [test "$poly_native_windows" = yes])
AM_CONDITIONAL([NO_UNDEFINED], [test "$poly_no_undefined" = yes])
+AM_CONDITIONAL([WINDOWSGUI], [test x$poly_windows_enablegui = xtrue])
AM_CONDITIONAL([MACOSLDOPTS], [test "$poly_need_macosopt" = yes ])
# If we're building only the static version of libpolyml
# then polyc and polyml.pc have to include the dependent libraries.
dependentlibs=""
if test "${enable_shared}" != yes; then
dependentlibs=${LIBS}
fi
AC_SUBST([dependentlibs], ["$dependentlibs"])
# Test whether this is a git directory and set the version if possible
AC_CHECK_PROG([gitinstalled], [git], [yes], [no])
if test X"$gitinstalled" = "Xyes" -a -d ".git"; then
GIT_VERSION='-DGIT_VERSION=\"$(shell git describe --tags --always)\"'
AC_SUBST(GIT_VERSION)
fi
# Strip -fdebug-prefix-map= from CFLAGS; it's meaningless for users of polyc,
# and hurts reproducibility.
polyc_CFLAGS=
for cflag in $CFLAGS; do
cflag="${cflag##-fdebug-prefix-map=*}"
if test -n "$cflag"; then
if test -n "$polyc_CFLAGS"; then
polyc_CFLAGS="$polyc_CFLAGS $cflag"
else
polyc_CFLAGS="$cflag"
fi
fi
done
AC_SUBST([polyc_CFLAGS], ["$polyc_CFLAGS"])
# Modules directory
AC_ARG_WITH([moduledir],
[AS_HELP_STRING([--with-moduledir=DIR], [directory for Poly/ML modules])],
[moduledir=$withval],
[moduledir="\${libdir}/polyml/modules"])
AC_SUBST([moduledir], [$moduledir])
# Control whether to build the basis library with arbitrary precision as the default int
AC_ARG_ENABLE([intinf-as-int],
[AS_HELP_STRING([--enable-intinf-as-int], [set arbitrary precision as the default int type])],
[case "${enableval}" in
no) intisintinf=no ;;
yes) intisintinf=yes ;;
*) AC_MSG_ERROR([bad value ${enableval} for --enable-intinf-as-int]) ;;
esac],
[intisintinf=no])
AM_CONDITIONAL([INTINFISINT], [test "$intisintinf" = "yes"])
# These are needed for building in a separate build directory, as they are
# referenced from exportPoly.sml.
AC_CONFIG_COMMANDS([basis], [test -e basis || ln -sf ${ac_top_srcdir}/basis .])
AC_CONFIG_COMMANDS([mlsource], [test -e mlsource || ln -sf ${ac_top_srcdir}/mlsource .])
AC_CONFIG_FILES([Makefile libpolyml/Makefile libpolyml/polyml.pc libpolymain/Makefile modules/Makefile modules/IntInfAsInt/Makefile])
AC_CONFIG_FILES([polyc], [chmod +x polyc])
AC_OUTPUT
diff --git a/libpolymain/PolyMainLib.vcxproj b/libpolymain/PolyMainLib.vcxproj
index 75b6fb01..9a2e886c 100644
--- a/libpolymain/PolyMainLib.vcxproj
+++ b/libpolymain/PolyMainLib.vcxproj
@@ -1,463 +1,464 @@
Debug32in64Win32Debug32in64x64DebugWin32Int32in64DebugWin32Int32in64Debugx64Int32In64ReleaseWin32Int32In64Releasex64IntDebugWin32IntDebugx64IntReleaseWin32IntReleasex64Release32in64Win32Release32in64x64ReleaseWin32Debugx64Releasex64{0326C47A-00AF-42CB-B87D-0369A241B570}PolyMainLib
+ 10.0StaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3Disabledtrue..;%(AdditionalIncludeDirectories)MultiThreadedDebugtrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrueLevel3MaxSpeedtruetruetrue..;%(AdditionalIncludeDirectories)MultiThreadedtruetruetrue
\ No newline at end of file
diff --git a/libpolymain/polystub.c b/libpolymain/polystub.c
index a460a876..9920c729 100644
--- a/libpolymain/polystub.c
+++ b/libpolymain/polystub.c
@@ -1,46 +1,46 @@
/*
Title: polystub.c
- Copyright (c) 2006, 2015 David C.J. Matthews
+ Copyright (c) 2006, 2015, 2019 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
// This is the start-up function for Poly/ML. It simply picks up the
// pointer to the exported data and calls the main program.
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#include "../polyexports.h"
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow)
{
return PolyWinMain(hInstance, hPrevInstance, lpCmdLine, nCmdShow, &poly_exports);
}
#else
int main(int argc, char *argv[])
{
return polymain(argc, argv, &poly_exports);
}
#endif
diff --git a/libpolyml/PolyLib.vcxproj b/libpolyml/PolyLib.vcxproj
index 0de86e4d..541c7a8f 100644
--- a/libpolyml/PolyLib.vcxproj
+++ b/libpolyml/PolyLib.vcxproj
@@ -1,891 +1,891 @@
Debug32in64Win32Debug32in64x64DebugWin32Int32in64DebugWin32Int32in64Debugx64Int32In64ReleaseWin32Int32In64Releasex64IntDebugWin32IntDebugx64IntReleaseWin32IntReleasex64Release32in64Win32Release32in64x64ReleaseWin32Debugx64Releasex64{0BA5D5B5-F85B-4C49-8A27-67186FA68922}PolyLib
- 10.0.15063.0
+ 10.0DynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibraryfalse
- v141
+ v142trueUnicodeDynamicLibraryfalse
- v141
+ v142trueUnicodeDynamicLibraryfalse
- v141
+ v142trueUnicodeDynamicLibraryfalse
- v141
+ v142trueUnicodeDynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibrarytrue
- v141
+ v142UnicodeDynamicLibraryfalse
- v141
+ v142trueUnicodeDynamicLibraryfalse
- v141
+ v142trueUnicodeDynamicLibraryfalse
- v141
+ v142trueUnicodeDynamicLibraryfalse
- v141
+ v142trueUnicode.dll.dll.dll.dll.dll.dll.dll.dll.dll.dll.dll.dll.dll.dll.dll.dllLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3Disabledtrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedDebugtruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falseLevel3MaxSpeedtruetruetrue..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories)POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions)MultiThreadedtruetruetruews2_32.lib;%(AdditionalDependencies)Windows6.0falsetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruefalsefalsetruetruefalsefalsetruetruefalsefalsetruetruefalsefalsetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruetruefalsefalsetruetruefalsefalsetruetruetruetruetruetrueDocumentcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /DWINDOWS /Fo $(IntDir)%(Filename).obj /c /coff "$(IntDir)%(Filename).asm"$(IntDir)%(Filename).obj$(IntDir)%(Filename).objtruetruetruetruetruetruetruetruetruetruetruetrueDocumentcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER /DPOLYML32IN64 "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER /DPOLYML32IN64 "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).objcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asmcl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj$(IntDir)%(Filename).obj{6d86bc6f-e74e-40c5-9881-f8bb606bca78}
\ No newline at end of file
diff --git a/libpolyml/basicio.cpp b/libpolyml/basicio.cpp
index c5bca275..93be528a 100644
--- a/libpolyml/basicio.cpp
+++ b/libpolyml/basicio.cpp
@@ -1,1099 +1,1124 @@
/*
Title: Basic IO.
Copyright (c) 2000, 2015-2019 David C. J. Matthews
Portions of this code are derived from the original stream io
package copyright CUTS 1983-2000.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
/*
This module replaces the old stream IO based on stdio. It works at a
lower level with the buffering being done in ML.
Sockets are generally dealt with in network.c but it is convenient to
use the same table for them particularly since it simplifies the
implementation of "poll".
Directory operations are also included in here.
DCJM May 2000.
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_FCNTL_H
#include
#endif
#ifdef HAVE_SYS_TYPES_H
#include
#endif
#ifdef HAVE_SYS_STAT_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_SIGNAL_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_ALLOCA_H
#include
#endif
#ifdef HAVE_IO_H
#include
#endif
#ifdef HAVE_SYS_PARAM_H
#include
#endif
#ifdef HAVE_SYS_IOCTL_H
#include
#endif
#ifdef HAVE_SYS_TIME_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_POLL_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_SYS_SELECT_H
#include
#endif
#ifdef HAVE_MALLOC_H
#include
#endif
#ifdef HAVE_DIRECT_H
#include
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#include
#ifndef INFTIM
#define INFTIM (-1)
#endif
#ifdef HAVE_DIRENT_H
# include
# define NAMLEN(dirent) strlen((dirent)->d_name)
#else
# define dirent direct
# define NAMLEN(dirent) (dirent)->d_namlen
# if HAVE_SYS_NDIR_H
# include
# endif
# if HAVE_SYS_DIR_H
# include
# endif
# if HAVE_NDIR_H
# include
# endif
#endif
#include "globals.h"
#include "basicio.h"
#include "sys.h"
#include "gc.h"
#include "run_time.h"
#include "machine_dep.h"
#include "arb.h"
#include "processes.h"
#include "diagnostics.h"
#include "io_internal.h"
#include "scanaddrs.h"
#include "polystring.h"
#include "mpoly.h"
#include "save_vec.h"
#include "rts_module.h"
#include "locking.h"
#include "rtsentry.h"
#include "timing.h"
#define TOOMANYFILES EMFILE
#define NOMEMORY ENOMEM
#define STREAMCLOSED EBADF
#define FILEDOESNOTEXIST ENOENT
#define ERRORNUMBER errno
#ifndef O_ACCMODE
#define O_ACCMODE (O_RDONLY|O_RDWR|O_WRONLY)
#endif
#define SAVE(x) taskData->saveVec.push(x)
#ifdef _MSC_VER
// Don't tell me about ISO C++ changes.
#pragma warning(disable:4996)
#endif
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVec, PolyWord bitVec, PolyWord maxMillisecs);
+ POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(FirstArgument threadId, PolyWord fd);
}
static bool isAvailable(TaskData *taskData, int ioDesc)
{
#ifdef __CYGWIN__
static struct timeval poll = {0,1};
#else
static struct timeval poll = {0,0};
#endif
fd_set read_fds;
int selRes;
FD_ZERO(&read_fds);
FD_SET(ioDesc, &read_fds);
/* If there is something there we can return. */
selRes = select(FD_SETSIZE, &read_fds, NULL, NULL, &poll);
if (selRes > 0) return true; /* Something waiting. */
else if (selRes < 0 && errno != EINTR) // Maybe another thread closed descr
raise_syscall(taskData, "select error", ERRORNUMBER);
else return false;
}
// The strm argument is a volatile word containing the descriptor.
// Volatiles are set to zero on entry to indicate a closed descriptor.
// Zero is a valid descriptor but -1 is not so we add 1 when storing and
// subtract 1 when loading.
+// N.B. There are also persistent descriptors created with PolyPosixCreatePersistentFD
Handle wrapFileDescriptor(TaskData *taskData, int fd)
{
return MakeVolatileWord(taskData, fd+1);
}
// Return a file descriptor or -1 if it is invalid.
int getStreamFileDescriptorWithoutCheck(PolyWord strm)
{
- return *(int*)(strm.AsObjPtr()) -1;
+ return *(intptr_t*)(strm.AsObjPtr()) -1;
}
// Most of the time we want to raise an exception if the file descriptor
// has been closed although this could be left to the system call.
int getStreamFileDescriptor(TaskData *taskData, PolyWord strm)
{
int descr = getStreamFileDescriptorWithoutCheck(strm);
if (descr == -1) raise_syscall(taskData, "Stream is closed", STREAMCLOSED);
return descr;
}
/* Open a file in the required mode. */
static Handle open_file(TaskData *taskData, Handle filename, int mode, int access, int isPosix)
{
while (true) // Repeat only with certain kinds of errors
{
TempString cFileName(filename->Word()); // Get file name
if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
int stream = open(cFileName, mode, access);
if (stream >= 0)
{
if (! isPosix)
{
/* Set the close-on-exec flag. We don't set this if we are being
called from one of the low level functions in the Posix structure.
I assume that if someone is using those functions they know what
they're doing and would expect the behaviour to be close to that
of the underlying function. */
fcntl(stream, F_SETFD, 1);
}
return wrapFileDescriptor(taskData, stream);
}
switch (errno)
{
case EINTR: // Just try the call. Is it possible to block here indefinitely?
continue;
default:
raise_syscall(taskData, "Cannot open", ERRORNUMBER);
/*NOTREACHED*/
return 0;
}
}
}
/* Close the stream unless it is stdin or stdout or already closed. */
static Handle close_file(TaskData *taskData, Handle stream)
{
int descr = getStreamFileDescriptorWithoutCheck(stream->Word());
// Don't close it if it's already closed or any of the standard streams
if (descr > 2)
{
close(descr);
- *(int*)(stream->WordP()) = 0; // Mark as closed
+ *(intptr_t*)(stream->WordP()) = 0; // Mark as closed
}
return Make_fixed_precision(taskData, 0);
}
static void waitForAvailableInput(TaskData *taskData, Handle stream)
{
int fd = getStreamFileDescriptor(taskData, stream->Word());
while (!isAvailable(taskData, fd))
{
WaitInputFD waiter(fd);
processes->ThreadPauseForIO(taskData, &waiter);
}
}
/* Read into an array. */
// We can't combine readArray and readString because we mustn't compute the
// destination of the data in readArray until after any GC.
static Handle readArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/)
{
/* The isText argument is ignored in both Unix and Windows but
is provided for future use. Windows remembers the mode used
when the file was opened to determine whether to translate
CRLF into LF. */
// We should check for interrupts even if we're not going to block.
processes->TestAnyEvents(taskData);
while (1) // Loop if interrupted.
{
// First test to see if we have input available.
// These tests may result in a GC if another thread is running.
// First test to see if we have input available.
// These tests may result in a GC if another thread is running.
waitForAvailableInput(taskData, stream);
// We can now try to read without blocking.
// Actually there's a race here in the unlikely situation that there
// are multiple threads sharing the same low-level reader. They could
// both detect that input is available but only one may succeed in
// reading without blocking. This doesn't apply where the threads use
// the higher-level IO interfaces in ML which have their own mutexes.
int fd = getStreamFileDescriptor(taskData, stream->Word());
byte *base = DEREFHANDLE(args)->Get(0).AsObjPtr()->AsBytePtr();
POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1));
size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
ssize_t haveRead = read(fd, base + offset, length);
if (haveRead >= 0)
return Make_fixed_precision(taskData, haveRead); // Success.
// If it failed because it was interrupted keep trying otherwise it's an error.
if (errno != EINTR)
raise_syscall(taskData, "Error while reading", ERRORNUMBER);
}
}
/* Return input as a string. We don't actually need both readArray and
readString but it's useful to have both to reduce unnecessary garbage.
The IO library will construct one from the other but the higher levels
choose the appropriate function depending on need. */
static Handle readString(TaskData *taskData, Handle stream, Handle args, bool/*isText*/)
{
size_t length = getPolyUnsigned(taskData, DEREFWORD(args));
// We should check for interrupts even if we're not going to block.
processes->TestAnyEvents(taskData);
while (1) // Loop if interrupted.
{
// First test to see if we have input available.
// These tests may result in a GC if another thread is running.
waitForAvailableInput(taskData, stream);
// We can now try to read without blocking.
int fd = getStreamFileDescriptor(taskData, stream->Word());
// We previously allocated the buffer on the stack but that caused
// problems with multi-threading at least on Mac OS X because of
// stack exhaustion. We limit the space to 100k. */
if (length > 102400) length = 102400;
byte *buff = (byte*)malloc(length);
if (buff == 0) raise_syscall(taskData, "Unable to allocate buffer", NOMEMORY);
ssize_t haveRead = read(fd, buff, length);
if (haveRead >= 0)
{
Handle result = SAVE(C_string_to_Poly(taskData, (char*)buff, haveRead));
free(buff);
return result;
}
free(buff);
// If it failed because it was interrupted keep trying otherwise it's an error.
if (errno != EINTR)
raise_syscall(taskData, "Error while reading", ERRORNUMBER);
}
}
static Handle writeArray(TaskData *taskData, Handle stream, Handle args, bool/*isText*/)
{
/* The isText argument is ignored in both Unix and Windows but
is provided for future use. Windows remembers the mode used
when the file was opened to determine whether to translate
LF into CRLF. */
PolyWord base = DEREFWORDHANDLE(args)->Get(0);
POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(1));
size_t length = getPolyUnsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
int fd = getStreamFileDescriptor(taskData, stream->Word());
/* We don't actually handle cases of blocking on output. */
byte *toWrite = base.AsObjPtr()->AsBytePtr();
ssize_t haveWritten = write(fd, toWrite+offset, length);
if (haveWritten < 0) raise_syscall(taskData, "Error while writing", ERRORNUMBER);
return Make_fixed_precision(taskData, haveWritten);
}
// Test whether we can write without blocking. Returns false if it will block,
// true if it will not.
static bool canOutput(TaskData *taskData, Handle stream)
{
int fd = getStreamFileDescriptor(taskData, stream->Word());
/* Unix - use "select" to find out if output is possible. */
#ifdef __CYGWIN__
static struct timeval poll = {0,1};
#else
static struct timeval poll = {0,0};
#endif
fd_set read_fds, write_fds, except_fds;
int sel;
FD_ZERO(&read_fds);
FD_ZERO(&write_fds);
FD_ZERO(&except_fds);
FD_SET(fd, &write_fds);
sel = select(FD_SETSIZE,&read_fds,&write_fds,&except_fds,&poll);
if (sel < 0 && errno != EINTR)
raise_syscall(taskData, "select failed", ERRORNUMBER);
return sel > 0;
}
static long seekStream(TaskData *taskData, int fd, long pos, int origin)
{
long lpos = lseek(fd, pos, origin);
if (lpos < 0) raise_syscall(taskData, "Position error", ERRORNUMBER);
return lpos;
}
/* Return the number of bytes available on the device. Works only for
files since it is meaningless for other devices. */
static Handle bytesAvailable(TaskData *taskData, Handle stream)
{
int fd = getStreamFileDescriptor(taskData, stream->Word());
/* Remember our original position, seek to the end, then seek back. */
long original = seekStream(taskData, fd, 0L, SEEK_CUR);
long endOfStream = seekStream(taskData, fd, 0L, SEEK_END);
if (seekStream(taskData, fd, original, SEEK_SET) != original)
raise_syscall(taskData, "Position error", ERRORNUMBER);
return Make_fixed_precision(taskData, endOfStream-original);
}
static Handle fileKind(TaskData *taskData, Handle stream)
{
int fd = getStreamFileDescriptor(taskData, stream->Word());
struct stat statBuff;
if (fstat(fd, &statBuff) < 0) raise_syscall(taskData, "Stat failed", ERRORNUMBER);
switch (statBuff.st_mode & S_IFMT)
{
case S_IFIFO:
return Make_fixed_precision(taskData, FILEKIND_PIPE);
case S_IFCHR:
case S_IFBLK:
if (isatty(fd))
return Make_fixed_precision(taskData, FILEKIND_TTY);
else return Make_fixed_precision(taskData, FILEKIND_DEV);
case S_IFDIR:
return Make_fixed_precision(taskData, FILEKIND_DIR);
case S_IFREG:
return Make_fixed_precision(taskData, FILEKIND_FILE);
case S_IFLNK:
return Make_fixed_precision(taskData, FILEKIND_LINK);
case S_IFSOCK:
return Make_fixed_precision(taskData, FILEKIND_SKT);
default:
return Make_fixed_precision(taskData, -1);
}
}
/* Find out what polling options, if any, are allowed on this
file descriptor. We assume that polling is allowed on all
descriptors, either for reading or writing depending on how
the stream was opened. */
Handle pollTest(TaskData *taskData, Handle stream)
{
// How do we test this? Assume all of them.
return Make_fixed_precision(taskData, POLL_BIT_IN|POLL_BIT_OUT|POLL_BIT_PRI);
}
// Do the polling. Takes a vector of io descriptors, a vector of bits to test
// and a time to wait and returns a vector of results.
class WaitPoll: public Waiter{
public:
WaitPoll(POLYUNSIGNED nDesc, struct pollfd *fds, unsigned maxMillisecs);
virtual void Wait(unsigned maxMillisecs);
int PollResult(void) { return pollResult; }
int PollError(void) { return errorResult; }
private:
int pollResult;
int errorResult;
unsigned maxTime;
struct pollfd *fdVec;
POLYUNSIGNED nDescr;
};
WaitPoll::WaitPoll(POLYUNSIGNED nDesc, struct pollfd *fds, unsigned maxMillisecs)
{
maxTime = maxMillisecs;
pollResult = 0;
errorResult = 0;
nDescr = nDesc;
fdVec = fds;
}
void WaitPoll::Wait(unsigned maxMillisecs)
{
if (nDescr == 0) pollResult = 0;
else
{
if (maxTime < maxMillisecs) maxMillisecs = maxTime;
pollResult = poll(fdVec, nDescr, maxMillisecs);
if (pollResult < 0) errorResult = ERRORNUMBER;
}
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyPollIODescriptors(FirstArgument threadId, PolyWord streamVector, PolyWord bitVector, PolyWord maxMillisecs)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned();
Handle result = 0;
try {
PolyObject *strmVec = streamVector.AsObjPtr();
PolyObject *bitVec = bitVector.AsObjPtr();
POLYUNSIGNED nDesc = strmVec->Length();
ASSERT(nDesc == bitVec->Length());
struct pollfd * fds = 0;
if (nDesc > 0)
fds = (struct pollfd *)alloca(nDesc * sizeof(struct pollfd));
/* Set up the request vector. */
for (unsigned i = 0; i < nDesc; i++)
{
fds[i].fd = getStreamFileDescriptor(taskData, strmVec->Get(i));
POLYUNSIGNED bits = UNTAGGED(bitVec->Get(i));
fds[i].events = 0;
if (bits & POLL_BIT_IN) fds[i].events |= POLLIN; /* | POLLRDNORM??*/
if (bits & POLL_BIT_OUT) fds[i].events |= POLLOUT;
if (bits & POLL_BIT_PRI) fds[i].events |= POLLPRI;
fds[i].revents = 0;
}
// Poll the descriptors.
WaitPoll pollWait(nDesc, fds, maxMilliseconds);
processes->ThreadPauseForIO(taskData, &pollWait);
if (pollWait.PollResult() < 0)
raise_syscall(taskData, "poll failed", pollWait.PollError());
// Construct the result vectors.
result = alloc_and_save(taskData, nDesc);
for (unsigned i = 0; i < nDesc; i++)
{
int res = 0;
if (fds[i].revents & POLLIN) res = POLL_BIT_IN;
if (fds[i].revents & POLLOUT) res = POLL_BIT_OUT;
if (fds[i].revents & POLLPRI) res = POLL_BIT_PRI;
DEREFWORDHANDLE(result)->Set(i, TAGGED(res));
}
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestAnyEvents may test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Directory functions.
static Handle openDirectory(TaskData *taskData, Handle dirname)
{
TempString dirName(dirname->Word());
if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
while (1)
{
DIR *dirp = opendir(dirName);
if (dirp != NULL)
return MakeVolatileWord(taskData, dirp);
switch (errno)
{
case EINTR:
continue; // Just retry the call.
default:
raise_syscall(taskData, "opendir failed", ERRORNUMBER);
}
}
}
/* Return the next entry from the directory, ignoring current and
parent arcs ("." and ".." in Windows and Unix) */
Handle readDirectory(TaskData *taskData, Handle stream)
{
DIR *pDir = *(DIR**)(stream->WordP()); // In a Volatile
if (pDir == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED);
while (1)
{
struct dirent *dp = readdir(pDir);
int len;
if (dp == NULL) return taskData->saveVec.push(EmptyString(taskData));
len = NAMLEN(dp);
if (!((len == 1 && strncmp(dp->d_name, ".", 1) == 0) ||
(len == 2 && strncmp(dp->d_name, "..", 2) == 0)))
return SAVE(C_string_to_Poly(taskData, dp->d_name, len));
}
}
Handle rewindDirectory(TaskData *taskData, Handle stream, Handle dirname)
{
DIR *pDir = *(DIR**)(stream->WordP()); // In a Volatile
if (pDir == 0) raise_syscall(taskData, "Stream is closed", STREAMCLOSED);
rewinddir(pDir);
return Make_fixed_precision(taskData, 0);
}
static Handle closeDirectory(TaskData *taskData, Handle stream)
{
DIR *pDir = *(DIR**)(stream->WordP()); // In a SysWord
if (pDir != 0)
{
closedir(pDir);
*((DIR**)stream->WordP()) = 0; // Clear this - no longer valid
}
return Make_fixed_precision(taskData, 0);
}
/* change_dirc - this is called directly and not via the dispatch
function. */
static Handle change_dirc(TaskData *taskData, Handle name)
/* Change working directory. */
{
TempString cDirName(name->Word());
if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
if (chdir(cDirName) != 0)
raise_syscall(taskData, "chdir failed", ERRORNUMBER);
return SAVE(TAGGED(0));
}
// External call
POLYUNSIGNED PolyChDir(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
try {
(void)change_dirc(taskData, pushedArg);
} catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned(); // Result is unit
}
/* Test for a directory. */
Handle isDir(TaskData *taskData, Handle name)
{
TempString cDirName(name->Word());
if (cDirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
struct stat fbuff;
if (stat(cDirName, &fbuff) != 0)
raise_syscall(taskData, "stat failed", ERRORNUMBER);
if ((fbuff.st_mode & S_IFMT) == S_IFDIR)
return Make_fixed_precision(taskData, 1);
else return Make_fixed_precision(taskData, 0);
}
/* Get absolute canonical path name. */
Handle fullPath(TaskData *taskData, Handle filename)
{
TempString cFileName;
/* Special case of an empty string. */
if (PolyStringLength(filename->Word()) == 0) cFileName = strdup(".");
else cFileName = Poly_string_to_C_alloc(filename->Word());
if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
TempCString resBuf(realpath(cFileName, NULL));
if (resBuf == NULL)
raise_syscall(taskData, "realpath failed", ERRORNUMBER);
/* Some versions of Unix don't check the final component
of a file. To be consistent try doing a "stat" of
the resulting string to check it exists. */
struct stat fbuff;
if (stat(resBuf, &fbuff) != 0)
raise_syscall(taskData, "stat failed", ERRORNUMBER);
return(SAVE(C_string_to_Poly(taskData, resBuf)));
}
/* Get file modification time. This returns the value in the
time units and from the base date used by timing.c. c.f. filedatec */
Handle modTime(TaskData *taskData, Handle filename)
{
TempString cFileName(filename->Word());
if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
struct stat fbuff;
if (stat(cFileName, &fbuff) != 0)
raise_syscall(taskData, "stat failed", ERRORNUMBER);
/* Convert to microseconds. */
return Make_arb_from_pair_scaled(taskData, STAT_SECS(&fbuff,m),
STAT_USECS(&fbuff,m), 1000000);
}
/* Get file size. */
Handle fileSize(TaskData *taskData, Handle filename)
{
TempString cFileName(filename->Word());
if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
struct stat fbuff;
if (stat(cFileName, &fbuff) != 0)
raise_syscall(taskData, "stat failed", ERRORNUMBER);
return Make_arbitrary_precision(taskData, fbuff.st_size);
}
/* Set file modification and access times. */
Handle setTime(TaskData *taskData, Handle fileName, Handle fileTime)
{
TempString cFileName(fileName->Word());
if (cFileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
struct timeval times[2];
/* We have a value in microseconds. We need to split
it into seconds and microseconds. */
Handle hTime = fileTime;
Handle hMillion = Make_arbitrary_precision(taskData, 1000000);
/* N.B. Arguments to div_longc and rem_longc are in reverse order. */
unsigned secs =
get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hTime)));
unsigned usecs =
get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hTime)));
times[0].tv_sec = times[1].tv_sec = secs;
times[0].tv_usec = times[1].tv_usec = usecs;
if (utimes(cFileName, times) != 0)
raise_syscall(taskData, "utimes failed", ERRORNUMBER);
return Make_fixed_precision(taskData, 0);
}
/* Rename a file. */
Handle renameFile(TaskData *taskData, Handle oldFileName, Handle newFileName)
{
TempString oldName(oldFileName->Word()), newName(newFileName->Word());
if (oldName == 0 || newName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
if (rename(oldName, newName) != 0)
raise_syscall(taskData, "rename failed", ERRORNUMBER);
return Make_fixed_precision(taskData, 0);
}
/* Access right requests passed in from ML. */
#define FILE_ACCESS_READ 1
#define FILE_ACCESS_WRITE 2
#define FILE_ACCESS_EXECUTE 4
/* Get access rights to a file. */
Handle fileAccess(TaskData *taskData, Handle name, Handle rights)
{
TempString fileName(name->Word());
if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
int rts = get_C_int(taskData, DEREFWORD(rights));
int mode = 0;
if (rts & FILE_ACCESS_READ) mode |= R_OK;
if (rts & FILE_ACCESS_WRITE) mode |= W_OK;
if (rts & FILE_ACCESS_EXECUTE) mode |= X_OK;
if (mode == 0) mode = F_OK;
/* Return true if access is allowed, otherwise false
for any other error. */
if (access(fileName, mode) == 0)
return Make_fixed_precision(taskData, 1);
else return Make_fixed_precision(taskData, 0);
}
/* IO_dispatchc. Called from assembly code module. */
static Handle IO_dispatch_c(TaskData *taskData, Handle args, Handle strm, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORD(code));
switch (c)
{
case 0: /* Return standard input */
return wrapFileDescriptor(taskData, 0);
case 1: /* Return standard output */
return wrapFileDescriptor(taskData, 1);
case 2: /* Return standard error */
return wrapFileDescriptor(taskData, 2);
case 3: /* Open file for text input. */
case 4: /* Open file for binary input. */
return open_file(taskData, args, O_RDONLY, 0666, 0);
case 5: /* Open file for text output. */
case 6: /* Open file for binary output. */
return open_file(taskData, args, O_WRONLY | O_CREAT | O_TRUNC, 0666, 0);
case 7: /* Close file */
return close_file(taskData, strm);
case 8: /* Read text into an array. */
return readArray(taskData, strm, args, true);
case 9: /* Read binary into an array. */
return readArray(taskData, strm, args, false);
case 10: /* Get text as a string. */
return readString(taskData, strm, args, true);
case 11: /* Write from memory into a text file. */
return writeArray(taskData, strm, args, true);
case 12: /* Write from memory into a binary file. */
return writeArray(taskData, strm, args, false);
case 13: /* Open text file for appending. */
/* The IO library definition leaves it open whether this
should use "append mode" or not. */
case 14: /* Open binary file for appending. */
return open_file(taskData, args, O_WRONLY | O_CREAT | O_APPEND, 0666, 0);
case 15: /* Return recommended buffer size. */
// This is a guess but 4k seems reasonable.
return Make_fixed_precision(taskData, 4096);
case 16: /* See if we can get some input. */
{
int fd = getStreamFileDescriptor(taskData, strm->Word());
return Make_fixed_precision(taskData, isAvailable(taskData, fd) ? 1 : 0);
}
case 17: /* Return the number of bytes available. */
return bytesAvailable(taskData, strm);
case 18: /* Get position on stream. */
{
/* Get the current position in the stream. This is used to test
for the availability of random access so it should raise an
exception if setFilePos or endFilePos would fail. */
int fd = getStreamFileDescriptor(taskData, strm->Word());
long pos = seekStream(taskData, fd, 0L, SEEK_CUR);
return Make_arbitrary_precision(taskData, pos);
}
case 19: /* Seek to position on stream. */
{
long position = (long)get_C_long(taskData, DEREFWORD(args));
int fd = getStreamFileDescriptor(taskData, strm->Word());
(void)seekStream(taskData, fd, position, SEEK_SET);
return Make_arbitrary_precision(taskData, 0);
}
case 20: /* Return position at end of stream. */
{
int fd = getStreamFileDescriptor(taskData, strm->Word());
/* Remember our original position, seek to the end, then seek back. */
long original = seekStream(taskData, fd, 0L, SEEK_CUR);
long endOfStream = seekStream(taskData, fd, 0L, SEEK_END);
if (seekStream(taskData, fd, original, SEEK_SET) != original)
raise_syscall(taskData, "Position error", ERRORNUMBER);
return Make_arbitrary_precision(taskData, endOfStream);
}
case 21: /* Get the kind of device underlying the stream. */
return fileKind(taskData, strm);
case 22: /* Return the polling options allowed on this descriptor. */
return pollTest(taskData, strm);
// case 23: /* Poll the descriptor, waiting forever. */
// return pollDescriptors(taskData, args, 1);
// case 24: /* Poll the descriptor, waiting for the time requested. */
// return pollDescriptors(taskData, args, 0);
// case 25: /* Poll the descriptor, returning immediately.*/
// return pollDescriptors(taskData, args, 2);
case 26: /* Get binary as a vector. */
return readString(taskData, strm, args, false);
case 27: /* Block until input is available. */
// We should check for interrupts even if we're not going to block.
processes->TestAnyEvents(taskData);
waitForAvailableInput(taskData, strm);
return Make_fixed_precision(taskData, 0);
case 28: /* Test whether output is possible. */
return Make_fixed_precision(taskData, canOutput(taskData, strm) ? 1:0);
case 29: /* Block until output is possible. */
// We should check for interrupts even if we're not going to block.
processes->TestAnyEvents(taskData);
while (true) {
if (canOutput(taskData, strm))
return Make_fixed_precision(taskData, 0);
// Use the default waiter for the moment since we don't have
// one to test for output.
processes->ThreadPauseForIO(taskData, Waiter::defaultWaiter);
}
/* Functions added for Posix structure. */
case 30: /* Return underlying file descriptor. */
/* This is now also used internally to test for
stdIn, stdOut and stdErr. */
{
int fd = getStreamFileDescriptor(taskData, strm->Word());
return Make_fixed_precision(taskData, fd);
}
case 31: /* Make an entry for a given descriptor. */
{
int ioDesc = get_C_int(taskData, DEREFWORD(args));
return wrapFileDescriptor(taskData, ioDesc);
}
/* Directory functions. */
case 50: /* Open a directory. */
return openDirectory(taskData, args);
case 51: /* Read a directory entry. */
return readDirectory(taskData, strm);
case 52: /* Close the directory */
return closeDirectory(taskData, strm);
case 53: /* Rewind the directory. */
return rewindDirectory(taskData, strm, args);
case 54: /* Get current working directory. */
{
size_t size = 4096;
TempString string_buffer((char *)malloc(size * sizeof(char)));
if (string_buffer == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
char *cwd;
while ((cwd = getcwd(string_buffer, size)) == NULL && errno == ERANGE) {
if (size > std::numeric_limits::max() / 2) raise_fail(taskData, "getcwd needs too large a buffer");
size *= 2;
char *new_buf = (char *)realloc(string_buffer, size * sizeof(char));
if (new_buf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
string_buffer = new_buf;
}
if (cwd == NULL)
raise_syscall(taskData, "getcwd failed", ERRORNUMBER);
return SAVE(C_string_to_Poly(taskData, cwd));
}
case 55: /* Create a new directory. */
{
TempString dirName(args->Word());
if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
if (mkdir(dirName, 0777) != 0)
raise_syscall(taskData, "mkdir failed", ERRORNUMBER);
return Make_fixed_precision(taskData, 0);
}
case 56: /* Delete a directory. */
{
TempString dirName(args->Word());
if (dirName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
if (rmdir(dirName) != 0)
raise_syscall(taskData, "rmdir failed", ERRORNUMBER);
return Make_fixed_precision(taskData, 0);
}
case 57: /* Test for directory. */
return isDir(taskData, args);
case 58: /* Test for symbolic link. */
{
TempString fileName(args->Word());
if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
struct stat fbuff;
if (lstat(fileName, &fbuff) != 0)
raise_syscall(taskData, "stat failed", ERRORNUMBER);
return Make_fixed_precision(taskData,
((fbuff.st_mode & S_IFMT) == S_IFLNK) ? 1 : 0);
}
case 59: /* Read a symbolic link. */
{
int nLen;
TempString linkName(args->Word());
if (linkName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
size_t size = 4096;
TempString resBuf((char *)malloc(size * sizeof(char)));
if (resBuf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
// nLen is signed, so cast size to ssize_t to perform signed
// comparison, avoiding an infinite loop when nLen is -1.
while ((nLen = readlink(linkName, resBuf, size)) >= (ssize_t) size) {
size *= 2;
if (size > std::numeric_limits::max()) raise_fail(taskData, "readlink needs too large a buffer");
char *newBuf = (char *)realloc(resBuf, size * sizeof(char));
if (newBuf == NULL) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
resBuf = newBuf;
}
if (nLen < 0) raise_syscall(taskData, "readlink failed", ERRORNUMBER);
return(SAVE(C_string_to_Poly(taskData, resBuf, nLen)));
}
case 60: /* Return the full absolute path name. */
return fullPath(taskData, args);
case 61: /* Modification time. */
return modTime(taskData, args);
case 62: /* File size. */
return fileSize(taskData, args);
case 63: /* Set file time. */
return setTime(taskData, strm, args);
case 64: /* Delete a file. */
{
TempString fileName(args->Word());
if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
if (unlink(fileName) != 0)
raise_syscall(taskData, "unlink failed", ERRORNUMBER);
return Make_fixed_precision(taskData, 0);
}
case 65: /* rename a file. */
return renameFile(taskData, strm, args);
case 66: /* Get access rights. */
return fileAccess(taskData, strm, args);
case 67: /* Return a temporary file name. */
{
const char *template_subdir = "/MLTEMPXXXXXX";
#ifdef P_tmpdir
TempString buff((char *)malloc(strlen(P_tmpdir) + strlen(template_subdir) + 1));
if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
strcpy(buff, P_tmpdir);
#else
const char *tmpdir = "/tmp";
TempString buff((char *)malloc(strlen(tmpdir) + strlen(template_subdir) + 1));
if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
strcpy(buff, tmpdir);
#endif
strcat(buff, template_subdir);
#if (defined(HAVE_MKSTEMP) && ! defined(UNICODE))
// mkstemp is present in the Mingw64 headers but only as ANSI not Unicode.
// Set the umask to mask out access by anyone else.
// mkstemp generally does this anyway.
mode_t oldMask = umask(0077);
int fd = mkstemp(buff);
int wasError = ERRORNUMBER;
(void)umask(oldMask);
if (fd != -1) close(fd);
else raise_syscall(taskData, "mkstemp failed", wasError);
#else
if (mktemp(buff) == 0)
raise_syscall(taskData, "mktemp failed", ERRORNUMBER);
int fd = open(buff, O_RDWR | O_CREAT | O_EXCL, 00600);
if (fd != -1) close(fd);
else raise_syscall(taskData, "Temporary file creation failed", ERRORNUMBER);
#endif
Handle res = SAVE(C_string_to_Poly(taskData, buff));
return res;
}
case 68: /* Get the file id. */
{
struct stat fbuff;
TempString fileName(args->Word());
if (fileName == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
if (stat(fileName, &fbuff) != 0)
raise_syscall(taskData, "stat failed", ERRORNUMBER);
/* Assume that inodes are always non-negative. */
return Make_arbitrary_precision(taskData, fbuff.st_ino);
}
case 69: // Return an index for a token. It is used in OS.IO.hash.
// This is supposed to be well distributed for any 2^n but simply return
// the stream number.
return Make_fixed_precision(taskData, getStreamFileDescriptor(taskData, strm->Word()));
case 70: /* Posix.FileSys.openf - open a file with given mode. */
{
Handle name = taskData->saveVec.push(DEREFWORDHANDLE(args)->Get(0));
int mode = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(1));
return open_file(taskData, name, mode, 0666, 1);
}
case 71: /* Posix.FileSys.createf - create a file with given mode and access. */
{
Handle name = taskData->saveVec.push(DEREFWORDHANDLE(args)->Get(0));
int mode = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(1));
int access = get_C_int(taskData, DEREFWORDHANDLE(args)->Get(2));
return open_file(taskData, name, mode|O_CREAT, access, 1);
}
default:
{
char msg[100];
sprintf(msg, "Unknown io function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
// General interface to IO. Ideally the various cases will be made into
// separate functions.
POLYUNSIGNED PolyBasicIOGeneral(FirstArgument threadId, PolyWord code, PolyWord strm, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedCode = taskData->saveVec.push(code);
Handle pushedStrm = taskData->saveVec.push(strm);
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = IO_dispatch_c(taskData, pushedArg, pushedStrm, pushedCode);
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestAnyEvents may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
+// Create a persistent file descriptor value for Posix.FileSys.stdin etc.
+POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixCreatePersistentFD(FirstArgument threadId, PolyWord fd)
+{
+ TaskData *taskData = TaskData::FindTaskForId(threadId);
+ ASSERT(taskData != 0);
+ taskData->PreRTSCall();
+ Handle reset = taskData->saveVec.mark();
+ Handle result = 0;
+
+ try {
+ result = alloc_and_save(taskData,
+ WORDS(SIZEOF_VOIDP), F_BYTE_OBJ | F_MUTABLE_BIT | F_NO_OVERWRITE);
+ *(POLYSIGNED*)(result->Word().AsCodePtr()) = fd.UnTagged() + 1;
+ }
+ catch (...) { } // If an ML exception is raised - could have run out of memory
+
+ taskData->saveVec.reset(reset);
+ taskData->PostRTSCall();
+ if (result == 0) return TAGGED(0).AsUnsigned();
+ else return result->Word().AsUnsigned();
+
+}
struct _entrypts basicIOEPT[] =
{
{ "PolyChDir", (polyRTSFunction)&PolyChDir},
{ "PolyBasicIOGeneral", (polyRTSFunction)&PolyBasicIOGeneral},
{ "PolyPollIODescriptors", (polyRTSFunction)&PolyPollIODescriptors },
+ { "PolyPosixCreatePersistentFD", (polyRTSFunction)&PolyPosixCreatePersistentFD},
{ NULL, NULL} // End of list.
};
diff --git a/libpolyml/diagnostics.cpp b/libpolyml/diagnostics.cpp
index 48044d7d..e10856f2 100644
--- a/libpolyml/diagnostics.cpp
+++ b/libpolyml/diagnostics.cpp
@@ -1,205 +1,205 @@
/*
Title: Diagnostics
Copyright (c) 2011, 2015, 2018, 2019 David C.J. Matthews
Copyright (c) 2000
Cambridge University Technical Services Limited
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_STDARG_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_SIGNAL_H
#include
#endif
#ifdef HAVE_WINDOWS_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include "winstartup.h"
#include "winguiconsole.h"
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#endif
#include "errors.h"
#include "noreturn.h"
#include "globals.h"
#include "diagnostics.h"
#include "mpoly.h"
extern FILE *polyStdout;
unsigned debugOptions = 0; // Debugging options requested on command line.
void Exit(const char *msg, ...)
{
va_list vl;
fprintf(polyStdout, "\n");
va_start(vl, msg);
vfprintf(polyStdout, msg, vl);
va_end(vl);
fprintf(polyStdout, "\n");
fflush(polyStdout);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
if (useConsole)
{
MessageBox(hMainWindow, _T("Poly/ML has exited"), _T("Poly/ML"), MB_OK);
}
#endif
exit(1);
}
// Error condition. This should really be replaced either with ASSERTs
// or exceptions.
void Crash(const char *msg, ...)
{
va_list vl;
fprintf(polyStdout, "\n");
va_start(vl, msg);
vfprintf(polyStdout, msg, vl);
va_end(vl);
fprintf(polyStdout, "\n");
fflush(polyStdout);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
if (useConsole)
{
MessageBox(hMainWindow, _T("Poly/ML has exited"), _T("Poly/ML"), MB_OK);
}
#else
{
sigset_t set;
sigemptyset(&set);
sigprocmask(SIG_SETMASK,&set,NULL);
}
#endif
ASSERT(0); // Force a core dump
abort();
exit(1);
}
void ExitWithError(const char *msg, int err)
{
fputs("\n", polyStdout);
fputs(msg, polyStdout);
const char *errorMsg = stringFromErrorCode(err);
if (errorMsg != NULL) puts(errorMsg);
fputs("\n", polyStdout);
fflush(polyStdout);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
if (useConsole)
{
MessageBox(hMainWindow, _T("Poly/ML has exited"), _T("Poly/ML"), MB_OK);
}
#endif
exit(1);
}
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
// Default is to log with OutputDebugString
static FILE *logStream = NULL;
#else
// Default is to log to stdout
static FILE *logStream = stdout;
#endif
void SetLogFile(const TCHAR *fileName)
{
#if (defined(_WIN32) && defined(UNICODE))
FILE *stream = _wfopen(fileName, L"w");
if (stream == NULL)
fprintf(polyStdout, "Unable to open debug file %S\n", fileName);
else logStream = stream;
#else
FILE *stream = fopen(fileName, "w");
if (stream == NULL)
fprintf(polyStdout, "Unable to open debug file %s\n", fileName);
else logStream = stream;
#endif
}
// For the moment log to stdout
void Log(const char *msg, ...)
{
va_list vl;
va_start(vl, msg);
if (logStream) vfprintf(logStream, msg, vl);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
char buff[1024];
if (_vsnprintf(buff, sizeof(buff), msg, vl) > 0)
::OutputDebugStringA(buff);
#endif
va_end(vl);
if (logStream) fflush(logStream);
}
// Log the size of a space as a comprehensible number
void LogSize(uintptr_t wordSize)
{
uintptr_t size = wordSize * sizeof(PolyWord);
if (size < 10*1024)
Log("%zu", size);
else
{
double s = (double)size;
if (s < 1024000.0)
Log("%1.2fK", s / 1024.0);
else if (s < 1000.0 * 1024.0 * 1024.0)
Log("%1.2fM", s / (1024.0 * 1024.0));
else Log("%1.2fG", s / (1024.0 * 1024.0 * 1024.0));
}
}
diff --git a/libpolyml/errors.cpp b/libpolyml/errors.cpp
index 6301ab96..0ef8d7a1 100644
--- a/libpolyml/errors.cpp
+++ b/libpolyml/errors.cpp
@@ -1,1334 +1,1334 @@
/*
Title: Error Messages.
- Copyright (c) 2012, 2017 David C. J. Matthews
+ Copyright (c) 2012, 2017, 2019 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#endif
#ifdef HAVE_WINDOWS_H
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#include "errors.h"
static struct {
int errorNum;
const char* errorString;
} errortable[] =
{
-#if(!defined(_WIN32) || defined(__CYGWIN__))
+#if (!defined(_WIN32))
#ifdef EPERM
{ EPERM, "EPERM" },
#endif
#ifdef ENOENT
{ ENOENT, "ENOENT" },
#endif
#ifdef ESRCH
{ ESRCH, "ESRCH" },
#endif
#ifdef EINTR
{ EINTR, "EINTR"},
#endif
#ifdef EIO
{ EIO, "EIO"},
#endif
#ifdef ENXIO
{ ENXIO, "ENXIO"},
#endif
#ifdef E2BIG
{ E2BIG, "E2BIG"},
#endif
#ifdef ENOEXEC
{ ENOEXEC, "ENOEXEC"},
#endif
#ifdef EBADF
{ EBADF, "EBADF"},
#endif
#ifdef ECHILD
{ ECHILD, "ECHILD"},
#endif
#ifdef EAGAIN
{ EAGAIN, "EAGAIN"},
#endif
#ifdef EDEADLK
{ EDEADLK, "EDEADLK"},
#endif
#ifdef ENOMEM
{ ENOMEM, "ENOMEM"},
#endif
#ifdef EACCES
{ EACCES, "EACCES"},
#endif
#ifdef EFAULT
{ EFAULT, "EFAULT"},
#endif
#ifdef ENOTBLK
{ ENOTBLK, "ENOTBLK"},
#endif
#ifdef EBUSY
{ EBUSY, "EBUSY"},
#endif
#ifdef EEXIST
{ EEXIST, "EEXIST"},
#endif
#ifdef EXDEV
{ EXDEV, "EXDEV"},
#endif
#ifdef ENODEV
{ ENODEV, "ENODEV"},
#endif
#ifdef ENOTDIR
{ ENOTDIR, "ENOTDIR"},
#endif
#ifdef EISDIR
{ EISDIR, "EISDIR"},
#endif
#ifdef EINVAL
{ EINVAL, "EINVAL"},
#endif
#ifdef ENFILE
{ ENFILE, "ENFILE"},
#endif
#ifdef EMFILE
{ EMFILE, "EMFILE"},
#endif
#ifdef ENOTTY
{ ENOTTY, "ENOTTY"},
#endif
#ifdef ETXTBSY
{ ETXTBSY, "ETXTBSY"},
#endif
#ifdef EFBIG
{ EFBIG, "EFBIG"},
#endif
#ifdef ENOSPC
{ ENOSPC, "ENOSPC"},
#endif
#ifdef ESPIPE
{ ESPIPE, "ESPIPE"},
#endif
#ifdef EROFS
{ EROFS, "EROFS"},
#endif
#ifdef EMLINK
{ EMLINK, "EMLINK"},
#endif
#ifdef EPIPE
{ EPIPE, "EPIPE"},
#endif
#ifdef EDOM
{ EDOM, "EDOM"},
#endif
#ifdef ERANGE
{ ERANGE, "ERANGE"},
#endif
#ifdef ENOMSG
{ ENOMSG, "ENOMSG"},
#endif
#ifdef EUCLEAN
{ EUCLEAN, "EUCLEAN"},
#endif
#ifdef EWOULDBLOCK
{ EWOULDBLOCK, "EWOULDBLOCK"},
#endif
#ifdef EIDRM
{ EIDRM, "EIDRM"},
#endif
#ifdef EINPROGRESS
{ EINPROGRESS, "EINPROGRESS"},
#endif
#ifdef ECHRNG
{ ECHRNG, "ECHRNG"},
#endif
#ifdef EALREADY
{ EALREADY, "EALREADY"},
#endif
#ifdef EL2NSYNC
{ EL2NSYNC, "EL2NSYNC"},
#endif
#ifdef ENAMETOOLONG
{ ENAMETOOLONG, "ENAMETOOLONG"},
#endif
#ifdef ENOTSOCK
{ ENOTSOCK, "ENOTSOCK"},
#endif
#ifdef EL3HLT
{ EL3HLT, "EL3HLT"},
#endif
#ifdef ENOLCK
{ ENOLCK, "ENOLCK"},
#endif
#ifdef EDESTADDRREQ
{ EDESTADDRREQ, "EDESTADDRREQ"},
#endif
#ifdef EL3RST
{ EL3RST, "EL3RST"},
#endif
#ifdef ENOSYS
{ ENOSYS, "ENOSYS"},
#endif
#ifdef EMSGSIZE
{ EMSGSIZE, "EMSGSIZE"},
#endif
#ifdef ELNRNG
{ ELNRNG, "ELNRNG"},
#endif
#ifdef ENOTEMPTY
{ ENOTEMPTY, "ENOTEMPTY"},
#endif
#ifdef EPROTOTYPE
{ EPROTOTYPE, "EPROTOTYPE"},
#endif
#ifdef EUNATCH
{ EUNATCH, "EUNATCH"},
#endif
#ifdef EILSEQ
{ EILSEQ, "EILSEQ"},
#endif
#ifdef ENOPROTOOPT
{ ENOPROTOOPT, "ENOPROTOOPT"},
#endif
#ifdef ENOCSI
{ ENOCSI, "ENOCSI"},
#endif
#ifdef EPROTONOSUPPORT
{ EPROTONOSUPPORT, "EPROTONOSUPPORT"},
#endif
#ifdef EL2HLT
{ EL2HLT, "EL2HLT"},
#endif
#ifdef ESOCKTNOSUPPORT
{ ESOCKTNOSUPPORT, "ESOCKTNOSUPPORT"},
#endif
#ifdef EOPNOTSUPP
{ EOPNOTSUPP, "EOPNOTSUPP"},
#endif
#ifdef ENOTREADY
{ ENOTREADY, "ENOTREADY"},
#endif
#ifdef EPFNOSUPPORT
{ EPFNOSUPPORT, "EPFNOSUPPORT"},
#endif
#ifdef EWRPROTECT
{ EWRPROTECT, "EWRPROTECT"},
#endif
#ifdef EAFNOSUPPORT
{ EAFNOSUPPORT, "EAFNOSUPPORT"},
#endif
#ifdef EFORMAT
{ EFORMAT, "EFORMAT"},
#endif
#ifdef EADDRINUSE
{ EADDRINUSE, "EADDRINUSE"},
#endif
#ifdef EADDRNOTAVAIL
{ EADDRNOTAVAIL, "EADDRNOTAVAIL"},
#endif
#ifdef ENOCONNECT
{ ENOCONNECT, "ENOCONNECT"},
#endif
#ifdef ENETDOWN
{ ENETDOWN, "ENETDOWN"},
#endif
#ifdef ESTALE
{ ESTALE, "ESTALE"},
#endif
#ifdef ENETUNREACH
{ ENETUNREACH, "ENETUNREACH"},
#endif
#ifdef EDIST
{ EDIST, "EDIST"},
#endif
#ifdef ENETRESET
{ ENETRESET, "ENETRESET"},
#endif
#ifdef ECONNABORTED
{ ECONNABORTED, "ECONNABORTED"},
#endif
#ifdef ECONNRESET
{ ECONNRESET, "ECONNRESET"},
#endif
#ifdef ENOBUFS
{ ENOBUFS, "ENOBUFS"},
#endif
#ifdef EISCONN
{ EISCONN, "EISCONN"},
#endif
#ifdef ENOTCONN
{ ENOTCONN, "ENOTCONN"},
#endif
#ifdef ESHUTDOWN
{ ESHUTDOWN, "ESHUTDOWN"},
#endif
#ifdef ETOOMANYREFS
{ ETOOMANYREFS, "ETOOMANYREFS"},
#endif
#ifdef ETIMEDOUT
{ ETIMEDOUT, "ETIMEDOUT"},
#endif
#ifdef ECONNREFUSED
{ ECONNREFUSED, "ECONNREFUSED"},
#endif
#ifdef ELOOP
{ ELOOP, "ELOOP"},
#endif
#ifdef EHOSTDOWN
{ EHOSTDOWN, "EHOSTDOWN"},
#endif
#ifdef EHOSTUNREACH
{ EHOSTUNREACH, "EHOSTUNREACH"},
#endif
#ifdef EPROCLIM
{ EPROCLIM, "EPROCLIM"},
#endif
#ifdef EUSERS
{ EUSERS, "EUSERS"},
#endif
#ifdef EDQUOT
{ EDQUOT, "EDQUOT"},
#endif
#ifdef EREMOTE
{ EREMOTE, "EREMOTE"},
#endif
#ifdef ENOSTR
{ ENOSTR, "ENOSTR"},
#endif
#ifdef EBADRPC
{ EBADRPC, "EBADRPC"},
#endif
#ifdef ETIME
{ ETIME, "ETIME"},
#endif
#ifdef ERPCMISMATCH
{ ERPCMISMATCH, "ERPCMISMATCH"},
#endif
#ifdef ENOSR
{ ENOSR, "ENOSR"},
#endif
#ifdef EPROGUNAVAIL
{ EPROGUNAVAIL, "EPROGUNAVAIL"},
#endif
#ifdef EPROGMISMATCH
{ EPROGMISMATCH, "EPROGMISMATCH"},
#endif
#ifdef EBADMSG
{ EBADMSG, "EBADMSG"},
#endif
#ifdef EPROCUNAVAIL
{ EPROCUNAVAIL, "EPROCUNAVAIL"},
#endif
#ifdef EFTYPE
{ EFTYPE, "EFTYPE"},
#endif
#ifdef ENONET
{ ENONET, "ENONET"},
#endif
#ifdef EAUTH
{ EAUTH, "EAUTH"},
#endif
#ifdef ERESTART
{ ERESTART, "ERESTART"},
#endif
#ifdef ERREMOTE
{ ERREMOTE, "ERREMOTE"},
#endif
#ifdef ENEEDAUTH
{ ENEEDAUTH, "ENEEDAUTH"},
#endif
#ifdef ENOLINK
{ ENOLINK, "ENOLINK"},
#endif
#ifdef EADV
{ EADV, "EADV"},
#endif
#ifdef ESRMNT
{ ESRMNT, "ESRMNT"},
#endif
#ifdef ECOMM
{ ECOMM, "ECOMM"},
#endif
#ifdef EPROTO
{ EPROTO, "EPROTO"},
#endif
#ifdef EMULTIHOP
{ EMULTIHOP, "EMULTIHOP"},
#endif
#ifdef EDOTDOT
{ EDOTDOT, "EDOTDOT"},
#endif
#ifdef EREMCHG
{ EREMCHG, "EREMCHG"},
#endif
#ifdef EMEDIA
{ EMEDIA, "EMEDIA"},
#endif
#ifdef ESOFT
{ ESOFT, "ESOFT"},
#endif
#ifdef ENOATTR
{ ENOATTR, "ENOATTR"},
#endif
#ifdef ESAD
{ ESAD, "ESAD"},
#endif
#ifdef ENOTRUST
{ ENOTRUST, "ENOTRUST"},
#endif
#ifdef ECANCELED
{ ECANCELED, "ECANCELED"},
#endif
#ifdef ENODATA
{ ENODATA, "ENODATA"},
#endif
#ifdef EBADE
{ EBADE, "EBADE"},
#endif
#ifdef EBADR
{ EBADR, "EBADR"},
#endif
#ifdef EXFULL
{ EXFULL, "EXFULL"},
#endif
#ifdef ENOANO
{ ENOANO, "ENOANO"},
#endif
#ifdef EBADRQC
{ EBADRQC, "EBADRQC"},
#endif
#ifdef EBADSLT
{ EBADSLT, "EBADSLT"},
#endif
#ifdef EDEADLOCK
{ EDEADLOCK, "EDEADLOCK"},
#endif
#ifdef EBFONT
{ EBFONT, "EBFONT"},
#endif
#ifdef EBFONT
{ EBFONT, "EBFONT"},
#endif
#ifdef ENOPKG
{ ENOPKG, "ENOPKG"},
#endif
#ifdef ELBIN
{ ELBIN, "ELBIN"},
#endif
#ifdef ENOTUNIQ
{ ENOTUNIQ, "ENOTUNIQ"},
#endif
#ifdef EBADFD
{ EBADFD, "EBADFD"},
#endif
#ifdef ELIBACC
{ ELIBACC, "ELIBACC"},
#endif
#ifdef ELIBBAD
{ ELIBBAD, "ELIBBAD"},
#endif
#ifdef ELIBSCN
{ ELIBSCN, "ELIBSCN"},
#endif
#ifdef ELIBMAX
{ ELIBMAX, "ELIBMAX"},
#endif
#ifdef ESTRPIPE
{ ESTRPIPE, "ESTRPIPE"},
#endif
#ifdef ELIBEXEC
{ ELIBEXEC, "ELIBEXEC"},
#endif
#ifdef ENMFILE
{ ENMFILE, "ENMFILE"},
#endif
#ifdef ENOTNAM
{ ENOTNAM, "ENOTNAM"},
#endif
#ifdef ENAVAIL
{ ENAVAIL, "ENAVAIL"},
#endif
#ifdef EISNAM
{ EISNAM, "EISNAM"},
#endif
#ifdef EREMOTEIO
{ EREMOTEIO, "EREMOTEIO"},
#endif
#ifdef ENOMEDIUM
{ ENOMEDIUM, "ENOMEDIUM"},
#endif
#ifdef EMEDIUMTYPE
{ EMEDIUMTYPE, "EMEDIUMTYPE"},
#endif
#ifdef ENOKEY
{ ENOKEY, "ENOKEY"},
#endif
#ifdef EKEYEXPIRED
{ EKEYEXPIRED, "EKEYEXPIRED"},
#endif
#ifdef EKEYREVOKED
{ EKEYREVOKED, "EKEYREVOKED"},
#endif
#ifdef EKEYREJECTED
{ EKEYREJECTED, "EKEYREJECTED"},
#endif
#ifdef EOWNERDEAD
{ EOWNERDEAD, "EOWNERDEAD"},
#endif
#ifdef ENOTRECOVERABLE
{ ENOTRECOVERABLE, "ENOTRECOVERABLE"},
#endif
#ifdef ENOTSUP
{ ENOTSUP, "ENOTSUP"},
#endif
#ifdef ENOMEDIUM
{ ENOMEDIUM, "ENOMEDIUM"},
#endif
#ifdef ENOSHARE
{ ENOSHARE, "ENOSHARE"},
#endif
#ifdef ECASECLASH
{ ECASECLASH, "ECASECLASH"},
#endif
#ifdef EOVERFLOW
{ EOVERFLOW, "EOVERFLOW"},
#endif
#else
{ ERROR_INVALID_FUNCTION, "ERROR_INVALID_FUNCTION" },
{ ERROR_FILE_NOT_FOUND, "ERROR_FILE_NOT_FOUND" },
{ ERROR_PATH_NOT_FOUND, "ERROR_PATH_NOT_FOUND" },
{ ERROR_TOO_MANY_OPEN_FILES, "ERROR_TOO_MANY_OPEN_FILES" },
{ ERROR_ACCESS_DENIED, "ERROR_ACCESS_DENIED" },
{ ERROR_INVALID_HANDLE, "ERROR_INVALID_HANDLE" },
{ ERROR_ARENA_TRASHED, "ERROR_ARENA_TRASHED" },
{ ERROR_NOT_ENOUGH_MEMORY, "ERROR_NOT_ENOUGH_MEMORY" },
{ ERROR_INVALID_BLOCK, "ERROR_INVALID_BLOCK" },
{ ERROR_BAD_ENVIRONMENT, "ERROR_BAD_ENVIRONMENT" },
{ ERROR_BAD_FORMAT, "ERROR_BAD_FORMAT" },
{ ERROR_INVALID_ACCESS, "ERROR_INVALID_ACCESS" },
{ ERROR_INVALID_DATA, "ERROR_INVALID_DATA" },
{ ERROR_OUTOFMEMORY, "ERROR_OUTOFMEMORY" },
{ ERROR_INVALID_DRIVE, "ERROR_INVALID_DRIVE" },
{ ERROR_CURRENT_DIRECTORY, "ERROR_CURRENT_DIRECTORY" },
{ ERROR_NOT_SAME_DEVICE, "ERROR_NOT_SAME_DEVICE" },
{ ERROR_NO_MORE_FILES, "ERROR_NO_MORE_FILES" },
{ ERROR_WRITE_PROTECT, "ERROR_WRITE_PROTECT" },
{ ERROR_BAD_UNIT, "ERROR_BAD_UNIT" },
{ ERROR_NOT_READY, "ERROR_NOT_READY" },
{ ERROR_BAD_COMMAND, "ERROR_BAD_COMMAND" },
{ ERROR_CRC, "ERROR_CRC" },
{ ERROR_BAD_LENGTH, "ERROR_BAD_LENGTH" },
{ ERROR_SEEK, "ERROR_SEEK" },
{ ERROR_NOT_DOS_DISK, "ERROR_NOT_DOS_DISK" },
{ ERROR_SECTOR_NOT_FOUND, "ERROR_SECTOR_NOT_FOUND" },
{ ERROR_OUT_OF_PAPER, "ERROR_OUT_OF_PAPER" },
{ ERROR_WRITE_FAULT, "ERROR_WRITE_FAULT" },
{ ERROR_READ_FAULT, "ERROR_READ_FAULT" },
{ ERROR_GEN_FAILURE, "ERROR_GEN_FAILURE" },
{ ERROR_SHARING_VIOLATION, "ERROR_SHARING_VIOLATION" },
{ ERROR_LOCK_VIOLATION, "ERROR_LOCK_VIOLATION" },
{ ERROR_WRONG_DISK, "ERROR_WRONG_DISK" },
{ ERROR_SHARING_BUFFER_EXCEEDED, "ERROR_SHARING_BUFFER_EXCEEDED" },
{ ERROR_HANDLE_EOF, "ERROR_HANDLE_EOF" },
{ ERROR_HANDLE_DISK_FULL, "ERROR_HANDLE_DISK_FULL" },
{ ERROR_NOT_SUPPORTED, "ERROR_NOT_SUPPORTED" },
{ ERROR_REM_NOT_LIST, "ERROR_REM_NOT_LIST" },
{ ERROR_DUP_NAME, "ERROR_DUP_NAME" },
{ ERROR_BAD_NETPATH, "ERROR_BAD_NETPATH" },
{ ERROR_NETWORK_BUSY, "ERROR_NETWORK_BUSY" },
{ ERROR_DEV_NOT_EXIST, "ERROR_DEV_NOT_EXIST" },
{ ERROR_TOO_MANY_CMDS, "ERROR_TOO_MANY_CMDS" },
{ ERROR_ADAP_HDW_ERR, "ERROR_ADAP_HDW_ERR" },
{ ERROR_BAD_NET_RESP, "ERROR_BAD_NET_RESP" },
{ ERROR_UNEXP_NET_ERR, "ERROR_UNEXP_NET_ERR" },
{ ERROR_BAD_REM_ADAP, "ERROR_BAD_REM_ADAP" },
{ ERROR_PRINTQ_FULL, "ERROR_PRINTQ_FULL" },
{ ERROR_NO_SPOOL_SPACE, "ERROR_NO_SPOOL_SPACE" },
{ ERROR_PRINT_CANCELLED, "ERROR_PRINT_CANCELLED" },
{ ERROR_NETNAME_DELETED, "ERROR_NETNAME_DELETED" },
{ ERROR_NETWORK_ACCESS_DENIED, "ERROR_NETWORK_ACCESS_DENIED" },
{ ERROR_BAD_DEV_TYPE, "ERROR_BAD_DEV_TYPE" },
{ ERROR_BAD_NET_NAME, "ERROR_BAD_NET_NAME" },
{ ERROR_TOO_MANY_NAMES, "ERROR_TOO_MANY_NAMES" },
{ ERROR_TOO_MANY_SESS, "ERROR_TOO_MANY_SESS" },
{ ERROR_SHARING_PAUSED, "ERROR_SHARING_PAUSED" },
{ ERROR_REQ_NOT_ACCEP, "ERROR_REQ_NOT_ACCEP" },
{ ERROR_REDIR_PAUSED, "ERROR_REDIR_PAUSED" },
{ ERROR_FILE_EXISTS, "ERROR_FILE_EXISTS" },
{ ERROR_CANNOT_MAKE, "ERROR_CANNOT_MAKE" },
{ ERROR_FAIL_I24, "ERROR_FAIL_I24" },
{ ERROR_OUT_OF_STRUCTURES, "ERROR_OUT_OF_STRUCTURES" },
{ ERROR_ALREADY_ASSIGNED, "ERROR_ALREADY_ASSIGNED" },
{ ERROR_INVALID_PASSWORD, "ERROR_INVALID_PASSWORD" },
{ ERROR_INVALID_PARAMETER, "ERROR_INVALID_PARAMETER" },
{ ERROR_NET_WRITE_FAULT, "ERROR_NET_WRITE_FAULT" },
{ ERROR_NO_PROC_SLOTS, "ERROR_NO_PROC_SLOTS" },
{ ERROR_TOO_MANY_SEMAPHORES, "ERROR_TOO_MANY_SEMAPHORES" },
{ ERROR_EXCL_SEM_ALREADY_OWNED, "ERROR_EXCL_SEM_ALREADY_OWNED" },
{ ERROR_SEM_IS_SET, "ERROR_SEM_IS_SET" },
{ ERROR_TOO_MANY_SEM_REQUESTS, "ERROR_TOO_MANY_SEM_REQUESTS" },
{ ERROR_INVALID_AT_INTERRUPT_TIME, "ERROR_INVALID_AT_INTERRUPT_TIME" },
{ ERROR_SEM_OWNER_DIED, "ERROR_SEM_OWNER_DIED" },
{ ERROR_SEM_USER_LIMIT, "ERROR_SEM_USER_LIMIT" },
{ ERROR_DISK_CHANGE, "ERROR_DISK_CHANGE" },
{ ERROR_DRIVE_LOCKED, "ERROR_DRIVE_LOCKED" },
{ ERROR_BROKEN_PIPE, "ERROR_BROKEN_PIPE" },
{ ERROR_OPEN_FAILED, "ERROR_OPEN_FAILED" },
{ ERROR_BUFFER_OVERFLOW, "ERROR_BUFFER_OVERFLOW" },
{ ERROR_DISK_FULL, "ERROR_DISK_FULL" },
{ ERROR_NO_MORE_SEARCH_HANDLES, "ERROR_NO_MORE_SEARCH_HANDLES" },
{ ERROR_INVALID_TARGET_HANDLE, "ERROR_INVALID_TARGET_HANDLE" },
{ ERROR_INVALID_CATEGORY, "ERROR_INVALID_CATEGORY" },
{ ERROR_INVALID_VERIFY_SWITCH, "ERROR_INVALID_VERIFY_SWITCH" },
{ ERROR_BAD_DRIVER_LEVEL, "ERROR_BAD_DRIVER_LEVEL" },
{ ERROR_CALL_NOT_IMPLEMENTED, "ERROR_CALL_NOT_IMPLEMENTED" },
{ ERROR_SEM_TIMEOUT, "ERROR_SEM_TIMEOUT" },
{ ERROR_INSUFFICIENT_BUFFER, "ERROR_INSUFFICIENT_BUFFER" },
{ ERROR_INVALID_NAME, "ERROR_INVALID_NAME" },
{ ERROR_INVALID_LEVEL, "ERROR_INVALID_LEVEL" },
{ ERROR_NO_VOLUME_LABEL, "ERROR_NO_VOLUME_LABEL" },
{ ERROR_MOD_NOT_FOUND, "ERROR_MOD_NOT_FOUND" },
{ ERROR_PROC_NOT_FOUND, "ERROR_PROC_NOT_FOUND" },
{ ERROR_WAIT_NO_CHILDREN, "ERROR_WAIT_NO_CHILDREN" },
{ ERROR_CHILD_NOT_COMPLETE, "ERROR_CHILD_NOT_COMPLETE" },
{ ERROR_DIRECT_ACCESS_HANDLE, "ERROR_DIRECT_ACCESS_HANDLE" },
{ ERROR_NEGATIVE_SEEK, "ERROR_NEGATIVE_SEEK" },
{ ERROR_SEEK_ON_DEVICE, "ERROR_SEEK_ON_DEVICE" },
{ ERROR_IS_JOIN_TARGET, "ERROR_IS_JOIN_TARGET" },
{ ERROR_IS_JOINED, "ERROR_IS_JOINED" },
{ ERROR_IS_SUBSTED, "ERROR_IS_SUBSTED" },
{ ERROR_NOT_JOINED, "ERROR_NOT_JOINED" },
{ ERROR_NOT_SUBSTED, "ERROR_NOT_SUBSTED" },
{ ERROR_JOIN_TO_JOIN, "ERROR_JOIN_TO_JOIN" },
{ ERROR_SUBST_TO_SUBST, "ERROR_SUBST_TO_SUBST" },
{ ERROR_JOIN_TO_SUBST, "ERROR_JOIN_TO_SUBST" },
{ ERROR_SUBST_TO_JOIN, "ERROR_SUBST_TO_JOIN" },
{ ERROR_BUSY_DRIVE, "ERROR_BUSY_DRIVE" },
{ ERROR_SAME_DRIVE, "ERROR_SAME_DRIVE" },
{ ERROR_DIR_NOT_ROOT, "ERROR_DIR_NOT_ROOT" },
{ ERROR_DIR_NOT_EMPTY, "ERROR_DIR_NOT_EMPTY" },
{ ERROR_IS_SUBST_PATH, "ERROR_IS_SUBST_PATH" },
{ ERROR_IS_JOIN_PATH, "ERROR_IS_JOIN_PATH" },
{ ERROR_PATH_BUSY, "ERROR_PATH_BUSY" },
{ ERROR_IS_SUBST_TARGET, "ERROR_IS_SUBST_TARGET" },
{ ERROR_SYSTEM_TRACE, "ERROR_SYSTEM_TRACE" },
{ ERROR_INVALID_EVENT_COUNT, "ERROR_INVALID_EVENT_COUNT" },
{ ERROR_TOO_MANY_MUXWAITERS, "ERROR_TOO_MANY_MUXWAITERS" },
{ ERROR_INVALID_LIST_FORMAT, "ERROR_INVALID_LIST_FORMAT" },
{ ERROR_LABEL_TOO_LONG, "ERROR_LABEL_TOO_LONG" },
{ ERROR_TOO_MANY_TCBS, "ERROR_TOO_MANY_TCBS" },
{ ERROR_SIGNAL_REFUSED, "ERROR_SIGNAL_REFUSED" },
{ ERROR_DISCARDED, "ERROR_DISCARDED" },
{ ERROR_NOT_LOCKED, "ERROR_NOT_LOCKED" },
{ ERROR_BAD_THREADID_ADDR, "ERROR_BAD_THREADID_ADDR" },
{ ERROR_BAD_ARGUMENTS, "ERROR_BAD_ARGUMENTS" },
{ ERROR_BAD_PATHNAME, "ERROR_BAD_PATHNAME" },
{ ERROR_SIGNAL_PENDING, "ERROR_SIGNAL_PENDING" },
{ ERROR_MAX_THRDS_REACHED, "ERROR_MAX_THRDS_REACHED" },
{ ERROR_LOCK_FAILED, "ERROR_LOCK_FAILED" },
{ ERROR_BUSY, "ERROR_BUSY" },
{ ERROR_CANCEL_VIOLATION, "ERROR_CANCEL_VIOLATION" },
{ ERROR_ATOMIC_LOCKS_NOT_SUPPORTED, "ERROR_ATOMIC_LOCKS_NOT_SUPPORTED" },
{ ERROR_INVALID_SEGMENT_NUMBER, "ERROR_INVALID_SEGMENT_NUMBER" },
{ ERROR_INVALID_ORDINAL, "ERROR_INVALID_ORDINAL" },
{ ERROR_ALREADY_EXISTS, "ERROR_ALREADY_EXISTS" },
{ ERROR_INVALID_FLAG_NUMBER, "ERROR_INVALID_FLAG_NUMBER" },
{ ERROR_SEM_NOT_FOUND, "ERROR_SEM_NOT_FOUND" },
{ ERROR_INVALID_STARTING_CODESEG, "ERROR_INVALID_STARTING_CODESEG" },
{ ERROR_INVALID_STACKSEG, "ERROR_INVALID_STACKSEG" },
{ ERROR_INVALID_MODULETYPE, "ERROR_INVALID_MODULETYPE" },
{ ERROR_INVALID_EXE_SIGNATURE, "ERROR_INVALID_EXE_SIGNATURE" },
{ ERROR_EXE_MARKED_INVALID, "ERROR_EXE_MARKED_INVALID" },
{ ERROR_BAD_EXE_FORMAT, "ERROR_BAD_EXE_FORMAT" },
{ ERROR_ITERATED_DATA_EXCEEDS_64k, "ERROR_ITERATED_DATA_EXCEEDS_64k" },
{ ERROR_INVALID_MINALLOCSIZE, "ERROR_INVALID_MINALLOCSIZE" },
{ ERROR_DYNLINK_FROM_INVALID_RING, "ERROR_DYNLINK_FROM_INVALID_RING" },
{ ERROR_IOPL_NOT_ENABLED, "ERROR_IOPL_NOT_ENABLED" },
{ ERROR_INVALID_SEGDPL, "ERROR_INVALID_SEGDPL" },
{ ERROR_AUTODATASEG_EXCEEDS_64k, "ERROR_AUTODATASEG_EXCEEDS_64k" },
{ ERROR_RING2SEG_MUST_BE_MOVABLE, "ERROR_RING2SEG_MUST_BE_MOVABLE" },
{ ERROR_RELOC_CHAIN_XEEDS_SEGLIM, "ERROR_RELOC_CHAIN_XEEDS_SEGLIM" },
{ ERROR_INFLOOP_IN_RELOC_CHAIN, "ERROR_INFLOOP_IN_RELOC_CHAIN" },
{ ERROR_ENVVAR_NOT_FOUND, "ERROR_ENVVAR_NOT_FOUND" },
{ ERROR_NO_SIGNAL_SENT, "ERROR_NO_SIGNAL_SENT" },
{ ERROR_FILENAME_EXCED_RANGE, "ERROR_FILENAME_EXCED_RANGE" },
{ ERROR_RING2_STACK_IN_USE, "ERROR_RING2_STACK_IN_USE" },
{ ERROR_META_EXPANSION_TOO_LONG, "ERROR_META_EXPANSION_TOO_LONG" },
{ ERROR_INVALID_SIGNAL_NUMBER, "ERROR_INVALID_SIGNAL_NUMBER" },
{ ERROR_THREAD_1_INACTIVE, "ERROR_THREAD_1_INACTIVE" },
{ ERROR_LOCKED, "ERROR_LOCKED" },
{ ERROR_TOO_MANY_MODULES, "ERROR_TOO_MANY_MODULES" },
{ ERROR_NESTING_NOT_ALLOWED, "ERROR_NESTING_NOT_ALLOWED" },
#ifdef ERROR_EXE_MACHINE_TYPE_MISMATCH
{ ERROR_EXE_MACHINE_TYPE_MISMATCH, "ERROR_EXE_MACHINE_TYPE_MISMATCH" },
#endif
{ ERROR_BAD_PIPE, "ERROR_BAD_PIPE" },
{ ERROR_PIPE_BUSY, "ERROR_PIPE_BUSY" },
{ ERROR_NO_DATA, "ERROR_NO_DATA" },
{ ERROR_PIPE_NOT_CONNECTED, "ERROR_PIPE_NOT_CONNECTED" },
{ ERROR_MORE_DATA, "ERROR_MORE_DATA" },
{ ERROR_VC_DISCONNECTED, "ERROR_VC_DISCONNECTED" },
{ ERROR_INVALID_EA_NAME, "ERROR_INVALID_EA_NAME" },
{ ERROR_EA_LIST_INCONSISTENT, "ERROR_EA_LIST_INCONSISTENT" },
{ ERROR_NO_MORE_ITEMS, "ERROR_NO_MORE_ITEMS" },
{ ERROR_CANNOT_COPY, "ERROR_CANNOT_COPY" },
{ ERROR_DIRECTORY, "ERROR_DIRECTORY" },
{ ERROR_EAS_DIDNT_FIT, "ERROR_EAS_DIDNT_FIT" },
{ ERROR_EA_FILE_CORRUPT, "ERROR_EA_FILE_CORRUPT" },
{ ERROR_EA_TABLE_FULL, "ERROR_EA_TABLE_FULL" },
{ ERROR_INVALID_EA_HANDLE, "ERROR_INVALID_EA_HANDLE" },
{ ERROR_EAS_NOT_SUPPORTED, "ERROR_EAS_NOT_SUPPORTED" },
{ ERROR_NOT_OWNER, "ERROR_NOT_OWNER" },
{ ERROR_TOO_MANY_POSTS, "ERROR_TOO_MANY_POSTS" },
{ ERROR_PARTIAL_COPY, "ERROR_PARTIAL_COPY" },
{ ERROR_MR_MID_NOT_FOUND, "ERROR_MR_MID_NOT_FOUND" },
{ ERROR_INVALID_ADDRESS, "ERROR_INVALID_ADDRESS" },
{ ERROR_ARITHMETIC_OVERFLOW, "ERROR_ARITHMETIC_OVERFLOW" },
{ ERROR_PIPE_CONNECTED, "ERROR_PIPE_CONNECTED" },
{ ERROR_PIPE_LISTENING, "ERROR_PIPE_LISTENING" },
{ ERROR_EA_ACCESS_DENIED, "ERROR_EA_ACCESS_DENIED" },
{ ERROR_OPERATION_ABORTED, "ERROR_OPERATION_ABORTED" },
{ ERROR_IO_INCOMPLETE, "ERROR_IO_INCOMPLETE" },
{ ERROR_IO_PENDING, "ERROR_IO_PENDING" },
{ ERROR_NOACCESS, "ERROR_NOACCESS" },
{ ERROR_SWAPERROR, "ERROR_SWAPERROR" },
{ ERROR_STACK_OVERFLOW, "ERROR_STACK_OVERFLOW" },
{ ERROR_INVALID_MESSAGE, "ERROR_INVALID_MESSAGE" },
{ ERROR_CAN_NOT_COMPLETE, "ERROR_CAN_NOT_COMPLETE" },
{ ERROR_INVALID_FLAGS, "ERROR_INVALID_FLAGS" },
{ ERROR_UNRECOGNIZED_VOLUME, "ERROR_UNRECOGNIZED_VOLUME" },
{ ERROR_FILE_INVALID, "ERROR_FILE_INVALID" },
{ ERROR_FULLSCREEN_MODE, "ERROR_FULLSCREEN_MODE" },
{ ERROR_NO_TOKEN, "ERROR_NO_TOKEN" },
{ ERROR_BADDB, "ERROR_BADDB" },
{ ERROR_BADKEY, "ERROR_BADKEY" },
{ ERROR_CANTOPEN, "ERROR_CANTOPEN" },
{ ERROR_CANTREAD, "ERROR_CANTREAD" },
{ ERROR_CANTWRITE, "ERROR_CANTWRITE" },
{ ERROR_REGISTRY_RECOVERED, "ERROR_REGISTRY_RECOVERED" },
{ ERROR_REGISTRY_CORRUPT, "ERROR_REGISTRY_CORRUPT" },
{ ERROR_REGISTRY_IO_FAILED, "ERROR_REGISTRY_IO_FAILED" },
{ ERROR_NOT_REGISTRY_FILE, "ERROR_NOT_REGISTRY_FILE" },
{ ERROR_KEY_DELETED, "ERROR_KEY_DELETED" },
{ ERROR_NO_LOG_SPACE, "ERROR_NO_LOG_SPACE" },
{ ERROR_KEY_HAS_CHILDREN, "ERROR_KEY_HAS_CHILDREN" },
{ ERROR_CHILD_MUST_BE_VOLATILE, "ERROR_CHILD_MUST_BE_VOLATILE" },
{ ERROR_NOTIFY_ENUM_DIR, "ERROR_NOTIFY_ENUM_DIR" },
{ ERROR_DEPENDENT_SERVICES_RUNNING, "ERROR_DEPENDENT_SERVICES_RUNNING" },
{ ERROR_INVALID_SERVICE_CONTROL, "ERROR_INVALID_SERVICE_CONTROL" },
{ ERROR_SERVICE_REQUEST_TIMEOUT, "ERROR_SERVICE_REQUEST_TIMEOUT" },
{ ERROR_SERVICE_NO_THREAD, "ERROR_SERVICE_NO_THREAD" },
{ ERROR_SERVICE_DATABASE_LOCKED, "ERROR_SERVICE_DATABASE_LOCKED" },
{ ERROR_SERVICE_ALREADY_RUNNING, "ERROR_SERVICE_ALREADY_RUNNING" },
{ ERROR_INVALID_SERVICE_ACCOUNT, "ERROR_INVALID_SERVICE_ACCOUNT" },
{ ERROR_SERVICE_DISABLED, "ERROR_SERVICE_DISABLED" },
{ ERROR_CIRCULAR_DEPENDENCY, "ERROR_CIRCULAR_DEPENDENCY" },
{ ERROR_SERVICE_DOES_NOT_EXIST, "ERROR_SERVICE_DOES_NOT_EXIST" },
{ ERROR_SERVICE_CANNOT_ACCEPT_CTRL, "ERROR_SERVICE_CANNOT_ACCEPT_CTRL" },
{ ERROR_SERVICE_NOT_ACTIVE, "ERROR_SERVICE_NOT_ACTIVE" },
{ ERROR_FAILED_SERVICE_CONTROLLER_CONNECT, "ERROR_FAILED_SERVICE_CONTROLLER_CONNECT" },
{ ERROR_EXCEPTION_IN_SERVICE, "ERROR_EXCEPTION_IN_SERVICE" },
{ ERROR_DATABASE_DOES_NOT_EXIST, "ERROR_DATABASE_DOES_NOT_EXIST" },
{ ERROR_SERVICE_SPECIFIC_ERROR, "ERROR_SERVICE_SPECIFIC_ERROR" },
{ ERROR_PROCESS_ABORTED, "ERROR_PROCESS_ABORTED" },
{ ERROR_SERVICE_DEPENDENCY_FAIL, "ERROR_SERVICE_DEPENDENCY_FAIL" },
{ ERROR_SERVICE_LOGON_FAILED, "ERROR_SERVICE_LOGON_FAILED" },
{ ERROR_SERVICE_START_HANG, "ERROR_SERVICE_START_HANG" },
{ ERROR_INVALID_SERVICE_LOCK, "ERROR_INVALID_SERVICE_LOCK" },
{ ERROR_SERVICE_MARKED_FOR_DELETE, "ERROR_SERVICE_MARKED_FOR_DELETE" },
{ ERROR_SERVICE_EXISTS, "ERROR_SERVICE_EXISTS" },
{ ERROR_ALREADY_RUNNING_LKG, "ERROR_ALREADY_RUNNING_LKG" },
{ ERROR_SERVICE_DEPENDENCY_DELETED, "ERROR_SERVICE_DEPENDENCY_DELETED" },
{ ERROR_BOOT_ALREADY_ACCEPTED, "ERROR_BOOT_ALREADY_ACCEPTED" },
{ ERROR_SERVICE_NEVER_STARTED, "ERROR_SERVICE_NEVER_STARTED" },
{ ERROR_DUPLICATE_SERVICE_NAME, "ERROR_DUPLICATE_SERVICE_NAME" },
#ifdef ERROR_DIFFERENT_SERVICE_ACCOUNT
{ ERROR_DIFFERENT_SERVICE_ACCOUNT, "ERROR_DIFFERENT_SERVICE_ACCOUNT" },
#endif
{ ERROR_END_OF_MEDIA, "ERROR_END_OF_MEDIA" },
{ ERROR_FILEMARK_DETECTED, "ERROR_FILEMARK_DETECTED" },
{ ERROR_BEGINNING_OF_MEDIA, "ERROR_BEGINNING_OF_MEDIA" },
{ ERROR_SETMARK_DETECTED, "ERROR_SETMARK_DETECTED" },
{ ERROR_NO_DATA_DETECTED, "ERROR_NO_DATA_DETECTED" },
{ ERROR_PARTITION_FAILURE, "ERROR_PARTITION_FAILURE" },
{ ERROR_INVALID_BLOCK_LENGTH, "ERROR_INVALID_BLOCK_LENGTH" },
{ ERROR_DEVICE_NOT_PARTITIONED, "ERROR_DEVICE_NOT_PARTITIONED" },
{ ERROR_UNABLE_TO_LOCK_MEDIA, "ERROR_UNABLE_TO_LOCK_MEDIA" },
{ ERROR_UNABLE_TO_UNLOAD_MEDIA, "ERROR_UNABLE_TO_UNLOAD_MEDIA" },
{ ERROR_MEDIA_CHANGED, "ERROR_MEDIA_CHANGED" },
{ ERROR_BUS_RESET, "ERROR_BUS_RESET" },
{ ERROR_NO_MEDIA_IN_DRIVE, "ERROR_NO_MEDIA_IN_DRIVE" },
{ ERROR_NO_UNICODE_TRANSLATION, "ERROR_NO_UNICODE_TRANSLATION" },
{ ERROR_DLL_INIT_FAILED, "ERROR_DLL_INIT_FAILED" },
{ ERROR_SHUTDOWN_IN_PROGRESS, "ERROR_SHUTDOWN_IN_PROGRESS" },
{ ERROR_NO_SHUTDOWN_IN_PROGRESS, "ERROR_NO_SHUTDOWN_IN_PROGRESS" },
{ ERROR_IO_DEVICE, "ERROR_IO_DEVICE" },
{ ERROR_SERIAL_NO_DEVICE, "ERROR_SERIAL_NO_DEVICE" },
{ ERROR_IRQ_BUSY, "ERROR_IRQ_BUSY" },
{ ERROR_MORE_WRITES, "ERROR_MORE_WRITES" },
{ ERROR_COUNTER_TIMEOUT, "ERROR_COUNTER_TIMEOUT" },
{ ERROR_FLOPPY_ID_MARK_NOT_FOUND, "ERROR_FLOPPY_ID_MARK_NOT_FOUND" },
{ ERROR_FLOPPY_WRONG_CYLINDER, "ERROR_FLOPPY_WRONG_CYLINDER" },
{ ERROR_FLOPPY_UNKNOWN_ERROR, "ERROR_FLOPPY_UNKNOWN_ERROR" },
{ ERROR_FLOPPY_BAD_REGISTERS, "ERROR_FLOPPY_BAD_REGISTERS" },
{ ERROR_DISK_RECALIBRATE_FAILED, "ERROR_DISK_RECALIBRATE_FAILED" },
{ ERROR_DISK_OPERATION_FAILED, "ERROR_DISK_OPERATION_FAILED" },
{ ERROR_DISK_RESET_FAILED, "ERROR_DISK_RESET_FAILED" },
{ ERROR_EOM_OVERFLOW, "ERROR_EOM_OVERFLOW" },
{ ERROR_NOT_ENOUGH_SERVER_MEMORY, "ERROR_NOT_ENOUGH_SERVER_MEMORY" },
{ ERROR_POSSIBLE_DEADLOCK, "ERROR_POSSIBLE_DEADLOCK" },
{ ERROR_MAPPED_ALIGNMENT, "ERROR_MAPPED_ALIGNMENT" },
{ ERROR_SET_POWER_STATE_VETOED, "ERROR_SET_POWER_STATE_VETOED" },
{ ERROR_SET_POWER_STATE_FAILED, "ERROR_SET_POWER_STATE_FAILED" },
#ifdef ERROR_TOO_MANY_LINKS
{ ERROR_TOO_MANY_LINKS, "ERROR_TOO_MANY_LINKS" },
#endif
{ ERROR_OLD_WIN_VERSION, "ERROR_OLD_WIN_VERSION" },
{ ERROR_APP_WRONG_OS, "ERROR_APP_WRONG_OS" },
{ ERROR_SINGLE_INSTANCE_APP, "ERROR_SINGLE_INSTANCE_APP" },
{ ERROR_RMODE_APP, "ERROR_RMODE_APP" },
{ ERROR_INVALID_DLL, "ERROR_INVALID_DLL" },
{ ERROR_NO_ASSOCIATION, "ERROR_NO_ASSOCIATION" },
{ ERROR_DDE_FAIL, "ERROR_DDE_FAIL" },
{ ERROR_DLL_NOT_FOUND, "ERROR_DLL_NOT_FOUND" },
{ ERROR_BAD_USERNAME, "ERROR_BAD_USERNAME" },
{ ERROR_NOT_CONNECTED, "ERROR_NOT_CONNECTED" },
{ ERROR_OPEN_FILES, "ERROR_OPEN_FILES" },
{ ERROR_ACTIVE_CONNECTIONS, "ERROR_ACTIVE_CONNECTIONS" },
{ ERROR_DEVICE_IN_USE, "ERROR_DEVICE_IN_USE" },
{ ERROR_BAD_DEVICE, "ERROR_BAD_DEVICE" },
{ ERROR_CONNECTION_UNAVAIL, "ERROR_CONNECTION_UNAVAIL" },
{ ERROR_DEVICE_ALREADY_REMEMBERED, "ERROR_DEVICE_ALREADY_REMEMBERED" },
{ ERROR_NO_NET_OR_BAD_PATH, "ERROR_NO_NET_OR_BAD_PATH" },
{ ERROR_BAD_PROVIDER, "ERROR_BAD_PROVIDER" },
{ ERROR_CANNOT_OPEN_PROFILE, "ERROR_CANNOT_OPEN_PROFILE" },
{ ERROR_BAD_PROFILE, "ERROR_BAD_PROFILE" },
{ ERROR_NOT_CONTAINER, "ERROR_NOT_CONTAINER" },
{ ERROR_EXTENDED_ERROR, "ERROR_EXTENDED_ERROR" },
{ ERROR_INVALID_GROUPNAME, "ERROR_INVALID_GROUPNAME" },
{ ERROR_INVALID_COMPUTERNAME, "ERROR_INVALID_COMPUTERNAME" },
{ ERROR_INVALID_EVENTNAME, "ERROR_INVALID_EVENTNAME" },
{ ERROR_INVALID_DOMAINNAME, "ERROR_INVALID_DOMAINNAME" },
{ ERROR_INVALID_SERVICENAME, "ERROR_INVALID_SERVICENAME" },
{ ERROR_INVALID_NETNAME, "ERROR_INVALID_NETNAME" },
{ ERROR_INVALID_SHARENAME, "ERROR_INVALID_SHARENAME" },
{ ERROR_INVALID_PASSWORDNAME, "ERROR_INVALID_PASSWORDNAME" },
{ ERROR_INVALID_MESSAGENAME, "ERROR_INVALID_MESSAGENAME" },
{ ERROR_INVALID_MESSAGEDEST, "ERROR_INVALID_MESSAGEDEST" },
{ ERROR_SESSION_CREDENTIAL_CONFLICT, "ERROR_SESSION_CREDENTIAL_CONFLICT" },
{ ERROR_REMOTE_SESSION_LIMIT_EXCEEDED, "ERROR_REMOTE_SESSION_LIMIT_EXCEEDED" },
{ ERROR_DUP_DOMAINNAME, "ERROR_DUP_DOMAINNAME" },
{ ERROR_NO_NETWORK, "ERROR_NO_NETWORK" },
{ ERROR_CANCELLED, "ERROR_CANCELLED" },
{ ERROR_USER_MAPPED_FILE, "ERROR_USER_MAPPED_FILE" },
{ ERROR_CONNECTION_REFUSED, "ERROR_CONNECTION_REFUSED" },
{ ERROR_GRACEFUL_DISCONNECT, "ERROR_GRACEFUL_DISCONNECT" },
{ ERROR_ADDRESS_ALREADY_ASSOCIATED, "ERROR_ADDRESS_ALREADY_ASSOCIATED" },
{ ERROR_ADDRESS_NOT_ASSOCIATED, "ERROR_ADDRESS_NOT_ASSOCIATED" },
{ ERROR_CONNECTION_INVALID, "ERROR_CONNECTION_INVALID" },
{ ERROR_CONNECTION_ACTIVE, "ERROR_CONNECTION_ACTIVE" },
{ ERROR_NETWORK_UNREACHABLE, "ERROR_NETWORK_UNREACHABLE" },
{ ERROR_HOST_UNREACHABLE, "ERROR_HOST_UNREACHABLE" },
{ ERROR_PROTOCOL_UNREACHABLE, "ERROR_PROTOCOL_UNREACHABLE" },
{ ERROR_PORT_UNREACHABLE, "ERROR_PORT_UNREACHABLE" },
{ ERROR_REQUEST_ABORTED, "ERROR_REQUEST_ABORTED" },
{ ERROR_CONNECTION_ABORTED, "ERROR_CONNECTION_ABORTED" },
{ ERROR_RETRY, "ERROR_RETRY" },
{ ERROR_CONNECTION_COUNT_LIMIT, "ERROR_CONNECTION_COUNT_LIMIT" },
{ ERROR_LOGIN_TIME_RESTRICTION, "ERROR_LOGIN_TIME_RESTRICTION" },
{ ERROR_LOGIN_WKSTA_RESTRICTION, "ERROR_LOGIN_WKSTA_RESTRICTION" },
{ ERROR_INCORRECT_ADDRESS, "ERROR_INCORRECT_ADDRESS" },
{ ERROR_ALREADY_REGISTERED, "ERROR_ALREADY_REGISTERED" },
{ ERROR_SERVICE_NOT_FOUND, "ERROR_SERVICE_NOT_FOUND" },
{ ERROR_NOT_AUTHENTICATED, "ERROR_NOT_AUTHENTICATED" },
{ ERROR_NOT_LOGGED_ON, "ERROR_NOT_LOGGED_ON" },
{ ERROR_CONTINUE, "ERROR_CONTINUE" },
{ ERROR_ALREADY_INITIALIZED, "ERROR_ALREADY_INITIALIZED" },
{ ERROR_NO_MORE_DEVICES, "ERROR_NO_MORE_DEVICES" },
{ ERROR_NOT_ALL_ASSIGNED, "ERROR_NOT_ALL_ASSIGNED" },
{ ERROR_SOME_NOT_MAPPED, "ERROR_SOME_NOT_MAPPED" },
{ ERROR_NO_QUOTAS_FOR_ACCOUNT, "ERROR_NO_QUOTAS_FOR_ACCOUNT" },
{ ERROR_LOCAL_USER_SESSION_KEY, "ERROR_LOCAL_USER_SESSION_KEY" },
{ ERROR_NULL_LM_PASSWORD, "ERROR_NULL_LM_PASSWORD" },
{ ERROR_UNKNOWN_REVISION, "ERROR_UNKNOWN_REVISION" },
{ ERROR_REVISION_MISMATCH, "ERROR_REVISION_MISMATCH" },
{ ERROR_INVALID_OWNER, "ERROR_INVALID_OWNER" },
{ ERROR_INVALID_PRIMARY_GROUP, "ERROR_INVALID_PRIMARY_GROUP" },
{ ERROR_NO_IMPERSONATION_TOKEN, "ERROR_NO_IMPERSONATION_TOKEN" },
{ ERROR_CANT_DISABLE_MANDATORY, "ERROR_CANT_DISABLE_MANDATORY" },
{ ERROR_NO_LOGON_SERVERS, "ERROR_NO_LOGON_SERVERS" },
{ ERROR_NO_SUCH_LOGON_SESSION, "ERROR_NO_SUCH_LOGON_SESSION" },
{ ERROR_NO_SUCH_PRIVILEGE, "ERROR_NO_SUCH_PRIVILEGE" },
{ ERROR_PRIVILEGE_NOT_HELD, "ERROR_PRIVILEGE_NOT_HELD" },
{ ERROR_INVALID_ACCOUNT_NAME, "ERROR_INVALID_ACCOUNT_NAME" },
{ ERROR_USER_EXISTS, "ERROR_USER_EXISTS" },
{ ERROR_NO_SUCH_USER, "ERROR_NO_SUCH_USER" },
{ ERROR_GROUP_EXISTS, "ERROR_GROUP_EXISTS" },
{ ERROR_NO_SUCH_GROUP, "ERROR_NO_SUCH_GROUP" },
{ ERROR_MEMBER_IN_GROUP, "ERROR_MEMBER_IN_GROUP" },
{ ERROR_MEMBER_NOT_IN_GROUP, "ERROR_MEMBER_NOT_IN_GROUP" },
{ ERROR_LAST_ADMIN, "ERROR_LAST_ADMIN" },
{ ERROR_WRONG_PASSWORD, "ERROR_WRONG_PASSWORD" },
{ ERROR_ILL_FORMED_PASSWORD, "ERROR_ILL_FORMED_PASSWORD" },
{ ERROR_PASSWORD_RESTRICTION, "ERROR_PASSWORD_RESTRICTION" },
{ ERROR_LOGON_FAILURE, "ERROR_LOGON_FAILURE" },
{ ERROR_ACCOUNT_RESTRICTION, "ERROR_ACCOUNT_RESTRICTION" },
{ ERROR_INVALID_LOGON_HOURS, "ERROR_INVALID_LOGON_HOURS" },
{ ERROR_INVALID_WORKSTATION, "ERROR_INVALID_WORKSTATION" },
{ ERROR_PASSWORD_EXPIRED, "ERROR_PASSWORD_EXPIRED" },
{ ERROR_ACCOUNT_DISABLED, "ERROR_ACCOUNT_DISABLED" },
{ ERROR_NONE_MAPPED, "ERROR_NONE_MAPPED" },
{ ERROR_TOO_MANY_LUIDS_REQUESTED, "ERROR_TOO_MANY_LUIDS_REQUESTED" },
{ ERROR_LUIDS_EXHAUSTED, "ERROR_LUIDS_EXHAUSTED" },
{ ERROR_INVALID_SUB_AUTHORITY, "ERROR_INVALID_SUB_AUTHORITY" },
{ ERROR_INVALID_ACL, "ERROR_INVALID_ACL" },
{ ERROR_INVALID_SID, "ERROR_INVALID_SID" },
{ ERROR_INVALID_SECURITY_DESCR, "ERROR_INVALID_SECURITY_DESCR" },
{ ERROR_BAD_INHERITANCE_ACL, "ERROR_BAD_INHERITANCE_ACL" },
{ ERROR_SERVER_DISABLED, "ERROR_SERVER_DISABLED" },
{ ERROR_SERVER_NOT_DISABLED, "ERROR_SERVER_NOT_DISABLED" },
{ ERROR_INVALID_ID_AUTHORITY, "ERROR_INVALID_ID_AUTHORITY" },
{ ERROR_ALLOTTED_SPACE_EXCEEDED, "ERROR_ALLOTTED_SPACE_EXCEEDED" },
{ ERROR_INVALID_GROUP_ATTRIBUTES, "ERROR_INVALID_GROUP_ATTRIBUTES" },
{ ERROR_BAD_IMPERSONATION_LEVEL, "ERROR_BAD_IMPERSONATION_LEVEL" },
{ ERROR_CANT_OPEN_ANONYMOUS, "ERROR_CANT_OPEN_ANONYMOUS" },
{ ERROR_BAD_VALIDATION_CLASS, "ERROR_BAD_VALIDATION_CLASS" },
{ ERROR_BAD_TOKEN_TYPE, "ERROR_BAD_TOKEN_TYPE" },
{ ERROR_NO_SECURITY_ON_OBJECT, "ERROR_NO_SECURITY_ON_OBJECT" },
{ ERROR_CANT_ACCESS_DOMAIN_INFO, "ERROR_CANT_ACCESS_DOMAIN_INFO" },
{ ERROR_INVALID_SERVER_STATE, "ERROR_INVALID_SERVER_STATE" },
{ ERROR_INVALID_DOMAIN_STATE, "ERROR_INVALID_DOMAIN_STATE" },
{ ERROR_INVALID_DOMAIN_ROLE, "ERROR_INVALID_DOMAIN_ROLE" },
{ ERROR_NO_SUCH_DOMAIN, "ERROR_NO_SUCH_DOMAIN" },
{ ERROR_DOMAIN_EXISTS, "ERROR_DOMAIN_EXISTS" },
{ ERROR_DOMAIN_LIMIT_EXCEEDED, "ERROR_DOMAIN_LIMIT_EXCEEDED" },
{ ERROR_INTERNAL_DB_CORRUPTION, "ERROR_INTERNAL_DB_CORRUPTION" },
{ ERROR_INTERNAL_ERROR, "ERROR_INTERNAL_ERROR" },
{ ERROR_GENERIC_NOT_MAPPED, "ERROR_GENERIC_NOT_MAPPED" },
{ ERROR_BAD_DESCRIPTOR_FORMAT, "ERROR_BAD_DESCRIPTOR_FORMAT" },
{ ERROR_NOT_LOGON_PROCESS, "ERROR_NOT_LOGON_PROCESS" },
{ ERROR_LOGON_SESSION_EXISTS, "ERROR_LOGON_SESSION_EXISTS" },
{ ERROR_NO_SUCH_PACKAGE, "ERROR_NO_SUCH_PACKAGE" },
{ ERROR_BAD_LOGON_SESSION_STATE, "ERROR_BAD_LOGON_SESSION_STATE" },
{ ERROR_LOGON_SESSION_COLLISION, "ERROR_LOGON_SESSION_COLLISION" },
{ ERROR_INVALID_LOGON_TYPE, "ERROR_INVALID_LOGON_TYPE" },
{ ERROR_CANNOT_IMPERSONATE, "ERROR_CANNOT_IMPERSONATE" },
{ ERROR_RXACT_INVALID_STATE, "ERROR_RXACT_INVALID_STATE" },
{ ERROR_RXACT_COMMIT_FAILURE, "ERROR_RXACT_COMMIT_FAILURE" },
{ ERROR_SPECIAL_ACCOUNT, "ERROR_SPECIAL_ACCOUNT" },
{ ERROR_SPECIAL_GROUP, "ERROR_SPECIAL_GROUP" },
{ ERROR_SPECIAL_USER, "ERROR_SPECIAL_USER" },
{ ERROR_MEMBERS_PRIMARY_GROUP, "ERROR_MEMBERS_PRIMARY_GROUP" },
{ ERROR_TOKEN_ALREADY_IN_USE, "ERROR_TOKEN_ALREADY_IN_USE" },
{ ERROR_NO_SUCH_ALIAS, "ERROR_NO_SUCH_ALIAS" },
{ ERROR_MEMBER_NOT_IN_ALIAS, "ERROR_MEMBER_NOT_IN_ALIAS" },
{ ERROR_MEMBER_IN_ALIAS, "ERROR_MEMBER_IN_ALIAS" },
{ ERROR_ALIAS_EXISTS, "ERROR_ALIAS_EXISTS" },
{ ERROR_LOGON_NOT_GRANTED, "ERROR_LOGON_NOT_GRANTED" },
{ ERROR_TOO_MANY_SECRETS, "ERROR_TOO_MANY_SECRETS" },
{ ERROR_SECRET_TOO_LONG, "ERROR_SECRET_TOO_LONG" },
{ ERROR_INTERNAL_DB_ERROR, "ERROR_INTERNAL_DB_ERROR" },
{ ERROR_TOO_MANY_CONTEXT_IDS, "ERROR_TOO_MANY_CONTEXT_IDS" },
{ ERROR_LOGON_TYPE_NOT_GRANTED, "ERROR_LOGON_TYPE_NOT_GRANTED" },
{ ERROR_NT_CROSS_ENCRYPTION_REQUIRED, "ERROR_NT_CROSS_ENCRYPTION_REQUIRED" },
{ ERROR_NO_SUCH_MEMBER, "ERROR_NO_SUCH_MEMBER" },
{ ERROR_INVALID_MEMBER, "ERROR_INVALID_MEMBER" },
{ ERROR_TOO_MANY_SIDS, "ERROR_TOO_MANY_SIDS" },
{ ERROR_LM_CROSS_ENCRYPTION_REQUIRED, "ERROR_LM_CROSS_ENCRYPTION_REQUIRED" },
{ ERROR_NO_INHERITANCE, "ERROR_NO_INHERITANCE" },
{ ERROR_FILE_CORRUPT, "ERROR_FILE_CORRUPT" },
{ ERROR_DISK_CORRUPT, "ERROR_DISK_CORRUPT" },
{ ERROR_NO_USER_SESSION_KEY, "ERROR_NO_USER_SESSION_KEY" },
#ifdef ERROR_LICENSE_QUOTA_EXCEEDED
{ ERROR_LICENSE_QUOTA_EXCEEDED, "ERROR_LICENSE_QUOTA_EXCEEDED" },
#endif
{ ERROR_INVALID_WINDOW_HANDLE, "ERROR_INVALID_WINDOW_HANDLE" },
{ ERROR_INVALID_MENU_HANDLE, "ERROR_INVALID_MENU_HANDLE" },
{ ERROR_INVALID_CURSOR_HANDLE, "ERROR_INVALID_CURSOR_HANDLE" },
{ ERROR_INVALID_ACCEL_HANDLE, "ERROR_INVALID_ACCEL_HANDLE" },
{ ERROR_INVALID_HOOK_HANDLE, "ERROR_INVALID_HOOK_HANDLE" },
{ ERROR_INVALID_DWP_HANDLE, "ERROR_INVALID_DWP_HANDLE" },
{ ERROR_TLW_WITH_WSCHILD, "ERROR_TLW_WITH_WSCHILD" },
{ ERROR_CANNOT_FIND_WND_CLASS, "ERROR_CANNOT_FIND_WND_CLASS" },
{ ERROR_WINDOW_OF_OTHER_THREAD, "ERROR_WINDOW_OF_OTHER_THREAD" },
{ ERROR_HOTKEY_ALREADY_REGISTERED, "ERROR_HOTKEY_ALREADY_REGISTERED" },
{ ERROR_CLASS_ALREADY_EXISTS, "ERROR_CLASS_ALREADY_EXISTS" },
{ ERROR_CLASS_DOES_NOT_EXIST, "ERROR_CLASS_DOES_NOT_EXIST" },
{ ERROR_CLASS_HAS_WINDOWS, "ERROR_CLASS_HAS_WINDOWS" },
{ ERROR_INVALID_INDEX, "ERROR_INVALID_INDEX" },
{ ERROR_INVALID_ICON_HANDLE, "ERROR_INVALID_ICON_HANDLE" },
{ ERROR_PRIVATE_DIALOG_INDEX, "ERROR_PRIVATE_DIALOG_INDEX" },
{ ERROR_LISTBOX_ID_NOT_FOUND, "ERROR_LISTBOX_ID_NOT_FOUND" },
{ ERROR_NO_WILDCARD_CHARACTERS, "ERROR_NO_WILDCARD_CHARACTERS" },
{ ERROR_CLIPBOARD_NOT_OPEN, "ERROR_CLIPBOARD_NOT_OPEN" },
{ ERROR_HOTKEY_NOT_REGISTERED, "ERROR_HOTKEY_NOT_REGISTERED" },
{ ERROR_WINDOW_NOT_DIALOG, "ERROR_WINDOW_NOT_DIALOG" },
{ ERROR_CONTROL_ID_NOT_FOUND, "ERROR_CONTROL_ID_NOT_FOUND" },
{ ERROR_INVALID_COMBOBOX_MESSAGE, "ERROR_INVALID_COMBOBOX_MESSAGE" },
{ ERROR_WINDOW_NOT_COMBOBOX, "ERROR_WINDOW_NOT_COMBOBOX" },
{ ERROR_INVALID_EDIT_HEIGHT, "ERROR_INVALID_EDIT_HEIGHT" },
{ ERROR_DC_NOT_FOUND, "ERROR_DC_NOT_FOUND" },
{ ERROR_INVALID_HOOK_FILTER, "ERROR_INVALID_HOOK_FILTER" },
{ ERROR_INVALID_FILTER_PROC, "ERROR_INVALID_FILTER_PROC" },
{ ERROR_HOOK_NEEDS_HMOD, "ERROR_HOOK_NEEDS_HMOD" },
{ ERROR_GLOBAL_ONLY_HOOK, "ERROR_GLOBAL_ONLY_HOOK" },
{ ERROR_JOURNAL_HOOK_SET, "ERROR_JOURNAL_HOOK_SET" },
{ ERROR_HOOK_NOT_INSTALLED, "ERROR_HOOK_NOT_INSTALLED" },
{ ERROR_INVALID_LB_MESSAGE, "ERROR_INVALID_LB_MESSAGE" },
{ ERROR_SETCOUNT_ON_BAD_LB, "ERROR_SETCOUNT_ON_BAD_LB" },
{ ERROR_LB_WITHOUT_TABSTOPS, "ERROR_LB_WITHOUT_TABSTOPS" },
{ ERROR_DESTROY_OBJECT_OF_OTHER_THREAD, "ERROR_DESTROY_OBJECT_OF_OTHER_THREAD" },
{ ERROR_CHILD_WINDOW_MENU, "ERROR_CHILD_WINDOW_MENU" },
{ ERROR_NO_SYSTEM_MENU, "ERROR_NO_SYSTEM_MENU" },
{ ERROR_INVALID_MSGBOX_STYLE, "ERROR_INVALID_MSGBOX_STYLE" },
{ ERROR_INVALID_SPI_VALUE, "ERROR_INVALID_SPI_VALUE" },
{ ERROR_SCREEN_ALREADY_LOCKED, "ERROR_SCREEN_ALREADY_LOCKED" },
{ ERROR_HWNDS_HAVE_DIFF_PARENT, "ERROR_HWNDS_HAVE_DIFF_PARENT" },
{ ERROR_NOT_CHILD_WINDOW, "ERROR_NOT_CHILD_WINDOW" },
{ ERROR_INVALID_GW_COMMAND, "ERROR_INVALID_GW_COMMAND" },
{ ERROR_INVALID_THREAD_ID, "ERROR_INVALID_THREAD_ID" },
{ ERROR_NON_MDICHILD_WINDOW, "ERROR_NON_MDICHILD_WINDOW" },
{ ERROR_POPUP_ALREADY_ACTIVE, "ERROR_POPUP_ALREADY_ACTIVE" },
{ ERROR_NO_SCROLLBARS, "ERROR_NO_SCROLLBARS" },
{ ERROR_INVALID_SCROLLBAR_RANGE, "ERROR_INVALID_SCROLLBAR_RANGE" },
{ ERROR_INVALID_SHOWWIN_COMMAND, "ERROR_INVALID_SHOWWIN_COMMAND" },
#ifdef ERROR_NO_SYSTEM_RESOURCES
{ ERROR_NO_SYSTEM_RESOURCES, "ERROR_NO_SYSTEM_RESOURCES" },
#endif
#ifdef ERROR_NONPAGED_SYSTEM_RESOURCES
{ ERROR_NONPAGED_SYSTEM_RESOURCES, "ERROR_NONPAGED_SYSTEM_RESOURCES" },
#endif
#ifdef ERROR_PAGED_SYSTEM_RESOURCES
{ ERROR_PAGED_SYSTEM_RESOURCES, "ERROR_PAGED_SYSTEM_RESOURCES" },
#endif
#ifdef ERROR_WORKING_SET_QUOTA
{ ERROR_WORKING_SET_QUOTA, "ERROR_WORKING_SET_QUOTA" },
#endif
#ifdef ERROR_PAGEFILE_QUOTA
{ ERROR_PAGEFILE_QUOTA, "ERROR_PAGEFILE_QUOTA" },
#endif
#ifdef ERROR_COMMITMENT_LIMIT
{ ERROR_COMMITMENT_LIMIT, "ERROR_COMMITMENT_LIMIT" },
#endif
#ifdef ERROR_MENU_ITEM_NOT_FOUND
{ ERROR_MENU_ITEM_NOT_FOUND, "ERROR_MENU_ITEM_NOT_FOUND" },
#endif
#ifdef ERROR_INVALID_KEYBOARD_HANDLE
{ ERROR_INVALID_KEYBOARD_HANDLE, "ERROR_INVALID_KEYBOARD_HANDLE" },
#endif
#ifdef ERROR_HOOK_TYPE_NOT_ALLOWED
{ ERROR_HOOK_TYPE_NOT_ALLOWED, "ERROR_HOOK_TYPE_NOT_ALLOWED" },
#endif
#ifdef ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION
{ ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION, "ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION" },
#endif
#ifdef ERROR_TIMEOUT
{ ERROR_TIMEOUT, "ERROR_TIMEOUT" },
#endif
{ ERROR_EVENTLOG_FILE_CORRUPT, "ERROR_EVENTLOG_FILE_CORRUPT" },
{ ERROR_EVENTLOG_CANT_START, "ERROR_EVENTLOG_CANT_START" },
{ ERROR_LOG_FILE_FULL, "ERROR_LOG_FILE_FULL" },
{ ERROR_EVENTLOG_FILE_CHANGED, "ERROR_EVENTLOG_FILE_CHANGED" },
{ RPC_S_INVALID_STRING_BINDING, "RPC_S_INVALID_STRING_BINDING" },
{ RPC_S_WRONG_KIND_OF_BINDING, "RPC_S_WRONG_KIND_OF_BINDING" },
{ RPC_S_INVALID_BINDING, "RPC_S_INVALID_BINDING" },
{ RPC_S_PROTSEQ_NOT_SUPPORTED, "RPC_S_PROTSEQ_NOT_SUPPORTED" },
{ RPC_S_INVALID_RPC_PROTSEQ, "RPC_S_INVALID_RPC_PROTSEQ" },
{ RPC_S_INVALID_STRING_UUID, "RPC_S_INVALID_STRING_UUID" },
{ RPC_S_INVALID_ENDPOINT_FORMAT, "RPC_S_INVALID_ENDPOINT_FORMAT" },
{ RPC_S_INVALID_NET_ADDR, "RPC_S_INVALID_NET_ADDR" },
{ RPC_S_NO_ENDPOINT_FOUND, "RPC_S_NO_ENDPOINT_FOUND" },
{ RPC_S_INVALID_TIMEOUT, "RPC_S_INVALID_TIMEOUT" },
{ RPC_S_OBJECT_NOT_FOUND, "RPC_S_OBJECT_NOT_FOUND" },
{ RPC_S_ALREADY_REGISTERED, "RPC_S_ALREADY_REGISTERED" },
{ RPC_S_TYPE_ALREADY_REGISTERED, "RPC_S_TYPE_ALREADY_REGISTERED" },
{ RPC_S_ALREADY_LISTENING, "RPC_S_ALREADY_LISTENING" },
{ RPC_S_NO_PROTSEQS_REGISTERED, "RPC_S_NO_PROTSEQS_REGISTERED" },
{ RPC_S_NOT_LISTENING, "RPC_S_NOT_LISTENING" },
{ RPC_S_UNKNOWN_MGR_TYPE, "RPC_S_UNKNOWN_MGR_TYPE" },
{ RPC_S_UNKNOWN_IF, "RPC_S_UNKNOWN_IF" },
{ RPC_S_NO_BINDINGS, "RPC_S_NO_BINDINGS" },
{ RPC_S_NO_PROTSEQS, "RPC_S_NO_PROTSEQS" },
{ RPC_S_CANT_CREATE_ENDPOINT, "RPC_S_CANT_CREATE_ENDPOINT" },
{ RPC_S_OUT_OF_RESOURCES, "RPC_S_OUT_OF_RESOURCES" },
{ RPC_S_SERVER_UNAVAILABLE, "RPC_S_SERVER_UNAVAILABLE" },
{ RPC_S_SERVER_TOO_BUSY, "RPC_S_SERVER_TOO_BUSY" },
{ RPC_S_INVALID_NETWORK_OPTIONS, "RPC_S_INVALID_NETWORK_OPTIONS" },
{ RPC_S_NO_CALL_ACTIVE, "RPC_S_NO_CALL_ACTIVE" },
{ RPC_S_CALL_FAILED, "RPC_S_CALL_FAILED" },
{ RPC_S_CALL_FAILED_DNE, "RPC_S_CALL_FAILED_DNE" },
{ RPC_S_PROTOCOL_ERROR, "RPC_S_PROTOCOL_ERROR" },
{ RPC_S_UNSUPPORTED_TRANS_SYN, "RPC_S_UNSUPPORTED_TRANS_SYN" },
{ RPC_S_UNSUPPORTED_TYPE, "RPC_S_UNSUPPORTED_TYPE" },
{ RPC_S_INVALID_TAG, "RPC_S_INVALID_TAG" },
{ RPC_S_INVALID_BOUND, "RPC_S_INVALID_BOUND" },
{ RPC_S_NO_ENTRY_NAME, "RPC_S_NO_ENTRY_NAME" },
{ RPC_S_INVALID_NAME_SYNTAX, "RPC_S_INVALID_NAME_SYNTAX" },
{ RPC_S_UNSUPPORTED_NAME_SYNTAX, "RPC_S_UNSUPPORTED_NAME_SYNTAX" },
{ RPC_S_UUID_NO_ADDRESS, "RPC_S_UUID_NO_ADDRESS" },
{ RPC_S_DUPLICATE_ENDPOINT, "RPC_S_DUPLICATE_ENDPOINT" },
{ RPC_S_UNKNOWN_AUTHN_TYPE, "RPC_S_UNKNOWN_AUTHN_TYPE" },
{ RPC_S_MAX_CALLS_TOO_SMALL, "RPC_S_MAX_CALLS_TOO_SMALL" },
{ RPC_S_STRING_TOO_LONG, "RPC_S_STRING_TOO_LONG" },
{ RPC_S_PROTSEQ_NOT_FOUND, "RPC_S_PROTSEQ_NOT_FOUND" },
{ RPC_S_PROCNUM_OUT_OF_RANGE, "RPC_S_PROCNUM_OUT_OF_RANGE" },
{ RPC_S_BINDING_HAS_NO_AUTH, "RPC_S_BINDING_HAS_NO_AUTH" },
{ RPC_S_UNKNOWN_AUTHN_SERVICE, "RPC_S_UNKNOWN_AUTHN_SERVICE" },
{ RPC_S_UNKNOWN_AUTHN_LEVEL, "RPC_S_UNKNOWN_AUTHN_LEVEL" },
{ RPC_S_INVALID_AUTH_IDENTITY, "RPC_S_INVALID_AUTH_IDENTITY" },
{ RPC_S_UNKNOWN_AUTHZ_SERVICE, "RPC_S_UNKNOWN_AUTHZ_SERVICE" },
{ EPT_S_INVALID_ENTRY, "EPT_S_INVALID_ENTRY" },
{ EPT_S_CANT_PERFORM_OP, "EPT_S_CANT_PERFORM_OP" },
{ EPT_S_NOT_REGISTERED, "EPT_S_NOT_REGISTERED" },
{ RPC_S_NOTHING_TO_EXPORT, "RPC_S_NOTHING_TO_EXPORT" },
{ RPC_S_INCOMPLETE_NAME, "RPC_S_INCOMPLETE_NAME" },
{ RPC_S_INVALID_VERS_OPTION, "RPC_S_INVALID_VERS_OPTION" },
{ RPC_S_NO_MORE_MEMBERS, "RPC_S_NO_MORE_MEMBERS" },
{ RPC_S_NOT_ALL_OBJS_UNEXPORTED, "RPC_S_NOT_ALL_OBJS_UNEXPORTED" },
{ RPC_S_INTERFACE_NOT_FOUND, "RPC_S_INTERFACE_NOT_FOUND" },
{ RPC_S_ENTRY_ALREADY_EXISTS, "RPC_S_ENTRY_ALREADY_EXISTS" },
{ RPC_S_ENTRY_NOT_FOUND, "RPC_S_ENTRY_NOT_FOUND" },
{ RPC_S_NAME_SERVICE_UNAVAILABLE, "RPC_S_NAME_SERVICE_UNAVAILABLE" },
{ RPC_S_INVALID_NAF_ID, "RPC_S_INVALID_NAF_ID" },
{ RPC_S_CANNOT_SUPPORT, "RPC_S_CANNOT_SUPPORT" },
{ RPC_S_NO_CONTEXT_AVAILABLE, "RPC_S_NO_CONTEXT_AVAILABLE" },
{ RPC_S_INTERNAL_ERROR, "RPC_S_INTERNAL_ERROR" },
{ RPC_S_ZERO_DIVIDE, "RPC_S_ZERO_DIVIDE" },
{ RPC_S_ADDRESS_ERROR, "RPC_S_ADDRESS_ERROR" },
{ RPC_S_FP_DIV_ZERO, "RPC_S_FP_DIV_ZERO" },
{ RPC_S_FP_UNDERFLOW, "RPC_S_FP_UNDERFLOW" },
{ RPC_S_FP_OVERFLOW, "RPC_S_FP_OVERFLOW" },
{ RPC_X_NO_MORE_ENTRIES, "RPC_X_NO_MORE_ENTRIES" },
{ RPC_X_SS_CHAR_TRANS_OPEN_FAIL, "RPC_X_SS_CHAR_TRANS_OPEN_FAIL" },
{ RPC_X_SS_CHAR_TRANS_SHORT_FILE, "RPC_X_SS_CHAR_TRANS_SHORT_FILE" },
{ RPC_X_SS_IN_NULL_CONTEXT, "RPC_X_SS_IN_NULL_CONTEXT" },
{ RPC_X_SS_CONTEXT_DAMAGED, "RPC_X_SS_CONTEXT_DAMAGED" },
{ RPC_X_SS_HANDLES_MISMATCH, "RPC_X_SS_HANDLES_MISMATCH" },
{ RPC_X_SS_CANNOT_GET_CALL_HANDLE, "RPC_X_SS_CANNOT_GET_CALL_HANDLE" },
{ RPC_X_NULL_REF_POINTER, "RPC_X_NULL_REF_POINTER" },
{ RPC_X_ENUM_VALUE_OUT_OF_RANGE, "RPC_X_ENUM_VALUE_OUT_OF_RANGE" },
{ RPC_X_BYTE_COUNT_TOO_SMALL, "RPC_X_BYTE_COUNT_TOO_SMALL" },
{ RPC_X_BAD_STUB_DATA, "RPC_X_BAD_STUB_DATA" },
{ ERROR_INVALID_USER_BUFFER, "ERROR_INVALID_USER_BUFFER" },
{ ERROR_UNRECOGNIZED_MEDIA, "ERROR_UNRECOGNIZED_MEDIA" },
{ ERROR_NO_TRUST_LSA_SECRET, "ERROR_NO_TRUST_LSA_SECRET" },
{ ERROR_NO_TRUST_SAM_ACCOUNT, "ERROR_NO_TRUST_SAM_ACCOUNT" },
{ ERROR_TRUSTED_DOMAIN_FAILURE, "ERROR_TRUSTED_DOMAIN_FAILURE" },
{ ERROR_TRUSTED_RELATIONSHIP_FAILURE, "ERROR_TRUSTED_RELATIONSHIP_FAILURE" },
{ ERROR_TRUST_FAILURE, "ERROR_TRUST_FAILURE" },
{ RPC_S_CALL_IN_PROGRESS, "RPC_S_CALL_IN_PROGRESS" },
{ ERROR_NETLOGON_NOT_STARTED, "ERROR_NETLOGON_NOT_STARTED" },
{ ERROR_ACCOUNT_EXPIRED, "ERROR_ACCOUNT_EXPIRED" },
{ ERROR_REDIRECTOR_HAS_OPEN_HANDLES, "ERROR_REDIRECTOR_HAS_OPEN_HANDLES" },
{ ERROR_PRINTER_DRIVER_ALREADY_INSTALLED, "ERROR_PRINTER_DRIVER_ALREADY_INSTALLED" },
{ ERROR_UNKNOWN_PORT, "ERROR_UNKNOWN_PORT" },
{ ERROR_UNKNOWN_PRINTER_DRIVER, "ERROR_UNKNOWN_PRINTER_DRIVER" },
{ ERROR_UNKNOWN_PRINTPROCESSOR, "ERROR_UNKNOWN_PRINTPROCESSOR" },
{ ERROR_INVALID_SEPARATOR_FILE, "ERROR_INVALID_SEPARATOR_FILE" },
{ ERROR_INVALID_PRIORITY, "ERROR_INVALID_PRIORITY" },
{ ERROR_INVALID_PRINTER_NAME, "ERROR_INVALID_PRINTER_NAME" },
{ ERROR_PRINTER_ALREADY_EXISTS, "ERROR_PRINTER_ALREADY_EXISTS" },
{ ERROR_INVALID_PRINTER_COMMAND, "ERROR_INVALID_PRINTER_COMMAND" },
{ ERROR_INVALID_DATATYPE, "ERROR_INVALID_DATATYPE" },
{ ERROR_INVALID_ENVIRONMENT, "ERROR_INVALID_ENVIRONMENT" },
{ RPC_S_NO_MORE_BINDINGS, "RPC_S_NO_MORE_BINDINGS" },
{ ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT, "ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT" },
{ ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT, "ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT" },
{ ERROR_NOLOGON_SERVER_TRUST_ACCOUNT, "ERROR_NOLOGON_SERVER_TRUST_ACCOUNT" },
{ ERROR_DOMAIN_TRUST_INCONSISTENT, "ERROR_DOMAIN_TRUST_INCONSISTENT" },
{ ERROR_SERVER_HAS_OPEN_HANDLES, "ERROR_SERVER_HAS_OPEN_HANDLES" },
{ ERROR_RESOURCE_DATA_NOT_FOUND, "ERROR_RESOURCE_DATA_NOT_FOUND" },
{ ERROR_RESOURCE_TYPE_NOT_FOUND, "ERROR_RESOURCE_TYPE_NOT_FOUND" },
{ ERROR_RESOURCE_NAME_NOT_FOUND, "ERROR_RESOURCE_NAME_NOT_FOUND" },
{ ERROR_RESOURCE_LANG_NOT_FOUND, "ERROR_RESOURCE_LANG_NOT_FOUND" },
{ ERROR_NOT_ENOUGH_QUOTA, "ERROR_NOT_ENOUGH_QUOTA" },
{ RPC_S_NO_INTERFACES, "RPC_S_NO_INTERFACES" },
{ RPC_S_CALL_CANCELLED, "RPC_S_CALL_CANCELLED" },
{ RPC_S_BINDING_INCOMPLETE, "RPC_S_BINDING_INCOMPLETE" },
{ RPC_S_COMM_FAILURE, "RPC_S_COMM_FAILURE" },
{ RPC_S_UNSUPPORTED_AUTHN_LEVEL, "RPC_S_UNSUPPORTED_AUTHN_LEVEL" },
{ RPC_S_NO_PRINC_NAME, "RPC_S_NO_PRINC_NAME" },
{ RPC_S_NOT_RPC_ERROR, "RPC_S_NOT_RPC_ERROR" },
{ RPC_S_UUID_LOCAL_ONLY, "RPC_S_UUID_LOCAL_ONLY" },
{ RPC_S_SEC_PKG_ERROR, "RPC_S_SEC_PKG_ERROR" },
{ RPC_S_NOT_CANCELLED, "RPC_S_NOT_CANCELLED" },
{ RPC_X_INVALID_ES_ACTION, "RPC_X_INVALID_ES_ACTION" },
{ RPC_X_WRONG_ES_VERSION, "RPC_X_WRONG_ES_VERSION" },
{ RPC_X_WRONG_STUB_VERSION, "RPC_X_WRONG_STUB_VERSION" },
#ifdef RPC_X_INVALID_PIPE_OBJECT
{ RPC_X_INVALID_PIPE_OBJECT, "RPC_X_INVALID_PIPE_OBJECT" },
#endif
#ifdef RPC_X_INVALID_PIPE_OPERATION
{ RPC_X_INVALID_PIPE_OPERATION, "RPC_X_INVALID_PIPE_OPERATION" },
#endif
#ifdef RPC_X_WRONG_PIPE_VERSION
{ RPC_X_WRONG_PIPE_VERSION, "RPC_X_WRONG_PIPE_VERSION" },
#endif
{ RPC_S_GROUP_MEMBER_NOT_FOUND, "RPC_S_GROUP_MEMBER_NOT_FOUND" },
{ EPT_S_CANT_CREATE, "EPT_S_CANT_CREATE" },
{ RPC_S_INVALID_OBJECT, "RPC_S_INVALID_OBJECT" },
{ ERROR_INVALID_TIME, "ERROR_INVALID_TIME" },
{ ERROR_INVALID_FORM_NAME, "ERROR_INVALID_FORM_NAME" },
{ ERROR_INVALID_FORM_SIZE, "ERROR_INVALID_FORM_SIZE" },
{ ERROR_ALREADY_WAITING, "ERROR_ALREADY_WAITING" },
{ ERROR_PRINTER_DELETED, "ERROR_PRINTER_DELETED" },
{ ERROR_INVALID_PRINTER_STATE, "ERROR_INVALID_PRINTER_STATE" },
{ ERROR_PASSWORD_MUST_CHANGE, "ERROR_PASSWORD_MUST_CHANGE" },
{ ERROR_DOMAIN_CONTROLLER_NOT_FOUND, "ERROR_DOMAIN_CONTROLLER_NOT_FOUND" },
{ ERROR_ACCOUNT_LOCKED_OUT, "ERROR_ACCOUNT_LOCKED_OUT" },
#ifdef OR_INVALID_OXID
{ OR_INVALID_OXID, "OR_INVALID_OXID" },
#endif
#ifdef OR_INVALID_OID
{ OR_INVALID_OID, "OR_INVALID_OID" },
#endif
#ifdef OR_INVALID_SET
{ OR_INVALID_SET, "OR_INVALID_SET" },
#endif
#ifdef RPC_S_SEND_INCOMPLETE
{ RPC_S_SEND_INCOMPLETE, "RPC_S_SEND_INCOMPLETE" },
#endif
{ ERROR_NO_BROWSER_SERVERS_FOUND, "ERROR_NO_BROWSER_SERVERS_FOUND" },
{ ERROR_INVALID_PIXEL_FORMAT, "ERROR_INVALID_PIXEL_FORMAT" },
{ ERROR_BAD_DRIVER, "ERROR_BAD_DRIVER" },
{ ERROR_INVALID_WINDOW_STYLE, "ERROR_INVALID_WINDOW_STYLE" },
{ ERROR_METAFILE_NOT_SUPPORTED, "ERROR_METAFILE_NOT_SUPPORTED" },
{ ERROR_TRANSFORM_NOT_SUPPORTED, "ERROR_TRANSFORM_NOT_SUPPORTED" },
{ ERROR_CLIPPING_NOT_SUPPORTED, "ERROR_CLIPPING_NOT_SUPPORTED" },
{ ERROR_UNKNOWN_PRINT_MONITOR, "ERROR_UNKNOWN_PRINT_MONITOR" },
{ ERROR_PRINTER_DRIVER_IN_USE, "ERROR_PRINTER_DRIVER_IN_USE" },
{ ERROR_SPOOL_FILE_NOT_FOUND, "ERROR_SPOOL_FILE_NOT_FOUND" },
{ ERROR_SPL_NO_STARTDOC, "ERROR_SPL_NO_STARTDOC" },
{ ERROR_SPL_NO_ADDJOB, "ERROR_SPL_NO_ADDJOB" },
{ ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED, "ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED" },
{ ERROR_PRINT_MONITOR_ALREADY_INSTALLED, "ERROR_PRINT_MONITOR_ALREADY_INSTALLED" },
#ifdef ERROR_INVALID_PRINT_MONITOR
{ ERROR_INVALID_PRINT_MONITOR, "ERROR_INVALID_PRINT_MONITOR" },
#endif
#ifdef ERROR_PRINT_MONITOR_IN_USE
{ ERROR_PRINT_MONITOR_IN_USE, "ERROR_PRINT_MONITOR_IN_USE" },
#endif
#ifdef ERROR_PRINTER_HAS_JOBS_QUEUED
{ ERROR_PRINTER_HAS_JOBS_QUEUED, "ERROR_PRINTER_HAS_JOBS_QUEUED" },
#endif
#ifdef ERROR_SUCCESS_REBOOT_REQUIRED
{ ERROR_SUCCESS_REBOOT_REQUIRED, "ERROR_SUCCESS_REBOOT_REQUIRED" },
#endif
#ifdef ERROR_SUCCESS_RESTART_REQUIRED
{ ERROR_SUCCESS_RESTART_REQUIRED, "ERROR_SUCCESS_RESTART_REQUIRED" },
#endif
{ ERROR_WINS_INTERNAL, "ERROR_WINS_INTERNAL" },
{ ERROR_CAN_NOT_DEL_LOCAL_WINS, "ERROR_CAN_NOT_DEL_LOCAL_WINS" },
{ ERROR_STATIC_INIT, "ERROR_STATIC_INIT" },
{ ERROR_INC_BACKUP, "ERROR_INC_BACKUP" },
{ ERROR_FULL_BACKUP, "ERROR_FULL_BACKUP" },
{ ERROR_REC_NON_EXISTENT, "ERROR_REC_NON_EXISTENT" },
{ ERROR_RPL_NOT_ALLOWED, "ERROR_RPL_NOT_ALLOWED" },
{ WSAEINTR, "WSAEINTR" },
{ WSAEBADF, "WSAEBADF" },
{ WSAEACCES, "WSAEACCES" },
{ WSAEFAULT, "WSAEFAULT" },
{ WSAEINVAL, "WSAEINVAL" },
{ WSAEMFILE, "WSAEMFILE" },
{ WSAEWOULDBLOCK, "WSAEWOULDBLOCK" },
{ WSAEINPROGRESS, "WSAEINPROGRESS" },
{ WSAEALREADY, "WSAEALREADY" },
{ WSAENOTSOCK, "WSAENOTSOCK" },
{ WSAEDESTADDRREQ, "WSAEDESTADDRREQ" },
{ WSAEMSGSIZE, "WSAEMSGSIZE" },
{ WSAEPROTOTYPE, "WSAEPROTOTYPE" },
{ WSAENOPROTOOPT, "WSAENOPROTOOPT" },
{ WSAEPROTONOSUPPORT, "WSAEPROTONOSUPPORT" },
{ WSAESOCKTNOSUPPORT, "WSAESOCKTNOSUPPORT" },
{ WSAEOPNOTSUPP, "WSAEOPNOTSUPP" },
{ WSAEPFNOSUPPORT, "WSAEPFNOSUPPORT" },
{ WSAEAFNOSUPPORT, "WSAEAFNOSUPPORT" },
{ WSAEADDRINUSE, "WSAEADDRINUSE" },
{ WSAEADDRNOTAVAIL, "WSAEADDRNOTAVAIL" },
{ WSAENETDOWN, "WSAENETDOWN" },
{ WSAENETUNREACH, "WSAENETUNREACH" },
{ WSAENETRESET, "WSAENETRESET" },
{ WSAECONNABORTED, "WSAECONNABORTED" },
{ WSAECONNRESET, "WSAECONNRESET" },
{ WSAENOBUFS, "WSAENOBUFS" },
{ WSAEISCONN, "WSAEISCONN" },
{ WSAENOTCONN, "WSAENOTCONN" },
{ WSAESHUTDOWN, "WSAESHUTDOWN" },
{ WSAETOOMANYREFS, "WSAETOOMANYREFS" },
{ WSAETIMEDOUT, "WSAETIMEDOUT" },
{ WSAECONNREFUSED, "WSAECONNREFUSED" },
{ WSAELOOP, "WSAELOOP" },
{ WSAENAMETOOLONG, "WSAENAMETOOLONG" },
{ WSAEHOSTDOWN, "WSAEHOSTDOWN" },
{ WSAEHOSTUNREACH, "WSAEHOSTUNREACH" },
{ WSAENOTEMPTY, "WSAENOTEMPTY" },
{ WSAEPROCLIM, "WSAEPROCLIM" },
{ WSAEUSERS, "WSAEUSERS" },
{ WSAEDQUOT, "WSAEDQUOT" },
{ WSAESTALE, "WSAESTALE" },
{ WSAEREMOTE, "WSAEREMOTE" },
{ WSAEDISCON, "WSAEDISCON" },
{ WSASYSNOTREADY, "WSASYSNOTREADY" },
{ WSAVERNOTSUPPORTED, "WSAVERNOTSUPPORTED" },
{ WSANOTINITIALISED, "WSANOTINITIALISED" },
{ WSAHOST_NOT_FOUND, "WSAHOST_NOT_FOUND" },
{ WSATRY_AGAIN, "WSATRY_AGAIN" },
{ WSANO_RECOVERY, "WSANO_RECOVERY" },
{ WSANO_DATA, "WSANO_DATA" },
#endif
};
const char *stringFromErrorCode(int err)
{
for (unsigned i = 0; i < sizeof(errortable)/sizeof(errortable[0]); i++)
{
if (errortable[i].errorNum == err) {
return errortable[i].errorString;
}
}
return 0;
}
bool errorCodeFromString(const char *text, int *err)
{
for (unsigned i = 0; i < sizeof(errortable)/sizeof(errortable[0]); i++)
{
if (strcmp(text, errortable[i].errorString) == 0)
{
*err = errortable[i].errorNum;
return true;
}
}
return false;
}
diff --git a/libpolyml/exporter.cpp b/libpolyml/exporter.cpp
index 3d2285bc..6d7ea139 100644
--- a/libpolyml/exporter.cpp
+++ b/libpolyml/exporter.cpp
@@ -1,913 +1,914 @@
/*
Title: exporter.cpp - Export a function as an object or C file
Copyright (c) 2006-7, 2015, 2016-19 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_SYS_PARAM_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#else
#define _T(x) x
#define _tcslen strlen
#define _tcscmp strcmp
#define _tcscat strcat
#endif
#include "exporter.h"
#include "save_vec.h"
#include "polystring.h"
#include "run_time.h"
#include "osmem.h"
#include "scanaddrs.h"
#include "gc.h"
#include "machine_dep.h"
#include "diagnostics.h"
#include "memmgr.h"
#include "processes.h" // For IO_SPACING
#include "sys.h" // For EXC_Fail
#include "rtsentry.h"
#include "pexport.h"
#ifdef HAVE_PECOFF
#include "pecoffexport.h"
#elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H)
#include "elfexport.h"
#elif defined(HAVE_MACH_O_RELOC_H)
#include "machoexport.h"
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#define NOMEMORY ERROR_NOT_ENOUGH_MEMORY
#define ERRORNUMBER _doserrno
#else
#define NOMEMORY ENOMEM
#define ERRORNUMBER errno
#endif
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root);
}
/*
To export the function and everything reachable from it we need to copy
all the objects into a new area. We leave tombstones in the original
objects by overwriting the length word. That prevents us from copying an
object twice and breaks loops. Once we've copied the objects we then
have to go back over the memory and turn the tombstones back into length
words.
*/
GraveYard::~GraveYard()
{
free(graves);
}
// Used to calculate the space required for the ordinary mutables
// and the no-overwrite mutables. They are interspersed in local space.
class MutSizes : public ScanAddress
{
public:
MutSizes() : mutSize(0), noOverSize(0) {}
virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; }// No Actually used
virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord)
{
const POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord) + 1; // Include length word
if (OBJ_IS_NO_OVERWRITE(lengthWord))
noOverSize += words;
else mutSize += words;
}
POLYUNSIGNED mutSize, noOverSize;
};
CopyScan::CopyScan(unsigned h/*=0*/): hierarchy(h)
{
defaultImmSize = defaultMutSize = defaultCodeSize = defaultNoOverSize = 0;
tombs = 0;
graveYard = 0;
}
void CopyScan::initialise(bool isExport/*=true*/)
{
ASSERT(gMem.eSpaces.size() == 0);
// Set the space sizes to a proportion of the space currently in use.
// Computing these sizes is not obvious because CopyScan is used both
// for export and for saved states. For saved states in particular we
// want to use a smaller size because they are retained after we save
// the state and if we have many child saved states it's important not
// to waste memory.
if (hierarchy == 0)
{
graveYard = new GraveYard[gMem.pSpaces.size()];
if (graveYard == 0)
{
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Unable to allocate graveyard, size: %lu.\n", gMem.pSpaces.size());
throw MemoryException();
}
}
for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++)
{
PermanentMemSpace *space = *i;
if (space->hierarchy >= hierarchy) {
// Include this if we're exporting (hierarchy=0) or if we're saving a state
// and will include this in the new state.
size_t size = (space->top-space->bottom)/4;
if (space->noOverwrite)
defaultNoOverSize += size;
else if (space->isMutable)
defaultMutSize += size;
else if (space->isCode)
defaultCodeSize += size;
else
defaultImmSize += size;
if (space->hierarchy == 0 && ! space->isMutable)
{
// We need a separate area for the tombstones because this is read-only
graveYard[tombs].graves = (PolyWord*)calloc(space->spaceSize(), sizeof(PolyWord));
if (graveYard[tombs].graves == 0)
{
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Unable to allocate graveyard for permanent space, size: %lu.\n",
space->spaceSize() * sizeof(PolyWord));
throw MemoryException();
}
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Allocated graveyard for permanent space, %p size: %lu.\n",
graveYard[tombs].graves, space->spaceSize() * sizeof(PolyWord));
graveYard[tombs].startAddr = space->bottom;
graveYard[tombs].endAddr = space->top;
tombs++;
}
}
}
for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *space = *i;
uintptr_t size = space->allocatedSpace();
// It looks as though the mutable size generally gets
// overestimated while the immutable size is correct.
if (space->isMutable)
{
MutSizes sizeMut;
sizeMut.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr);
sizeMut.ScanAddressesInRegion(space->upperAllocPtr, space->top);
defaultNoOverSize += sizeMut.noOverSize / 4;
defaultMutSize += sizeMut.mutSize / 4;
}
else
defaultImmSize += size/2;
}
for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++)
{
CodeSpace *space = *i;
uintptr_t size = space->spaceSize();
defaultCodeSize += size/2;
}
if (isExport)
{
// Minimum 1M words.
if (defaultMutSize < 1024*1024) defaultMutSize = 1024*1024;
if (defaultImmSize < 1024*1024) defaultImmSize = 1024*1024;
if (defaultCodeSize < 1024*1024) defaultCodeSize = 1024*1024;
#ifdef MACOSX
// Limit the segment size for Mac OS X. The linker has a limit of 2^24 relocations
// in a segment so this is a crude way of ensuring the limit isn't exceeded.
// It's unlikely to be exceeded by the code itself.
// Actually, from trial-and-error, the limit seems to be around 6M.
if (defaultMutSize > 6 * 1024 * 1024) defaultMutSize = 6 * 1024 * 1024;
if (defaultImmSize > 6 * 1024 * 1024) defaultImmSize = 6 * 1024 * 1024;
#endif
if (defaultNoOverSize < 4096) defaultNoOverSize = 4096; // Except for the no-overwrite area
}
else
{
// Much smaller minimum sizes for saved states.
if (defaultMutSize < 1024) defaultMutSize = 1024;
if (defaultImmSize < 4096) defaultImmSize = 4096;
if (defaultCodeSize < 4096) defaultCodeSize = 4096;
if (defaultNoOverSize < 4096) defaultNoOverSize = 4096;
// Set maximum sizes as well. We may have insufficient contiguous space for
// very large areas.
if (defaultMutSize > 1024 * 1024) defaultMutSize = 1024 * 1024;
if (defaultImmSize > 1024 * 1024) defaultImmSize = 1024 * 1024;
if (defaultCodeSize > 1024 * 1024) defaultCodeSize = 1024 * 1024;
if (defaultNoOverSize > 1024 * 1024) defaultNoOverSize = 1024 * 1024;
}
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Copyscan default sizes: Immutable: %" POLYUFMT ", Mutable: %" POLYUFMT ", Code: %" POLYUFMT ", No-overwrite %" POLYUFMT ".\n",
defaultImmSize, defaultMutSize, defaultCodeSize, defaultNoOverSize);
}
CopyScan::~CopyScan()
{
gMem.DeleteExportSpaces();
if (graveYard)
delete[](graveYard);
}
// This function is called for each address in an object
// once it has been copied to its new location. We copy first
// then scan to update the addresses.
POLYUNSIGNED CopyScan::ScanAddressAt(PolyWord *pt)
{
PolyWord val = *pt;
// Ignore integers.
if (IS_INT(val) || val == PolyWord::FromUnsigned(0))
return 0;
PolyObject *obj = val.AsObjPtr();
POLYUNSIGNED l = ScanAddress(&obj);
*pt = obj;
return l;
}
// This function is called for each address in an object
// once it has been copied to its new location. We copy first
// then scan to update the addresses.
POLYUNSIGNED CopyScan::ScanAddress(PolyObject **pt)
{
PolyObject *obj = *pt;
MemSpace *space = gMem.SpaceForAddress((PolyWord*)obj - 1);
ASSERT(space != 0);
// We may sometimes get addresses that have already been updated
// to point to the new area. e.g. (only?) in the case of constants
// that have been updated in ScanConstantsWithinCode.
if (space->spaceType == ST_EXPORT)
return 0;
// If this is at a lower level than the hierarchy we are saving
// then leave it untouched.
if (space->spaceType == ST_PERMANENT)
{
PermanentMemSpace *pmSpace = (PermanentMemSpace*)space;
if (pmSpace->hierarchy < hierarchy)
return 0;
}
// Have we already scanned this?
if (obj->ContainsForwardingPtr())
{
// Update the address to the new value.
#ifdef POLYML32IN64
PolyObject *newAddr;
if (space->isCode)
newAddr = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1));
else newAddr = obj->GetForwardingPtr();
#else
PolyObject *newAddr = obj->GetForwardingPtr();
#endif
*pt = newAddr;
return 0; // No need to scan it again.
}
else if (space->spaceType == ST_PERMANENT)
{
// See if we have this in the grave-yard.
for (unsigned i = 0; i < tombs; i++)
{
GraveYard *g = &graveYard[i];
if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr)
{
PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr);
PolyObject *tombObject = (PolyObject*)tombAddr;
if (tombObject->ContainsForwardingPtr())
{
#ifdef POLYML32IN64
PolyObject *newAddr;
if (space->isCode)
newAddr = (PolyObject*)(globalCodeBase + ((tombObject->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1));
else newAddr = tombObject->GetForwardingPtr();
#else
PolyObject *newAddr = tombObject->GetForwardingPtr();
#endif
*pt = newAddr;
return 0;
}
break; // No need to look further
}
}
}
// No, we need to copy it.
ASSERT(space->spaceType == ST_LOCAL || space->spaceType == ST_PERMANENT ||
space->spaceType == ST_CODE);
POLYUNSIGNED lengthWord = obj->LengthWord();
POLYUNSIGNED words = OBJ_OBJECT_LENGTH(lengthWord);
PolyObject *newObj = 0;
bool isMutableObj = obj->IsMutable();
bool isNoOverwrite = false;
bool isByteObj = false;
bool isCodeObj = false;
if (isMutableObj)
{
isNoOverwrite = obj->IsNoOverwriteObject();
isByteObj = obj->IsByteObject();
}
else isCodeObj = obj->IsCodeObject();
// Allocate a new address for the object.
for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++)
{
PermanentMemSpace *space = *i;
if (isMutableObj == space->isMutable &&
isNoOverwrite == space->noOverwrite &&
isByteObj == space->byteOnly &&
isCodeObj == space->isCode)
{
ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom);
size_t spaceLeft = space->top - space->topPointer;
if (spaceLeft > words)
{
newObj = (PolyObject*)(space->topPointer + 1);
space->topPointer += words + 1;
#ifdef POLYML32IN64
// Maintain the odd-word alignment of topPointer
if ((words & 1) == 0 && space->topPointer < space->top)
{
*space->topPointer = PolyWord::FromUnsigned(0);
space->topPointer++;
}
#endif
break;
}
}
}
if (newObj == 0)
{
// Didn't find room in the existing spaces. Create a new space.
uintptr_t spaceWords;
if (isMutableObj)
{
if (isNoOverwrite) spaceWords = defaultNoOverSize;
else spaceWords = defaultMutSize;
}
else
{
if (isCodeObj) spaceWords = defaultCodeSize;
else spaceWords = defaultImmSize;
}
if (spaceWords <= words)
spaceWords = words + 1; // Make sure there's space for this object.
PermanentMemSpace *space = gMem.NewExportSpace(spaceWords, isMutableObj, isNoOverwrite, isCodeObj);
if (isByteObj) space->byteOnly = true;
if (space == 0)
{
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Unable to allocate export space, size: %lu.\n", spaceWords);
// Unable to allocate this.
throw MemoryException();
}
newObj = (PolyObject*)(space->topPointer + 1);
space->topPointer += words + 1;
#ifdef POLYML32IN64
// Maintain the odd-word alignment of topPointer
if ((words & 1) == 0 && space->topPointer < space->top)
{
*space->topPointer = PolyWord::FromUnsigned(0);
space->topPointer++;
}
#endif
ASSERT(space->topPointer <= space->top && space->topPointer >= space->bottom);
}
newObj->SetLengthWord(lengthWord); // copy length word
memcpy(newObj, obj, words * sizeof(PolyWord));
if (space->spaceType == ST_PERMANENT && !space->isMutable && ((PermanentMemSpace*)space)->hierarchy == 0)
{
// The immutable permanent areas are read-only.
unsigned m;
for (m = 0; m < tombs; m++)
{
GraveYard *g = &graveYard[m];
if ((PolyWord*)obj >= g->startAddr && (PolyWord*)obj < g->endAddr)
{
PolyWord *tombAddr = g->graves + ((PolyWord*)obj - g->startAddr);
PolyObject *tombObject = (PolyObject*)tombAddr;
#ifdef POLYML32IN64
if (isCodeObj)
{
POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj - globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT);
tombObject->SetLengthWord(ll);
}
else tombObject->SetForwardingPtr(newObj);
#else
tombObject->SetForwardingPtr(newObj);
#endif
break; // No need to look further
}
}
ASSERT(m < tombs); // Should be there.
}
#ifdef POLYML32IN64
// If this is a code address we can't use the usual forwarding pointer format.
// Instead we have to compute the offset relative to the base of the code.
else if (isCodeObj)
{
POLYUNSIGNED ll = (POLYUNSIGNED)(((PolyWord*)newObj-globalCodeBase) >> 1 | _OBJ_TOMBSTONE_BIT);
obj->SetLengthWord(ll);
}
#endif
else obj->SetForwardingPtr(newObj); // Put forwarding pointer in old object.
if (OBJ_IS_CODE_OBJECT(lengthWord))
{
// We don't need to worry about flushing the instruction cache
// since we're not going to execute this code here.
// We do have to update any relative addresses within the code
// to take account of its new position. We have to do that now
// even though ScanAddressesInObject will do it again because this
// is the only point where we have both the old and the new addresses.
machineDependent->ScanConstantsWithinCode(newObj, obj, words, this);
}
*pt = newObj; // Update it to the newly copied object.
return lengthWord; // This new object needs to be scanned.
}
// The address of code in the code area. We treat this as a normal heap cell.
// We will probably need to copy this and to process addresses within it.
POLYUNSIGNED CopyScan::ScanCodeAddressAt(PolyObject **pt)
{
POLYUNSIGNED lengthWord = ScanAddress(pt);
if (lengthWord)
ScanAddressesInObject(*pt, lengthWord);
return 0;
}
PolyObject *CopyScan::ScanObjectAddress(PolyObject *base)
{
PolyWord val = base;
// Scan this as an address.
POLYUNSIGNED lengthWord = CopyScan::ScanAddressAt(&val);
if (lengthWord)
ScanAddressesInObject(val.AsObjPtr(), lengthWord);
return val.AsObjPtr();
}
#define MAX_EXTENSION 4 // The longest extension we may need to add is ".obj"
// Convert the forwarding pointers in a region back into length words.
// Generally if this object has a forwarding pointer that's
// because we've moved it into the export region. We can,
// though, get multiple levels of forwarding if there is an object
// that has been shifted up by a garbage collection, leaving a forwarding
// pointer and then that object has been moved to the export region.
// We mustn't turn locally forwarded values back into ordinary objects
// because they could contain addresses that are no longer valid.
static POLYUNSIGNED GetObjLength(PolyObject *obj)
{
if (obj->ContainsForwardingPtr())
{
PolyObject *forwardedTo;
#ifdef POLYML32IN64
{
MemSpace *space = gMem.SpaceForAddress((PolyWord*)obj - 1);
if (space->isCode)
forwardedTo = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1));
else forwardedTo = obj->GetForwardingPtr();
}
#else
forwardedTo = obj->GetForwardingPtr();
#endif
POLYUNSIGNED length = GetObjLength(forwardedTo);
MemSpace *space = gMem.SpaceForAddress((PolyWord*)forwardedTo-1);
if (space->spaceType == ST_EXPORT)
obj->SetLengthWord(length);
return length;
}
else {
ASSERT(obj->ContainsNormalLengthWord());
return obj->LengthWord();
}
}
static void FixForwarding(PolyWord *pt, size_t space)
{
while (space)
{
pt++;
PolyObject *obj = (PolyObject*)pt;
#ifdef POLYML32IN64
if ((uintptr_t)obj & 4)
{
// Skip filler words needed to align to an even word
space--;
continue; // We've added 1 to pt so just loop.
}
#endif
size_t length = OBJ_OBJECT_LENGTH(GetObjLength(obj));
pt += length;
ASSERT(space > length);
space -= length+1;
}
}
class ExportRequest: public MainThreadRequest
{
public:
ExportRequest(Handle root, Exporter *exp): MainThreadRequest(MTP_EXPORTING),
exportRoot(root), exporter(exp) {}
virtual void Perform() { exporter->RunExport(exportRoot->WordP()); }
Handle exportRoot;
Exporter *exporter;
};
static void exporter(TaskData *taskData, Handle fileName, Handle root, const TCHAR *extension, Exporter *exports)
{
size_t extLen = _tcslen(extension);
TempString fileNameBuff(Poly_string_to_T_alloc(fileName->Word(), extLen));
if (fileNameBuff == NULL)
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
size_t length = _tcslen(fileNameBuff);
// Does it already have the extension? If not add it on.
if (length < extLen || _tcscmp(fileNameBuff + length - extLen, extension) != 0)
_tcscat(fileNameBuff, extension);
#if (defined(_WIN32) && defined(UNICODE))
exports->exportFile = _wfopen(fileNameBuff, L"wb");
#else
exports->exportFile = fopen(fileNameBuff, "wb");
#endif
if (exports->exportFile == NULL)
raise_syscall(taskData, "Cannot open export file", ERRORNUMBER);
// Request a full GC to reduce the size of fix-ups.
FullGC(taskData);
// Request the main thread to do the export.
ExportRequest request(root, exports);
processes->MakeRootRequest(taskData, &request);
if (exports->errorMessage)
raise_fail(taskData, exports->errorMessage);
}
// This is called by the initial thread to actually do the export.
void Exporter::RunExport(PolyObject *rootFunction)
{
Exporter *exports = this;
PolyObject *copiedRoot = 0;
CopyScan copyScan(hierarchy);
try {
copyScan.initialise();
// Copy the root and everything reachable from it into the temporary area.
copiedRoot = copyScan.ScanObjectAddress(rootFunction);
}
catch (MemoryException &)
{
// If we ran out of memory.
copiedRoot = 0;
}
// Fix the forwarding pointers.
for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *space = *i;
// Local areas only have objects from the allocation pointer to the top.
FixForwarding(space->bottom, space->lowerAllocPtr - space->bottom);
FixForwarding(space->upperAllocPtr, space->top - space->upperAllocPtr);
}
for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++)
{
MemSpace *space = *i;
// Permanent areas are filled with objects from the bottom.
FixForwarding(space->bottom, space->top - space->bottom);
}
for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++)
{
MemSpace *space = *i;
// Code areas are filled with objects from the bottom.
FixForwarding(space->bottom, space->top - space->bottom);
}
// Reraise the exception after cleaning up the forwarding pointers.
if (copiedRoot == 0)
{
exports->errorMessage = "Insufficient Memory";
return;
}
// Copy the areas into the export object.
size_t tableEntries = gMem.eSpaces.size();
unsigned memEntry = 0;
if (hierarchy != 0) tableEntries += gMem.pSpaces.size();
exports->memTable = new memoryTableEntry[tableEntries];
// If we're constructing a module we need to include the global spaces.
if (hierarchy != 0)
{
// Permanent spaces from the executable.
for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++)
{
PermanentMemSpace *space = *i;
if (space->hierarchy < hierarchy)
{
memoryTableEntry *entry = &exports->memTable[memEntry++];
entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom;
entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord);
entry->mtIndex = space->index;
entry->mtFlags = 0;
if (space->isMutable) entry->mtFlags |= MTF_WRITEABLE;
if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE;
}
}
newAreas = memEntry;
}
for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++)
{
memoryTableEntry *entry = &exports->memTable[memEntry++];
PermanentMemSpace *space = *i;
entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom;
entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord);
entry->mtIndex = hierarchy == 0 ? memEntry-1 : space->index;
entry->mtFlags = 0;
if (space->isMutable)
{
entry->mtFlags = MTF_WRITEABLE;
if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE;
}
if (space->isCode) entry->mtFlags |= MTF_EXECUTABLE;
if (space->byteOnly) entry->mtFlags |= MTF_BYTES;
}
ASSERT(memEntry == tableEntries);
exports->memTableEntries = memEntry;
exports->rootFunction = copiedRoot;
try {
// This can raise MemoryException at least in PExport::exportStore.
exports->exportStore();
}
catch (MemoryException &) {
exports->errorMessage = "Insufficient Memory";
}
}
// Functions called via the RTS call.
Handle exportNative(TaskData *taskData, Handle args)
{
#ifdef HAVE_PECOFF
// Windows including Cygwin
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
const TCHAR *extension = _T(".obj"); // Windows
#else
const char *extension = ".o"; // Cygwin
#endif
PECOFFExport exports;
exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)),
taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports);
#elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H)
// Most Unix including Linux, FreeBSD and Solaris.
const char *extension = ".o";
ELFExport exports;
exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)),
taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports);
#elif defined(HAVE_MACH_O_RELOC_H)
// Mac OS-X
const char *extension = ".o";
MachoExport exports;
exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)),
taskData->saveVec.push(args->WordP()->Get(1)), extension, &exports);
#else
raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform");
#endif
return taskData->saveVec.push(TAGGED(0));
}
Handle exportPortable(TaskData *taskData, Handle args)
{
PExport exports;
exporter(taskData, taskData->saveVec.push(args->WordP()->Get(0)),
taskData->saveVec.push(args->WordP()->Get(1)), _T(".txt"), &exports);
return taskData->saveVec.push(TAGGED(0));
}
POLYUNSIGNED PolyExport(FirstArgument threadId, PolyWord fileName, PolyWord root)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedName = taskData->saveVec.push(fileName);
Handle pushedRoot = taskData->saveVec.push(root);
try {
#ifdef HAVE_PECOFF
// Windows including Cygwin
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
const TCHAR *extension = _T(".obj"); // Windows
#else
const char *extension = ".o"; // Cygwin
#endif
PECOFFExport exports;
exporter(taskData, pushedName, pushedRoot, extension, &exports);
#elif defined(HAVE_ELF_H) || defined(HAVE_ELF_ABI_H)
// Most Unix including Linux, FreeBSD and Solaris.
const char *extension = ".o";
ELFExport exports;
exporter(taskData, pushedName, pushedRoot, extension, &exports);
#elif defined(HAVE_MACH_O_RELOC_H)
// Mac OS-X
const char *extension = ".o";
MachoExport exports;
exporter(taskData, pushedName, pushedRoot, extension, &exports);
#else
raise_exception_string (taskData, EXC_Fail, "Native export not available for this platform");
#endif
} catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned(); // Returns unit
}
POLYUNSIGNED PolyExportPortable(FirstArgument threadId, PolyWord fileName, PolyWord root)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedName = taskData->saveVec.push(fileName);
Handle pushedRoot = taskData->saveVec.push(root);
try {
PExport exports;
exporter(taskData, pushedName, pushedRoot, _T(".txt"), &exports);
} catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned(); // Returns unit
}
// Helper functions for exporting. We need to produce relocation information
// and this code is common to every method.
Exporter::Exporter(unsigned int h): exportFile(NULL), errorMessage(0), hierarchy(h), memTable(0), newAreas(0)
{
}
Exporter::~Exporter()
{
delete[](memTable);
if (exportFile)
fclose(exportFile);
}
void Exporter::relocateValue(PolyWord *pt)
{
#ifndef POLYML32IN64
PolyWord q = *pt;
if (IS_INT(q) || q == PolyWord::FromUnsigned(0)) {}
else createRelocation(pt);
#endif
}
// Check through the areas to see where the address is. It must be
// in one of them.
unsigned Exporter::findArea(void *p)
{
for (unsigned i = 0; i < memTableEntries; i++)
{
if (p > memTable[i].mtOriginalAddr &&
p <= (char*)memTable[i].mtOriginalAddr + memTable[i].mtLength)
return i;
}
{ ASSERT(0); }
return 0;
}
void Exporter::relocateObject(PolyObject *p)
{
if (p->IsByteObject())
{
if (p->IsMutable() && p->IsWeakRefObject())
{
// Weak mutable byte refs are used for external references and
// also in the FFI for non-persistent values.
bool isFuncPtr = true;
const char *entryName = getEntryPointName(p, &isFuncPtr);
if (entryName != 0) addExternalReference(p, entryName, isFuncPtr);
// Clear the first word of the data.
ASSERT(p->Length() >= sizeof(uintptr_t)/sizeof(PolyWord));
*(uintptr_t*)p = 0;
}
}
else if (p->IsCodeObject())
{
POLYUNSIGNED constCount;
PolyWord *cp;
ASSERT(! p->IsMutable() );
p->GetConstSegmentForCode(cp, constCount);
/* Now the constants. */
for (POLYUNSIGNED i = 0; i < constCount; i++) relocateValue(&(cp[i]));
}
else if (p->IsClosureObject())
{
#ifndef POLYML32IN64
ASSERT(0);
#endif
// This should only be used in 32-in-64 where we don't use relocations.
}
else /* Ordinary objects, essentially tuples. */
{
POLYUNSIGNED length = p->Length();
for (POLYUNSIGNED i = 0; i < length; i++) relocateValue(p->Offset(i));
}
}
ExportStringTable::ExportStringTable(): strings(0), stringSize(0), stringAvailable(0)
{
}
ExportStringTable::~ExportStringTable()
{
free(strings);
}
// Add a string to the string table, growing it if necessary.
unsigned long ExportStringTable::makeEntry(const char *str)
{
unsigned len = (unsigned)strlen(str);
unsigned long entry = stringSize;
if (stringSize + len + 1 > stringAvailable)
{
stringAvailable = stringAvailable+stringAvailable/2;
if (stringAvailable < stringSize + len + 1)
stringAvailable = stringSize + len + 1 + 500;
- strings = (char*)realloc(strings, stringAvailable);
- if (strings == 0)
+ char* newStrings = (char*)realloc(strings, stringAvailable);
+ if (newStrings == 0)
{
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Unable to realloc string table, size: %lu.\n", stringAvailable);
throw MemoryException();
}
+ else strings = newStrings;
}
strcpy(strings + stringSize, str);
stringSize += len + 1;
return entry;
}
struct _entrypts exporterEPT[] =
{
{ "PolyExport", (polyRTSFunction)&PolyExport},
{ "PolyExportPortable", (polyRTSFunction)&PolyExportPortable},
{ NULL, NULL} // End of list.
};
diff --git a/libpolyml/gc.cpp b/libpolyml/gc.cpp
index 44654156..6fd69e4f 100644
--- a/libpolyml/gc.cpp
+++ b/libpolyml/gc.cpp
@@ -1,408 +1,416 @@
/*
Title: Multi-Threaded Garbage Collector
- Copyright (c) 2010-12 David C. J. Matthews
+ Copyright (c) 2010-12, 2019 David C. J. Matthews
Based on the original garbage collector code
Copyright 2000-2008
Cambridge University Technical Services Limited
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
#include "globals.h"
#include "run_time.h"
#include "machine_dep.h"
#include "diagnostics.h"
#include "processes.h"
#include "timing.h"
#include "gc.h"
#include "scanaddrs.h"
#include "check_objects.h"
#include "osmem.h"
#include "bitmap.h"
#include "rts_module.h"
#include "memmgr.h"
#include "gctaskfarm.h"
#include "mpoly.h"
#include "statistics.h"
#include "profiling.h"
#include "heapsizing.h"
static GCTaskFarm gTaskFarm; // Global task farm.
GCTaskFarm *gpTaskFarm = &gTaskFarm;
// If the GC converts a weak ref from SOME to NONE it sets this ref. It can be
// cleared by the signal handler thread. There's no need for a lock since it
// is only set during GC and only cleared when not GCing.
bool convertedWeak = false;
/*
How the garbage collector works.
The GC has two phases. The minor (quick) GC is a copying collector that
copies data from the allocation area into the mutable and immutable area.
The major collector is started when either the mutable or the immutable
area is full. The major collector uses a mark/sweep scheme.
The GC has three phases:
1. Mark phase.
Working from the roots; which are the the permanent mutable segments and
the RTS roots (e.g. thread stacks), mark all reachable cells.
Marking involves setting bits in the bitmap for reachable words.
2. Compact phase.
Marked objects are copied to try to compact, upwards, the heap segments. When
an object is moved the length word of the object in the old location is set as
a tombstone that points to its new location. In particular this means that we
cannot reuse the space where an object previously was during the compaction phase.
Immutable objects are moved into immutable segments. When an object is moved
to a new location the bits are set in the bitmap as though the object had been
marked at that location.
3. Update phase.
The roots and objects marked during the first two phases are scanned and any
addresses for moved objects are updated. The lowest address used in the area
then becomes the base of the area for future allocations.
There is a sharing phase which may be performed before the mark phase. This
merges immutable cells with the same contents with the aim of reducing the
size of the live data. It is expensive so is not performed by default.
Updated DCJM 12/06/12
*/
static bool doGC(const POLYUNSIGNED wordsRequiredToAllocate)
{
gHeapSizeParameters.RecordAtStartOfMajorGC();
gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeStart);
globalStats.incCount(PSC_GC_FULLGC);
// Remove any empty spaces. There will not normally be any except
// if we have triggered a full GC as a result of detecting paging in the
// minor GC but in that case we want to try to stop the system writing
// out areas that are now empty.
gMem.RemoveEmptyLocals();
if (debugOptions & DEBUG_GC)
Log("GC: Full GC, %lu words required %" PRI_SIZET " spaces\n", wordsRequiredToAllocate, gMem.lSpaces.size());
if (debugOptions & DEBUG_HEAPSIZE)
gMem.ReportHeapSizes("Full GC (before)");
// Data sharing pass.
if (gHeapSizeParameters.PerformSharingPass())
{
globalStats.incCount(PSC_GC_SHARING);
GCSharingPhase();
}
/*
* There is a really weird bug somewhere. An extra bit may be set in the bitmap during
* the mark phase. It seems to be related to heavy swapping activity. Duplicating the
* bitmap causes it to occur only in one copy and write-protecting the bitmap apart from
* when it is actually being updated does not result in a seg-fault. So far I've only
* seen it on 64-bit Linux but it may be responsible for other crashes. The work-around
* is to check the number of bits set in the bitmap and repeat the mark phase if it does
* not match.
*/
for (unsigned p = 3; p > 0; p--)
{
for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *lSpace = *i;
ASSERT (lSpace->top >= lSpace->upperAllocPtr);
ASSERT (lSpace->upperAllocPtr >= lSpace->lowerAllocPtr);
ASSERT (lSpace->lowerAllocPtr >= lSpace->bottom);
// Set upper and lower limits of weak refs.
lSpace->highestWeak = lSpace->bottom;
lSpace->lowestWeak = lSpace->top;
lSpace->fullGCLowerLimit = lSpace->top;
// Put dummy objects in the unused space. This allows
// us to scan over the whole of the space.
gMem.FillUnusedSpace(lSpace->lowerAllocPtr,
lSpace->upperAllocPtr-lSpace->lowerAllocPtr);
}
// Set limits of weak refs.
for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++)
{
PermanentMemSpace *pSpace = *i;
pSpace->highestWeak = pSpace->bottom;
pSpace->lowestWeak = pSpace->top;
}
/* Mark phase */
GCMarkPhase();
uintptr_t bitCount = 0, markCount = 0;
for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *lSpace = *i;
markCount += lSpace->i_marked + lSpace->m_marked;
bitCount += lSpace->bitmap.CountSetBits(lSpace->spaceSize());
}
if (markCount == bitCount)
break;
else
{
// Report an error. If this happens again we crash.
Log("GC: Count error mark count %lu, bitCount %lu\n", markCount, bitCount);
if (p == 1)
{
ASSERT(markCount == bitCount);
}
}
}
for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *lSpace = *i;
// Reset the allocation pointers. They will be set to the
// limits of the retained data.
#ifdef POLYML32IN64
lSpace->lowerAllocPtr = lSpace->bottom+1; // Must be odd-word aligned
lSpace->lowerAllocPtr[-1] = PolyWord::FromUnsigned(0);
#else
lSpace->lowerAllocPtr = lSpace->bottom;
#endif
lSpace->upperAllocPtr = lSpace->top;
}
if (debugOptions & DEBUG_GC) Log("GC: Check weak refs\n");
/* Detect unreferenced streams, windows etc. */
GCheckWeakRefs();
// Check that the heap is not overfull. We make sure the marked
// mutable and immutable data is no more than 90% of the
// corresponding areas. This is a very coarse adjustment.
{
uintptr_t iMarked = 0, mMarked = 0;
uintptr_t iSpace = 0, mSpace = 0;
for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *lSpace = *i;
iMarked += lSpace->i_marked;
mMarked += lSpace->m_marked;
if (! lSpace->allocationSpace)
{
if (lSpace->isMutable)
mSpace += lSpace->spaceSize();
else
iSpace += lSpace->spaceSize();
}
}
// Add space if necessary and possible.
while (iMarked > iSpace - iSpace/10 && gHeapSizeParameters.AddSpaceBeforeCopyPhase(false) != 0)
iSpace += gMem.DefaultSpaceSize();
while (mMarked > mSpace - mSpace/10 && gHeapSizeParameters.AddSpaceBeforeCopyPhase(true) != 0)
mSpace += gMem.DefaultSpaceSize();
}
/* Compact phase */
GCCopyPhase();
gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Copy");
// Update Phase.
if (debugOptions & DEBUG_GC) Log("GC: Update\n");
GCUpdatePhase();
gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeIntermediate, "Update");
{
uintptr_t iUpdated = 0, mUpdated = 0, iMarked = 0, mMarked = 0;
for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *lSpace = *i;
iMarked += lSpace->i_marked;
mMarked += lSpace->m_marked;
if (lSpace->isMutable)
mUpdated += lSpace->updated;
else
iUpdated += lSpace->updated;
}
ASSERT(iUpdated+mUpdated == iMarked+mMarked);
}
// Delete empty spaces.
gMem.RemoveEmptyLocals();
if (debugOptions & DEBUG_GC_ENHANCED)
{
for(std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *lSpace = *i;
Log("GC: %s space %p %" PRI_SIZET " free in %" PRI_SIZET " words %2.1f%% full\n", lSpace->spaceTypeString(),
lSpace, lSpace->freeSpace(), lSpace->spaceSize(),
((float)lSpace->allocatedSpace()) * 100 / (float)lSpace->spaceSize());
}
}
// Compute values for statistics
globalStats.setSize(PSS_AFTER_LAST_GC, 0);
globalStats.setSize(PSS_AFTER_LAST_FULLGC, 0);
globalStats.setSize(PSS_ALLOCATION, 0);
globalStats.setSize(PSS_ALLOCATION_FREE, 0);
for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *space = *i;
uintptr_t free = space->freeSpace();
globalStats.incSize(PSS_AFTER_LAST_GC, free*sizeof(PolyWord));
globalStats.incSize(PSS_AFTER_LAST_FULLGC, free*sizeof(PolyWord));
if (space->allocationSpace)
{
if (space->allocatedSpace() > space->freeSpace()) // It's more than half full
gMem.ConvertAllocationSpaceToLocal(space);
else
{
globalStats.incSize(PSS_ALLOCATION, free*sizeof(PolyWord));
globalStats.incSize(PSS_ALLOCATION_FREE, free*sizeof(PolyWord));
}
}
#ifdef FILL_UNUSED_MEMORY
memset(space->bottom, 0xaa, (char*)space->upperAllocPtr - (char*)space->bottom);
#endif
if (debugOptions & DEBUG_GC_ENHANCED)
Log("GC: %s space %p %" PRI_SIZET " free in %" PRI_SIZET " words %2.1f%% full\n", space->spaceTypeString(),
space, space->freeSpace(), space->spaceSize(),
((float)space->allocatedSpace()) * 100 / (float)space->spaceSize());
}
// End of garbage collection
gHeapSizeParameters.RecordGCTime(HeapSizeParameters::GCTimeEnd);
// Now we've finished we can adjust the heap sizes.
gHeapSizeParameters.AdjustSizeAfterMajorGC(wordsRequiredToAllocate);
gHeapSizeParameters.resetMajorTimingData();
bool haveSpace = gMem.CheckForAllocation(wordsRequiredToAllocate);
// Invariant: the bitmaps are completely clean.
if (debugOptions & DEBUG_GC)
{
if (haveSpace)
Log("GC: Completed successfully\n");
else Log("GC: Completed with insufficient space\n");
}
if (debugOptions & DEBUG_HEAPSIZE)
gMem.ReportHeapSizes("Full GC (after)");
// if (profileMode == kProfileLiveData || profileMode == kProfileLiveMutables)
// printprofile();
CheckMemory();
return haveSpace; // Completed
}
// Create the initial heap. hsize, isize and msize are the requested heap sizes
// from the user arguments in units of kbytes.
// Fills in the defaults and attempts to allocate the heap. If the heap size
// is too large it allocates as much as it can. The default heap size is half the
// physical memory.
void CreateHeap()
{
// Create an initial allocation space.
if (gMem.CreateAllocationSpace(gMem.DefaultSpaceSize()) == 0)
Exit("Insufficient memory to allocate the heap");
// Create the task farm if required
if (userOptions.gcthreads != 1)
{
if (! gTaskFarm.Initialise(userOptions.gcthreads, 100))
Crash("Unable to initialise the GC task farm");
}
// Set up the stacks for the mark phase.
initialiseMarkerTables();
}
+// Set single threaded mode. This is only used in a child process after
+// Posix fork in case there is a GC before the exec.
+void GCSetSingleThreadAfterFork()
+{
+ gpTaskFarm->SetSingleThreaded();
+ initialiseMarkerTables();
+}
+
class FullGCRequest: public MainThreadRequest
{
public:
FullGCRequest(): MainThreadRequest(MTP_GCPHASEMARK) {}
virtual void Perform()
{
doGC (0);
}
};
class QuickGCRequest: public MainThreadRequest
{
public:
QuickGCRequest(POLYUNSIGNED words): MainThreadRequest(MTP_GCPHASEMARK), wordsRequired(words) {}
virtual void Perform()
{
result =
#ifndef DEBUG_ONLY_FULL_GC
// If DEBUG_ONLY_FULL_GC is defined then we skip the partial GC.
RunQuickGC(wordsRequired) ||
#endif
doGC (wordsRequired);
}
bool result;
POLYUNSIGNED wordsRequired;
};
// Perform a full garbage collection. This is called either from ML via the full_gc RTS call
// or from various RTS functions such as open_file to try to recover dropped file handles.
void FullGC(TaskData *taskData)
{
FullGCRequest request;
processes->MakeRootRequest(taskData, &request);
if (convertedWeak)
// Notify the signal thread to broadcast on the condition var when
// the GC is complete. We mustn't call SignalArrived within the GC
// because it locks schedLock and the main GC thread already holds schedLock.
processes->SignalArrived();
}
// This is the normal call when memory is exhausted and we need to garbage collect.
bool QuickGC(TaskData *taskData, POLYUNSIGNED wordsRequiredToAllocate)
{
QuickGCRequest request(wordsRequiredToAllocate);
processes->MakeRootRequest(taskData, &request);
if (convertedWeak)
processes->SignalArrived();
return request.result;
}
// Called in RunShareData. This is called as a root function
void FullGCForShareCommonData(void)
{
doGC(0);
}
diff --git a/libpolyml/gc.h b/libpolyml/gc.h
index 8f61c4a6..242e48f6 100644
--- a/libpolyml/gc.h
+++ b/libpolyml/gc.h
@@ -1,60 +1,62 @@
/*
Title: gc.h - exports signature for gc.cpp
Copyright (c) 2000-7
Cambridge University Technical Services Limited
- Further development Copyright David C.J. Matthews 2010
+ Further development Copyright David C.J. Matthews 2010, 2019
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef GC_H_INCLUDED
#define GC_H_INCLUDED
#include "globals.h" // For POLYUNSIGNED
class TaskData;
// Make a request for a full garbage collection.
extern void FullGC(TaskData *taskData);
// Make a request for a partial garbage collection.
extern bool QuickGC(TaskData *taskData, POLYUNSIGNED words_needed);
extern void CreateHeap();
extern void FullGCForShareCommonData(void);
extern bool convertedWeak;
// Multi-thread GC.
extern void initialiseMarkerTables();
// The task farm for the GC. The threads are left waiting for the GC,
class GCTaskFarm;
extern GCTaskFarm *gpTaskFarm;
extern void CopyObjectToNewAddress(PolyObject *srcAddress, PolyObject *destAddress, POLYUNSIGNED L);
extern bool RunQuickGC(const POLYUNSIGNED wordsRequiredToAllocate);
+extern void GCSetSingleThreadAfterFork();
+
// GC Phases.
extern void GCSharingPhase(void);
extern void GCMarkPhase(void);
extern void GCheckWeakRefs(void);
extern void GCCopyPhase(void);
extern void GCUpdatePhase(void);
#endif
diff --git a/libpolyml/gctaskfarm.cpp b/libpolyml/gctaskfarm.cpp
index bb9c5715..fc98d743 100644
--- a/libpolyml/gctaskfarm.cpp
+++ b/libpolyml/gctaskfarm.cpp
@@ -1,279 +1,273 @@
/*
Title: Task farm for Multi-Threaded Garbage Collector
- Copyright (c) 2010 David C. J. Matthews
+ Copyright (c) 2010, 2019 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
- License as published by the Free Software Foundation; either
- version 2.1 of the License, or (at your option) any later version.
+ License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_MALLOC_H
#include
#endif
#ifdef HAVE_SYS_TIME_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
#include "gctaskfarm.h"
#include "diagnostics.h"
#include "timing.h"
static GCTaskId gTask;
GCTaskId *globalTask = &gTask;
GCTaskFarm::GCTaskFarm(): workLock("GC task farm work")
{
queueSize = queueIn = queuedItems = 0;
workQueue = 0;
terminate = false;
threadCount = activeThreadCount = 0;
-#if (defined(HAVE_PTHREAD_H) || defined(HAVE_WINDOWS_H))
threadHandles = 0;
-#endif
}
GCTaskFarm::~GCTaskFarm()
{
Terminate();
free(workQueue);
-#if (defined(HAVE_PTHREAD_H) || defined(HAVE_WINDOWS_H))
free(threadHandles);
-#endif
}
bool GCTaskFarm::Initialise(unsigned thrdCount, unsigned qSize)
{
terminate = false;
if (!waitForWork.Init(0, thrdCount)) return false;
workQueue = (queue_entry*)calloc(qSize, sizeof(queue_entry));
if (workQueue == 0) return false;
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+#if (!defined(_WIN32))
queueSize = qSize;
threadHandles = (pthread_t*)calloc(thrdCount, sizeof(pthread_t));
if (threadHandles == 0) return false;
-#elif defined(HAVE_WINDOWS_H)
+#else
queueSize = qSize;
threadHandles = (HANDLE*)calloc(thrdCount, sizeof(HANDLE));
if (threadHandles == 0) return false;
-#else
- queueSize = 0;
#endif
// Create the worker threads.
for (unsigned i = 0; i < thrdCount; i++) {
// Fork a thread
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+#if (!defined(_WIN32))
// Create a thread that isn't joinable since we don't want to wait
// for it to finish.
pthread_t pthreadId;
bool isError = pthread_create(&pthreadId, NULL, WorkerThreadFunction, this) != 0;
if (isError) break;
threadHandles[threadCount++] = pthreadId;
-#elif defined(HAVE_WINDOWS_H)
+#else
DWORD dwThrdId; // Have to provide this although we don't use it.
HANDLE threadHandle =
CreateThread(NULL, 0, WorkerThreadFunction, this, 0, &dwThrdId);
if (threadHandle == NULL) break;
threadHandles[threadCount++] = threadHandle;
#endif
}
return true;
}
void GCTaskFarm::Terminate()
{
terminate = true;
// Increment the semaphore by the number of threads to release them all.
for (unsigned i = 0; i < threadCount; i++) waitForWork.Signal();
// Wait for the threads to terminate.
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+#if (!defined(_WIN32))
for (unsigned j = 0; j < threadCount; j++)
pthread_join(threadHandles[j], NULL);
-#elif defined(HAVE_WINDOWS_H)
+#else
if (threadCount != 0)
WaitForMultipleObjects(threadCount, threadHandles, TRUE, 10000);
#endif
}
// Add work to the queue. Returns true if it succeeds.
bool GCTaskFarm::AddWork(gctask work, void *arg1, void *arg2)
{
bool wantSignal = false;
{
PLocker l(&workLock);
- if (queuedItems == queueSize) return false; // Queue is full
+ if (queuedItems == queueSize)
+ return false; // Queue is full
workQueue[queueIn].task = work;
workQueue[queueIn].arg1 = arg1;
workQueue[queueIn].arg2 = arg2;
queueIn++;
if (queueIn == queueSize) queueIn = 0;
queuedItems++;
wantSignal = queuedItems <= threadCount;
}
if (wantSignal) waitForWork.Signal();
return true;
}
// Schedule this as a task or run it immediately if the queue is full.
void GCTaskFarm::AddWorkOrRunNow(gctask work, void *arg1, void *arg2)
{
if (! AddWork(work, arg1, arg2))
(*work)(globalTask, arg1, arg2);
}
void GCTaskFarm::ThreadFunction()
{
GCTaskId myTaskId;
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
DWORD startActive = GetTickCount();
#else
struct timeval startTime;
gettimeofday(&startTime, NULL);
#endif
workLock.Lock();
activeThreadCount++;
while (! terminate) {
// Invariant: We have the lock and the activeThreadCount includes this thread.
// Find some work.
if (queuedItems > 0) { // There is work
unsigned outPos;
if (queuedItems > queueIn)
outPos = queueIn+queueSize-queuedItems;
else outPos = queueIn-queuedItems;
gctask work = workQueue[outPos].task;
void *arg1 = workQueue[outPos].arg1;
void *arg2 = workQueue[outPos].arg2;
workQueue[outPos].task = 0;
queuedItems--;
ASSERT(work != 0);
workLock.Unlock();
(*work)(&myTaskId, arg1, arg2);
workLock.Lock();
}
else {
activeThreadCount--; // We're no longer active
// If there is no work and we're the last active thread signal the
// main thread that the queue is empty
bool wantSignal = activeThreadCount == 0;
if (wantSignal)
waitForCompletion.Signal();
// Now release the lock. In our Windows partial implementation of
// condition vars we assume that signalling is done with the lock
// still held.
workLock.Unlock();
if (debugOptions & DEBUG_GCTASKS)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
Log("GCTask: Thread %p blocking after %u milliseconds\n", &myTaskId,
GetTickCount() - startActive);
#else
struct timeval endTime;
gettimeofday(&endTime, NULL);
subTimevals(&endTime, &startTime);
Log("GCTask: Thread %p blocking after %0.4f seconds\n", &myTaskId,
(float)endTime.tv_sec + (float)endTime.tv_usec / 1.0E6);
#endif
}
if (terminate) return;
// Block until there's work.
waitForWork.Wait();
// We've been woken up
if (debugOptions & DEBUG_GCTASKS)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
startActive = GetTickCount();
#else
gettimeofday(&startTime, NULL);
#endif
Log("GCTask: Thread %p resuming\n", &myTaskId);
}
workLock.Lock();
activeThreadCount++;
}
}
activeThreadCount--;
workLock.Unlock();
}
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+#if (!defined(_WIN32))
void *GCTaskFarm::WorkerThreadFunction(void *parameter)
{
GCTaskFarm *t = (GCTaskFarm *)parameter;
t->ThreadFunction();
return 0;
}
-#elif defined(HAVE_WINDOWS_H)
+#else
DWORD WINAPI GCTaskFarm::WorkerThreadFunction(void *parameter)
{
GCTaskFarm *t = (GCTaskFarm *)parameter;
t->ThreadFunction();
return 0;
}
#endif
// Wait until the queue is empty.
void GCTaskFarm::WaitForCompletion(void)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
DWORD startWait;
if (debugOptions & DEBUG_GCTASKS)
startWait = GetTickCount();
#else
struct timeval startWait;
if (debugOptions & DEBUG_GCTASKS)
gettimeofday(&startWait, NULL);
#endif
workLock.Lock();
while (activeThreadCount > 0 || queuedItems > 0)
waitForCompletion.Wait(&workLock);
workLock.Unlock();
if (debugOptions & DEBUG_GCTASKS)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
Log("GCTask: Threads completed after %u milliseconds\n", GetTickCount()-startWait);
#else
struct timeval endWait;
gettimeofday(&endWait, NULL);
subTimevals(&endWait, &startWait);
Log("GCTask: Threads completed after %0.4f seconds\n",
(float)endWait.tv_sec + (float)endWait.tv_usec / 1.0E6);
#endif
}
}
diff --git a/libpolyml/gctaskfarm.h b/libpolyml/gctaskfarm.h
index 473e4d6c..91d890b4 100644
--- a/libpolyml/gctaskfarm.h
+++ b/libpolyml/gctaskfarm.h
@@ -1,90 +1,94 @@
/*
Title: Task farm for Multi-Threaded Garbage Collector
- Copyright (c) 2010-12 David C. J. Matthews
+ Copyright (c) 2010-12, 2019 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef GCTASKFARM_H_INCLUDED
#define GCTASKFARM_H_INCLUDED
#include "locking.h"
// An empty class just used as an ID.
class GCTaskId {
};
extern GCTaskId *globalTask; // The ID used when a function is run immediately
// Function for action. The usual C++ approach would be to use an
// object pointer but that requires lots of small objects to be created
// and deleted.
typedef void (*gctask)(GCTaskId*, void*, void*);
typedef struct {
gctask task;
void *arg1;
void *arg2;
} queue_entry;
class GCTaskFarm {
public:
GCTaskFarm();
~GCTaskFarm();
+ // Initialise and create the worker threads
bool Initialise(unsigned threadCount, unsigned queueSize);
+ // Set single threaded mode. This is only used in a child process after
+ // Posix fork in case there is a GC before the exec.
+ void SetSingleThreaded() { threadCount = 0; queueSize = 0; }
bool AddWork(gctask task, void *arg1, void *arg2);
void AddWorkOrRunNow(gctask task, void *arg1, void *arg2);
void WaitForCompletion(void);
void Terminate(void);
// See if the queue is draining. Used as a hint as to whether
// it's worth sparking off some new work.
bool Draining(void) const { return queuedItems == 0; }
unsigned ThreadCount(void) const { return threadCount; }
private:
// The semaphore is zero if there is no work or some value up to
// the number of threads if there is work.
PSemaphore waitForWork;
// The lock protects the queue and the item count.
PLock workLock;
// The condition variable is signalled when the queue is empty.
// This can only be waited for by a single thread because it's not a proper
// implementation of a condition variable in Windows.
PCondVar waitForCompletion;
unsigned queueSize, queueIn, queuedItems;
queue_entry *workQueue; // Array of unit->unit functions.
bool terminate; // Set to true to kill all workers.
unsigned threadCount; // Count of workers.
unsigned activeThreadCount; // Count of workers doing work.
void ThreadFunction(void);
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+#if (!defined(_WIN32))
static void *WorkerThreadFunction(void *parameter);
pthread_t *threadHandles;
-#elif defined(HAVE_WINDOWS_H)
+#else
static DWORD WINAPI WorkerThreadFunction(void *parameter);
HANDLE *threadHandles;
#endif
};
#endif
diff --git a/libpolyml/globals.h b/libpolyml/globals.h
index 4c05c19f..c323a731 100644
--- a/libpolyml/globals.h
+++ b/libpolyml/globals.h
@@ -1,415 +1,415 @@
/*
Title: Globals for the system.
Author: Dave Matthews, Cambridge University Computer Laboratory
- Copyright David C. J. Matthews 2017-18
+ Copyright David C. J. Matthews 2017-19
Copyright (c) 2000-7
Cambridge University Technical Services Limited
Further work copyright David C.J. Matthews 2006-18
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef _GLOBALS_H
#define _GLOBALS_H
/*
Poly words, pointers and cells (objects).
The garbage collector needs to be able to distinguish different uses of a
memory word. We need to be able find which words are pointers to other
objects and which are simple integers. The simple distinction is between
integers, which are tagged by having the bottom bit set, and Addresses
which are word aligned (bottom 2 bits zero on a 32 bit machine, bottom 3
bits on a 64 bit machine, bottom bit in 32-in-64).
Addresses always point to the start of cells. The preceding word of a
cell is the length word. This contains the
length of the cell in words in the low-order 3 (7 in native 64-bits)
bytes and a flag byte in the top byte. The flags give information about
the type of the object. The length word is also used by the garbage
collector and other object processors.
*/
#if HAVE_STDINT_H
# include
#endif
#if HAVE_INTTYPES_H
# ifndef __STDC_FORMAT_MACROS
# define __STDC_FORMAT_MACROS
# endif
# include
#elif (defined(_MSC_VER) && (_MSC_VER >= 1900))
// In VS 2015 and later we need to use
# include
#endif
#ifdef HAVE_STDDEF_H
# include
#endif
#define POLY_TAGSHIFT 1
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
# include
#endif
#ifdef POLYML32IN64
typedef int32_t POLYSIGNED;
typedef uint32_t POLYUNSIGNED;
#define SIZEOF_POLYWORD 4
#else
typedef intptr_t POLYSIGNED;
typedef uintptr_t POLYUNSIGNED;
#define SIZEOF_POLYWORD SIZEOF_VOIDP
#endif
// libpolyml uses printf-style I/O instead of C++ standard IOstreams,
// so we need specifier to format POLYUNSIGNED/POLYSIGNED values.
#ifdef POLYML32IN64
#if (defined(PRIu32))
# define POLYUFMT PRIu32
# define POLYSFMT PRId32
#elif (defined(_MSC_VER))
# define POLYUFMT "lu"
# define POLYSFMT "ld"
#else
# define POLYUFMT "u"
# define POLYSFMT "d"
#endif
#elif (defined(PRIuPTR))
# define POLYUFMT PRIuPTR
# define POLYSFMT PRIdPTR
#elif (defined(_MSC_VER) && (SIZEOF_POLYWORD == 8))
# define POLYUFMT "llu"
# define POLYSFMT "lld"
#else
# define POLYUFMT "lu" // as before. Cross your fingers.
# define POLYSFMT "ld" // idem.
#endif
// We can use the C99 %zu in most cases except MingW since it uses
// the old msvcrt and that only supports C89.
-#if (defined(_WIN32) && ! defined(__CYGWIN__) && (! defined(_MSC_VER) || _MSC_VER < 1800))
+#if (defined(_WIN32) && (! defined(_MSC_VER) || _MSC_VER < 1800))
# if (SIZEOF_VOIDP == 8)
# define PRI_SIZET PRIu64
# else
# define PRI_SIZET PRIu32
# endif
#else
# define PRI_SIZET "zu"
#endif
typedef unsigned char byte;
class PolyObject;
typedef PolyObject *POLYOBJPTR;
#ifdef POLYML32IN64
class PolyWord;
extern PolyWord *globalHeapBase, *globalCodeBase;
typedef uint32_t POLYOBJECTPTR; // This is an index into globalHeapBase
// If a 64-bit value if in the range of the object pointers.
inline bool IsHeapAddress(void *addr) { return (uintptr_t)addr <= 0xffffffff; }
#else
typedef POLYOBJPTR POLYOBJECTPTR;
inline bool IsHeapAddress(void *) { return true; }
#endif
typedef byte *POLYCODEPTR;
class PolyWord {
public:
// Initialise to TAGGED(0). This is very rarely used.
PolyWord() { contents.unsignedInt = 1; }
// Integers need to be tagged.
static PolyWord TaggedInt(POLYSIGNED s) { return PolyWord((s << POLY_TAGSHIFT) | (POLYSIGNED)0x01); }
static PolyWord TaggedUnsigned(POLYUNSIGNED u) { return PolyWord((u << POLY_TAGSHIFT) | 0x01); }
static PolyWord FromStackAddr(PolyWord *sp) { return PolyWord(sp); }
static PolyWord FromCodePtr(POLYCODEPTR p) { return PolyWord(p); }
// Tests for the various cases.
bool IsTagged(void) const { return (contents.unsignedInt & 1) != 0; }
#ifndef POLYML32IN64
// In native 32-bit and 64-bit addresses are on word boundaries
bool IsDataPtr(void) const { return (contents.unsignedInt & (sizeof(PolyWord) - 1)) == 0; }
#else
// In 32-in-64 addresses are anything that isn't tagged.
bool IsDataPtr(void) const { return (contents.unsignedInt & 1) == 0; }
#ifdef POLYML32IN64DEBUG
static POLYOBJECTPTR AddressToObjectPtr(void *address);
#else
static POLYOBJECTPTR AddressToObjectPtr(void *address)
{ return (POLYOBJECTPTR)((PolyWord*)address - globalHeapBase); }
#endif
#endif
// Extract the various cases.
POLYSIGNED UnTagged(void) const { return contents.signedInt >> POLY_TAGSHIFT; }
POLYUNSIGNED UnTaggedUnsigned(void) const { return contents.unsignedInt >> POLY_TAGSHIFT; }
#ifdef POLYML32IN64
PolyWord(POLYOBJPTR p) { contents.objectPtr = AddressToObjectPtr(p); }
PolyWord *AsStackAddr(PolyWord *base = globalHeapBase) const { return base + contents.objectPtr; }
POLYOBJPTR AsObjPtr(PolyWord *base = globalHeapBase) const { return (POLYOBJPTR)AsStackAddr(base); }
#else
// An object pointer can become a word directly.
PolyWord(POLYOBJPTR p) { contents.objectPtr = p; }
POLYOBJPTR AsObjPtr(PolyWord *base = 0) const { return contents.objectPtr; }
PolyWord *AsStackAddr(PolyWord *base=0) const { return (PolyWord *)contents.objectPtr; }
#endif
POLYCODEPTR AsCodePtr(void) const { return (POLYCODEPTR)AsObjPtr(); }
void *AsAddress(void)const { return AsCodePtr(); }
// There are a few cases where we need to store and extract untagged values
static PolyWord FromUnsigned(POLYUNSIGNED u) { return PolyWord(u); }
static PolyWord FromSigned(POLYSIGNED s) { return PolyWord(s); }
POLYUNSIGNED AsUnsigned(void) const { return contents.unsignedInt; }
POLYSIGNED AsSigned(void) const { return contents.signedInt; }
protected:
PolyWord(POLYSIGNED s) { contents.signedInt = s; }
PolyWord(POLYUNSIGNED u) { contents.unsignedInt = u; }
public:
bool operator == (PolyWord b) const { return contents.unsignedInt == b.contents.unsignedInt; }
bool operator != (PolyWord b) const { return contents.unsignedInt != b.contents.unsignedInt; }
protected:
#ifdef POLYML32IN64
PolyWord(PolyWord *sp) { contents.objectPtr = AddressToObjectPtr(sp); }
PolyWord(POLYCODEPTR p) { contents.objectPtr = AddressToObjectPtr(p); }
#else
PolyWord(PolyWord *sp) { contents.objectPtr = (PolyObject*)sp; }
PolyWord(POLYCODEPTR p) { contents.objectPtr = (PolyObject*)p; }
#endif
union {
POLYSIGNED signedInt; // A tagged integer - lowest bit set
POLYUNSIGNED unsignedInt; // A tagged integer - lowest bit set
POLYOBJECTPTR objectPtr; // Object pointer - lowest bit clear.
} contents;
};
//typedef PolyWord POLYWORD;
inline bool OBJ_IS_AN_INTEGER(const PolyWord & a) { return a.IsTagged(); }
inline bool OBJ_IS_DATAPTR(const PolyWord & a) { return a.IsDataPtr(); }
// The maximum tagged signed number is one less than 0x80 shifted into the top byte then shifted down
// by the tag shift.
#define MAXTAGGED (((POLYSIGNED)0x80 << (POLYSIGNED)(8*(sizeof(PolyWord)-1) -POLY_TAGSHIFT)) -1)
inline PolyWord TAGGED(POLYSIGNED a) { return PolyWord::TaggedInt(a); }
inline POLYSIGNED UNTAGGED(PolyWord a) { return a.UnTagged(); }
inline POLYUNSIGNED UNTAGGED_UNSIGNED(PolyWord a) { return a.UnTaggedUnsigned(); }
#define IS_INT(x) ((x).IsTagged())
/* length word flags */
#define OBJ_PRIVATE_FLAGS_SHIFT (8 * (sizeof(PolyWord) - 1))
#define _TOP_BYTE(x) ((POLYUNSIGNED)(x) << OBJ_PRIVATE_FLAGS_SHIFT)
// Bottom two bits define the content format.
// Zero bits mean ordinary word object containing addresses or tagged integers.
#define F_BYTE_OBJ 0x01 /* byte object (contains no pointers) */
#define F_CODE_OBJ 0x02 /* code object (mixed bytes and words) */
#define F_CLOSURE_OBJ 0x03 /* closure (32-in-64 only). First word is code addr. */
#define F_GC_MARK 0x04 // Used during the GC marking phase
#define F_NO_OVERWRITE 0x08 /* don't overwrite when loading - mutables only. */
// This bit is overloaded and has different meanings depending on what other bits are set.
// For byte objects it is the sign bit for arbitrary precision ints.
// For other data it indicates either that the object is a profile block or contains
// information for allocation profiling.
#define F_NEGATIVE_BIT 0x10 // Sign bit for arbitrary precision ints (byte segs only)
#define F_PROFILE_BIT 0x10 // Object has a profile pointer (word segs only)
#define F_WEAK_BIT 0x20 /* object contains weak references to option values. */
// The Weak bit is only used on mutables. The data sharing (sharedata.cpp) uses this with
// immutables to indicate that the length field is being used to store the "depth".
#define F_MUTABLE_BIT 0x40 /* object is mutable */
#define F_TOMBSTONE_BIT 0x80 // Object is a forwarding pointer
#define F_PRIVATE_FLAGS_MASK 0xFF
// Shifted bits
#define _OBJ_BYTE_OBJ _TOP_BYTE(F_BYTE_OBJ) /* byte object (contains no pointers) */
#define _OBJ_CODE_OBJ _TOP_BYTE(F_CODE_OBJ) /* code object (mixed bytes and words) */
#define _OBJ_CLOSURE_OBJ _TOP_BYTE(F_CLOSURE_OBJ) // closure (32-in-64 only). First word is code addr.
#define _OBJ_GC_MARK _TOP_BYTE(F_GC_MARK) // Mark bit
#define _OBJ_NO_OVERWRITE _TOP_BYTE(F_NO_OVERWRITE) /* don't overwrite when loading - mutables only. */
#define _OBJ_NEGATIVE_BIT _TOP_BYTE(F_NEGATIVE_BIT) /* sign bit for arbitrary precision ints */
#define _OBJ_PROFILE_BIT _TOP_BYTE(F_PROFILE_BIT) /* sign bit for arbitrary precision ints */
#define _OBJ_WEAK_BIT _TOP_BYTE(F_WEAK_BIT)
#define _OBJ_MUTABLE_BIT _TOP_BYTE(F_MUTABLE_BIT) /* object is mutable */
#define _OBJ_TOMBSTONE_BIT _TOP_BYTE(F_TOMBSTONE_BIT) // object is a tombstone.
#define _OBJ_PRIVATE_FLAGS_MASK _TOP_BYTE(F_PRIVATE_FLAGS_MASK)
#define _OBJ_PRIVATE_LENGTH_MASK ((-1) ^ _OBJ_PRIVATE_FLAGS_MASK)
#define MAX_OBJECT_SIZE _OBJ_PRIVATE_LENGTH_MASK
//
inline bool OBJ_IS_LENGTH(POLYUNSIGNED L) { return ((L & _OBJ_TOMBSTONE_BIT) == 0); }
/* these should only be applied to proper length words */
/* discards GC flag, mutable bit and weak bit. */
inline byte GetTypeBits(POLYUNSIGNED L) { return (byte)(L >> OBJ_PRIVATE_FLAGS_SHIFT) & 0x03; }
inline POLYUNSIGNED OBJ_OBJECT_LENGTH(POLYUNSIGNED L) { return L & _OBJ_PRIVATE_LENGTH_MASK; }
inline bool OBJ_IS_BYTE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_BYTE_OBJ); }
inline bool OBJ_IS_CODE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_CODE_OBJ); }
inline bool OBJ_IS_CLOSURE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_CLOSURE_OBJ); }
inline bool OBJ_IS_NO_OVERWRITE(POLYUNSIGNED L) { return ((L & _OBJ_NO_OVERWRITE) != 0); }
inline bool OBJ_IS_NEGATIVE(POLYUNSIGNED L) { return ((L & _OBJ_NEGATIVE_BIT) != 0); }
inline bool OBJ_HAS_PROFILE(POLYUNSIGNED L) { return ((L & _OBJ_PROFILE_BIT) != 0); }
inline bool OBJ_IS_MUTABLE_OBJECT(POLYUNSIGNED L) { return ((L & _OBJ_MUTABLE_BIT) != 0); }
inline bool OBJ_IS_WEAKREF_OBJECT(POLYUNSIGNED L) { return ((L & _OBJ_WEAK_BIT) != 0); }
/* Don't need to worry about whether shift is signed,
because OBJ_PRIVATE_USER_FLAGS_MASK removes the sign bit.
We don't want the GC bit (which should be 0) anyway.
*/
#define OBJ_PRIVATE_USER_FLAGS_MASK _TOP_BYTE(0x7F)
#define OBJ_IS_WORD_OBJECT(L) (GetTypeBits(L) == 0)
/* case 2 - forwarding pointer */
inline bool OBJ_IS_POINTER(POLYUNSIGNED L) { return (L & _OBJ_TOMBSTONE_BIT) != 0; }
#ifdef POLYML32IN64
inline PolyObject *OBJ_GET_POINTER(POLYUNSIGNED L) { return (PolyObject*)(globalHeapBase + ((L & ~_OBJ_TOMBSTONE_BIT) << 1)); }
inline POLYUNSIGNED OBJ_SET_POINTER(PolyObject *pt) { return PolyWord::AddressToObjectPtr(pt) >> 1 | _OBJ_TOMBSTONE_BIT; }
#else
inline PolyObject *OBJ_GET_POINTER(POLYUNSIGNED L) { return (PolyObject*)(( L & ~_OBJ_TOMBSTONE_BIT) <<2); }
inline POLYUNSIGNED OBJ_SET_POINTER(PolyObject *pt) { return ((POLYUNSIGNED)pt >> 2) | _OBJ_TOMBSTONE_BIT; }
#endif
// An object i.e. a piece of allocated memory in the heap. In the simplest case this is a
// tuple, a list cons cell, a string or a ref. Every object has a length word in the word before
// where its address points. The top byte of this contains flags.
class PolyObject {
public:
byte *AsBytePtr(void)const { return (byte*)this; }
PolyWord *AsWordPtr(void)const { return (PolyWord*)this; }
POLYUNSIGNED LengthWord(void)const { return ((PolyWord*)this)[-1].AsUnsigned(); }
POLYUNSIGNED Length(void)const { return OBJ_OBJECT_LENGTH(LengthWord()); }
// Get and set a word
PolyWord Get(POLYUNSIGNED i) const { return ((PolyWord*)this)[i]; }
void Set(POLYUNSIGNED i, PolyWord v) { ((PolyWord*)this)[i] = v; }
PolyWord *Offset(POLYUNSIGNED i) const { return ((PolyWord*)this)+i; }
// Create a length word from a length and the flags in the top byte.
void SetLengthWord(POLYUNSIGNED l, byte f)
{ ((POLYUNSIGNED*)this)[-1] = l | ((POLYUNSIGNED)f << OBJ_PRIVATE_FLAGS_SHIFT); }
void SetLengthWord(POLYUNSIGNED l) { ((PolyWord*)this)[-1] = PolyWord::FromUnsigned(l); }
bool IsByteObject(void) const { return OBJ_IS_BYTE_OBJECT(LengthWord()); }
bool IsCodeObject(void) const { return OBJ_IS_CODE_OBJECT(LengthWord()); }
bool IsClosureObject(void) const { return OBJ_IS_CLOSURE_OBJECT(LengthWord()); }
bool IsWordObject(void) const { return OBJ_IS_WORD_OBJECT(LengthWord()); }
bool IsMutable(void) const { return OBJ_IS_MUTABLE_OBJECT(LengthWord()); }
bool IsWeakRefObject(void) const { return OBJ_IS_WEAKREF_OBJECT(LengthWord()); }
bool IsNoOverwriteObject(void) const { return OBJ_IS_NO_OVERWRITE(LengthWord()); }
bool ContainsForwardingPtr(void) const { return OBJ_IS_POINTER(LengthWord()); }
PolyObject *GetForwardingPtr(void) const { return OBJ_GET_POINTER(LengthWord()); }
void SetForwardingPtr(PolyObject *newp) { ((PolyWord*)this)[-1] = PolyWord::FromUnsigned(OBJ_SET_POINTER(newp)); }
bool ContainsNormalLengthWord(void) const { return OBJ_IS_LENGTH(LengthWord()); }
// Find the start of the constant section for a piece of code.
// The first of these is really only needed because we may have objects whose length
// words have been overwritten.
void GetConstSegmentForCode(POLYUNSIGNED obj_length, PolyWord * &cp, POLYUNSIGNED &count) const
{
PolyWord *last_word = Offset(obj_length - 1); // Last word in the code
count = last_word->AsUnsigned(); // This is the number of consts
cp = last_word - count;
}
void GetConstSegmentForCode(PolyWord * &cp, POLYUNSIGNED &count) const
{
GetConstSegmentForCode(Length(), cp, count);
}
PolyWord *ConstPtrForCode(void) const
{
PolyWord *cp; POLYUNSIGNED count;
GetConstSegmentForCode(cp, count);
return cp;
}
// Follow a chain of forwarding pointers
PolyObject *FollowForwardingChain(void)
{
if (ContainsForwardingPtr())
return GetForwardingPtr()->FollowForwardingChain();
else return this;
}
};
/* There was a problem with version 2.95 on Sparc/Solaris at least. The PolyObject
class has no members so classes derived from it e.g. ML_Cons_Cell should begin at
the beginning of the object. Later versions of GCC get this right. */
#if defined(__GNUC__) && (__GNUC__ <= 2)
#error Poly/ML requires GCC version 3 or newer
#endif
inline POLYUNSIGNED GetLengthWord(PolyWord p) { return p.AsObjPtr()->LengthWord(); }
// Get the length of an object.
inline POLYUNSIGNED OBJECT_LENGTH(PolyWord p) { return OBJ_OBJECT_LENGTH(GetLengthWord(p)); }
// A list cell. This can be passed to or returned from certain RTS functions.
class ML_Cons_Cell: public PolyObject {
public:
PolyWord h;
PolyWord t;
#define ListNull (TAGGED(0))
static bool IsNull(PolyWord p) { return p == ListNull; }
};
/* An exception packet. This contains an identifier (either a tagged integer for RTS
exceptions or the address of a mutable for those created within ML), a string
name for printing and an exception argument value. */
class PolyException: public PolyObject {
public:
PolyWord ex_id; /* Exc identifier */
PolyWord ex_name;/* Exc name */
PolyWord arg; /* Exc arguments */
PolyWord ex_location; // Location of "raise". Always zero for RTS exceptions.
};
typedef PolyException poly_exn;
/* Macro to round a number of bytes up to a number of words. */
#define WORDS(s) ((s+sizeof(PolyWord)-1)/sizeof(PolyWord))
/**********************************************************************
*
* Representation of option type.
*
**********************************************************************/
#define NONE_VALUE (TAGGED(0))
/* SOME x is represented by a single word cell containing x. */
#if (defined(_WIN32))
/* Windows doesn't include 0x in %p format. */
#define ZERO_X "0x"
#else
#define ZERO_X ""
#endif
#endif
diff --git a/libpolyml/heapsizing.cpp b/libpolyml/heapsizing.cpp
index eb5e6fe6..5b7f0474 100644
--- a/libpolyml/heapsizing.cpp
+++ b/libpolyml/heapsizing.cpp
@@ -1,991 +1,991 @@
/*
Title: heapsizing.cpp - parameters to adjust heap size
Copyright (c) Copyright David C.J. Matthews 2012, 2015, 2017
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
/*
This module is intended to deal with heap sizing based on measurements of the time taken
in the GC compared with the application code. Currently it is very basic.
This also provides GC timing information to the ML code as well as statistics and
debugging.
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_WINDOWS_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include // For sysconf
#endif
#ifdef HAVE_SYS_TYPES_H
#include
#endif
#ifdef HAVE_SYS_SYSCTL_H
#include
#endif
#ifdef HAVE_FLOAT_H
#include
#endif
#ifdef HAVE_MATH_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
#include "globals.h"
#include "arb.h"
#include "diagnostics.h"
#include "rts_module.h"
#include "timing.h"
#include "heapsizing.h"
#include "statistics.h"
#include "memmgr.h"
// The one and only parameter object
HeapSizeParameters gHeapSizeParameters;
#ifdef HAVE_WINDOWS_H
// There's no (documented) way to get the per-process hard page
// count in Windows. Cygwin uses GetProcessMemoryInfo to return the
// value in ru_majflt but this is actually incorrect because it returns
// the soft page count not the hard page count. We previously used the
// undocumented NtQuerySystemInformation call.
static long GetPaging(long)
{
return 0;
}
#else
inline long GetPaging(long rusagePage)
{
return rusagePage;
}
#endif
HeapSizeParameters::HeapSizeParameters()
{
startPF = GetPaging(0);
fullGCNextTime = false;
performSharingPass = false;
lastAllocationSucceeded = true;
allocationFailedBeforeLastMajorGC = false;
minHeapSize = 0;
maxHeapSize = 0; // Unlimited
lastFreeSpace = 0;
pagingLimitSize = 0;
highWaterMark = 0;
sharingWordsRecovered = 0;
cumulativeSharingSaving = 0;
// Initial values until we've actually done a sharing pass.
sharingRecoveryRate = 0.5; // The structure sharing recovers half the heap.
sharingCostFactor = 2; // It doubles the cost
}
// These macros were originally in globals.h and used more generally.
// Since only K_to_words is used now this can be greatly simplified.
#define BITSPERWORD (sizeof(PolyWord)*8)
#define ROUNDUP_UNITS(m,n) (((m) + (n) - 1) / (n))
#define ROUNDUP(m,n) (ROUNDUP_UNITS(m,n) * (n))
#define K_to_words(k) ROUNDUP((k) * (1024 / sizeof(PolyWord)),BITSPERWORD)
// Returns physical memory size in bytes
static size_t GetPhysicalMemorySize(void);
// These are the maximum values for the number of words.
#if (SIZEOF_VOIDP == 4)
# define MAXIMUMADDRESS 0x3fffffff /* 4Gbytes as words */
#elif defined(POLYML32IN64)
# define MAXIMUMADDRESS 0xffffffff /* 16Gbytes as words */
#else
# define MAXIMUMADDRESS 0x1fffffffffffffff
#endif
// Set the initial size based on any parameters specified on the command line.
// Any of these can be zero indicating they should default.
void HeapSizeParameters::SetHeapParameters(uintptr_t minsize, uintptr_t maxsize, uintptr_t initialsize, unsigned percent)
{
minHeapSize = K_to_words(minsize); // If these overflow assume the result will be zero
maxHeapSize = K_to_words(maxsize);
uintptr_t initialSize = K_to_words(initialsize);
uintptr_t memsize = GetPhysicalMemorySize() / sizeof(PolyWord);
// If no maximum is given default it to 80% of the physical memory.
// This allows some space for the OS and other things.
// We now check maxsize so it should never exceed the maximum.
if (maxHeapSize == 0 || maxHeapSize > MAXIMUMADDRESS)
{
if (memsize != 0)
maxHeapSize = memsize - memsize / 5;
else maxHeapSize = MAXIMUMADDRESS;
// But if this must not be smaller than the minimum size.
if (maxHeapSize < minHeapSize) maxHeapSize = minHeapSize;
if (maxHeapSize < initialSize) maxHeapSize = initialSize;
}
// The default minimum is zero; in practice the live data size.
// The default initial size is the minimum if that has been provided,
// otherwise 8M words. There are applications that only require a small
// heap and if we set the heap large to begin with we'll never do a
// full GC and reduce it.
if (initialSize == 0)
{
if (minHeapSize != 0)
initialSize = minHeapSize;
else initialSize = 8 * gMem.DefaultSpaceSize();
// But not more than the maximum
if (initialSize > maxHeapSize) initialSize = maxHeapSize;
}
// Together with the constraints on user settings that ensures this holds.
ASSERT(initialSize >= minHeapSize && initialSize <= maxHeapSize);
// Initially we divide the space equally between the major and
// minor heaps. That means that there will definitely be space
// for the first minor GC to copy its data. This division can be
// changed later on.
gMem.SetSpaceForHeap(initialSize);
gMem.SetSpaceBeforeMinorGC(initialSize/2);
lastFreeSpace = initialSize;
highWaterMark = initialSize;
if (percent == 0)
userGCRatio = 1.0 / 9.0; // Default to 10% GC to 90% application
else
userGCRatio = (float)percent / (float)(100 - percent);
predictedRatio = lastMajorGCRatio = userGCRatio;
if (debugOptions & DEBUG_HEAPSIZE)
{
Log("Heap: Initial settings: Initial heap ");
LogSize(initialSize);
Log(" minimum ");
LogSize(minHeapSize);
Log(" maximum ");
LogSize(maxHeapSize);
Log(" target ratio %f\n", userGCRatio);
}
}
void HeapSizeParameters::SetReservation(uintptr_t rsize)
{
gMem.SetReservation(K_to_words(rsize));
}
// Called in the minor GC if a GC thread needs to grow the heap.
// Returns zero if the heap cannot be grown. "space" is the space required for the
// object (and length field) in case this is larger than the default size.
LocalMemSpace *HeapSizeParameters::AddSpaceInMinorGC(uintptr_t space, bool isMutable)
{
// See how much space is allocated to the major heap.
uintptr_t spaceAllocated = gMem.CurrentHeapSize() - gMem.CurrentAllocSpace();
// The new segment is either the default size or as large as
// necessary for the object.
uintptr_t spaceSize = gMem.DefaultSpaceSize();
#ifdef POLYML32IN64
// When we allocate a space in NewLocalSpace we take one word to ensure
// the that the first length word is on an odd-word boundary.
// We need to add one here to ensure there is sufficient space to do that.
// See AllocHeapSpace
space++;
#endif
if (space > spaceSize) spaceSize = space;
// We allow for extension if the total heap size after extending it
// plus one allocation area of the default size would not be more
// than the allowed heap size.
if (spaceAllocated + spaceSize + gMem.DefaultSpaceSize() <= gMem.SpaceForHeap())
{
LocalMemSpace *sp = gMem.NewLocalSpace(spaceSize, isMutable); // Return the space or zero if it failed
// If this is the first time the allocation failed report it.
if (sp == 0 && (debugOptions & DEBUG_HEAPSIZE) && lastAllocationSucceeded)
{
Log("Heap: Allocation of new heap segment size ");
LogSize(spaceSize);
Log(" failed. Limit reached?\n");
}
lastAllocationSucceeded = sp != 0;
return sp;
}
return 0; // Insufficient space
}
// Called in the major GC before the copy phase if the heap is more than
// 90% full. This should improve the efficiency of copying.
LocalMemSpace *HeapSizeParameters::AddSpaceBeforeCopyPhase(bool isMutable)
{
LocalMemSpace *sp = gMem.NewLocalSpace(gMem.DefaultSpaceSize(), isMutable);
if (sp == 0 && (debugOptions & DEBUG_HEAPSIZE) && lastAllocationSucceeded)
Log("Heap: Allocation of new heap segment failed. Limit reached?\n");
lastAllocationSucceeded = sp != 0;
return sp;
}
// The steepness of the curve.
#define PAGINGCOSTSTEEPNESS 20.0
// The additional cost at the boundary
#define PAGINGCOSTFACTOR 3.0
// The number of pages at the boundary
#define PAGINGCOUNTFACTOR 1000.0
// Called at the end of collection. This is where we should do the
// fine adjustment of the heap size to minimise the GC time.
// Growing the heap is just a matter of adjusting the limits. We
// don't actually need to allocate the space here.
// See also adjustHeapSizeAfterMinorGC for adjustments after a minor GC.
void HeapSizeParameters::AdjustSizeAfterMajorGC(uintptr_t wordsRequired)
{
// Cumulative times since the last major GC
TIMEDATA gc, nonGc;
gc.add(majorGCSystemCPU);
gc.add(majorGCUserCPU);
nonGc.add(majorNonGCSystemCPU);
nonGc.add(majorNonGCUserCPU);
if (highWaterMark < heapSizeAtStart) highWaterMark = heapSizeAtStart;
uintptr_t heapSpace = gMem.SpaceForHeap() < highWaterMark ? gMem.SpaceForHeap() : highWaterMark;
currentSpaceUsed = wordsRequired;
for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
currentSpaceUsed += (*i)->allocatedSpace();
}
// N.B. Normally currentSpaceUsed will be less than the size of the heap
// except if wordsRequired is very large.
// The times for all the minor GCs up to this. The cost of this (major) GC
// is actually in minorGCUserCPU/minorGCSystemCPU.
TIMEDATA minorGC;
minorGC.add(gc);
minorGC.sub(minorGCUserCPU);
minorGC.sub(minorGCSystemCPU);
if (performSharingPass)
{
// We ran the sharing pass last time: calculate the actual recovery rate.
uintptr_t originalSpaceUsed = currentSpaceUsed + sharingWordsRecovered;
sharingRecoveryRate = (double)sharingWordsRecovered / (double)originalSpaceUsed;
if (debugOptions & DEBUG_HEAPSIZE)
Log("Heap: Sharing recovery rate was %0.3f and cost %0.3f seconds (%0.3f%% of total).\n",
sharingRecoveryRate, sharingCPU.toSeconds(), sharingCPU.toSeconds() / gc.toSeconds());
// The cost factor is the ratio of the cost of sharing to the cost without.
sharingCostFactor = sharingCPU.toSeconds() / (gc.toSeconds() - sharingCPU.toSeconds());
// Subtract the sharing cost from the GC cost because the initial estimate is
// the cost without running the sharing pass.
gc.sub(sharingCPU);
}
if (gc.toSeconds() != 0.0 && nonGc.toSeconds() != 0.0)
lastMajorGCRatio = gc.toSeconds() / nonGc.toSeconds();
if (debugOptions & DEBUG_HEAPSIZE)
{
uintptr_t currentFreeSpace = currentSpaceUsed < heapSpace ? 0: heapSpace - currentSpaceUsed;
Log("Heap: GC cpu time %2.3f non-gc time %2.3f ratio %0.3f for free space ",
gc.toSeconds(), nonGc.toSeconds(), lastMajorGCRatio);
LogSize((lastFreeSpace + currentFreeSpace)/2);
Log("\n");
Log("Heap: GC real time %2.3f non-gc time %2.3f ratio %0.3f\n",
majorGCReal.toSeconds(), majorNonGCReal.toSeconds(), majorGCReal.toSeconds()/majorNonGCReal.toSeconds());
Log("Heap: Total of minor GCs %2.3f, %2.3f of total\n", minorGC.toSeconds(), minorGC.toSeconds() / gc.toSeconds());
}
// Calculate the paging threshold.
if (pagingLimitSize != 0 || majorGCPageFaults != 0)
{
if (majorGCPageFaults == 0) majorGCPageFaults = 1; // Less than one
// Some paging detected. The expression here is the inverse of the one used to
// compute the paging contribution in the cost function.
double scaleFactor = 1.0 + log((double)majorGCPageFaults / PAGINGCOUNTFACTOR) / PAGINGCOSTSTEEPNESS;
ASSERT(scaleFactor > 0.0);
POLYUNSIGNED newLimit = (POLYUNSIGNED)((double)heapSpace / scaleFactor);
if (pagingLimitSize == 0)
pagingLimitSize = newLimit;
else
pagingLimitSize = (newLimit + pagingLimitSize) / 2;
}
if (allocationFailedBeforeLastMajorGC)
{
// If the last allocation failed then we may well have reached the
// maximum available memory. Set the paging limit to be the current
// heap size. We want to avoid hitting the limit because typically
// that happens when we try to extend the major heap in a minor GC
// resulting in the minor GC failing and a major GC starting.
if (pagingLimitSize == 0 || heapSizeAtStart < pagingLimitSize)
pagingLimitSize = heapSizeAtStart;
}
if (pagingLimitSize != 0 && (debugOptions & DEBUG_HEAPSIZE))
{
Log("Heap: Paging threshold adjusted to ");
LogSize(pagingLimitSize);
Log(" with %ld page faults\n", majorGCPageFaults);
}
// Calculate the new heap size and the predicted cost.
uintptr_t newHeapSize;
double cost;
bool atTarget = getCostAndSize(newHeapSize, cost, false);
// If we have been unable to allocate any more memory we may already
// be at the limit.
if (allocationFailedBeforeLastMajorGC && newHeapSize > heapSizeAtStart)
{
cost = costFunction(heapSizeAtStart, false, true);
atTarget = false;
}
if (atTarget)
{
// We are at the target level. We don't want to attempt sharing.
performSharingPass = false;
cumulativeSharingSaving = 0;
}
else
{
uintptr_t newHeapSizeWithSharing;
double costWithSharing;
// Get the cost and heap size if sharing was enabled. If we are at the
// limit, though, we need to work using the size we can achieve.
if (! allocationFailedBeforeLastMajorGC)
(void)getCostAndSize(newHeapSizeWithSharing, costWithSharing, true);
else
{
newHeapSizeWithSharing = heapSizeAtStart;
costWithSharing = costFunction(heapSizeAtStart, true, true);
}
// Run the sharing pass if that would give a lower cost.
// Subtract the cumulative saving that would have been made if the
// sharing had been run before. This is an estimate and depends on the
// extent to which a reduction in the heap earlier would be carried through
// to later GCs.
cumulativeSharingSaving =
cumulativeSharingSaving * ((double)currentSpaceUsed / (double)heapSpace);
if (debugOptions & DEBUG_HEAPSIZE)
Log("Heap: Cumulative sharing saving %0.2f\n", cumulativeSharingSaving);
if (costWithSharing - cumulativeSharingSaving < cost)
{
// Run the sharing pass next time.
performSharingPass = true;
cumulativeSharingSaving = 0;
}
else
{
// Don't run the sharing pass next time
performSharingPass = false;
// Running a sharing pass reduces the heap for subsequent
// runs. Add this into the cost.
double freeSharingCost = costFunction(newHeapSizeWithSharing, true, false);
if (freeSharingCost < cost && freeSharingCost > userGCRatio)
{
if (debugOptions & DEBUG_HEAPSIZE)
Log("Heap: Previous sharing would have saved %0.2f\n", cost - freeSharingCost);
cumulativeSharingSaving += cost - freeSharingCost;
}
}
}
if (debugOptions & DEBUG_HEAPSIZE)
{
if (performSharingPass)
Log("Heap: Next full GC will enable the sharing pass\n");
Log("Heap: Resizing from ");
LogSize(gMem.SpaceForHeap());
Log(" to ");
LogSize(newHeapSize);
Log(". Estimated ratio %2.2f\n", cost);
}
// Set the sizes.
gMem.SetSpaceForHeap(newHeapSize);
// Set the minor space size. It can potentially use the whole of the
// rest of the available heap but there could be a problem if that exceeds
// the available memory and causes paging. We need to raise the limit carefully.
// Also, if we use the whole of the heap we may not then be able to allocate
// new areas in the major heap without going over the limit. Restrict it to
// half of the available heap.
uintptr_t nextLimit = highWaterMark + highWaterMark / 32;
if (nextLimit > newHeapSize) nextLimit = newHeapSize;
// gMem.CurrentHeapSize() is the live space size.
if (gMem.CurrentHeapSize() > nextLimit)
gMem.SetSpaceBeforeMinorGC(0); // Run out of space
else gMem.SetSpaceBeforeMinorGC((nextLimit-gMem.CurrentHeapSize())/2);
lastFreeSpace = newHeapSize - currentSpaceUsed;
predictedRatio = cost;
}
// Called after a minor GC. Currently does nothing.
// See also adjustHeapSize for adjustments after a major GC.
bool HeapSizeParameters::AdjustSizeAfterMinorGC(uintptr_t spaceAfterGC, uintptr_t spaceBeforeGC)
{
uintptr_t spaceCopiedOut = spaceAfterGC-spaceBeforeGC;
TIMEDATA gc, total;
minorGCsSinceMajor++;
// The major costs are cumulative so we use those
gc.add(majorGCSystemCPU);
gc.add(majorGCUserCPU);
total.add(gc);
total.add(majorNonGCSystemCPU);
total.add(majorNonGCUserCPU);
float g = gc.toSeconds() / total.toSeconds();
if (debugOptions & DEBUG_HEAPSIZE)
{
Log("Heap: Space before ");
LogSize(spaceBeforeGC);
Log(", space after ");
LogSize(spaceAfterGC);
Log("\n");
Log("Heap: Minor resizing factors g = %f, recent pf = %ld, cumulative pf = %ld\n",
g, minorGCPageFaults, majorGCPageFaults);
}
if (highWaterMark < gMem.CurrentHeapSize()) highWaterMark = gMem.CurrentHeapSize();
uintptr_t nextLimit = highWaterMark + highWaterMark / 32;
if (nextLimit > gMem.SpaceForHeap()) nextLimit = gMem.SpaceForHeap();
// Set the space available for the allocation area to be the difference between the
// total heap size and the allowed heap size together with as much space as we copied
// on this GC. That allows for the next minor GC to copy the same amount without
// extending the heap. If the next minor GC adds more than this the heap will be
// extended and a corresponding amount deducted so that the heap shrinks again.
uintptr_t currHeap = gMem.CurrentHeapSize();
uintptr_t currAlloc = gMem.CurrentAllocSpace();
uintptr_t nonAlloc = currHeap - currAlloc + spaceCopiedOut;
// TODO: If we have limited the space to the high water mark + 1/32 but that is less
// than we really need we should increase it further.
uintptr_t allowedAlloc = nonAlloc >= nextLimit ? 0 : nextLimit - nonAlloc;
// Normally the allocation area will be empty but if we've failed to copy
// everything out, especially a big object, it may not be.
uintptr_t allocatedInAlloc = gMem.AllocatedInAlloc();
// If we hit the limit at the last major GC we have to be much more careful.
// If the minor GC cannot allocate a major GC space when it needs it the minor
// GC will fail immediately and a major GC will be started. It's better to
// risk doing more minor GCs than we need by making the allocation area smaller
// rather than run out of space.
if (allocationFailedBeforeLastMajorGC)
allowedAlloc = allowedAlloc / 2;
if (gMem.CurrentAllocSpace() - allocatedInAlloc != allowedAlloc)
{
if (debugOptions & DEBUG_HEAPSIZE)
{
Log("Heap: Adjusting space for allocation area from ");
LogSize(gMem.SpaceBeforeMinorGC());
Log(" to ");
LogSize(allowedAlloc);
Log("\n");
}
gMem.SetSpaceBeforeMinorGC(allowedAlloc);
if (allowedAlloc < gMem.DefaultSpaceSize() * 2 || minorGCPageFaults > 100)
return false; // Trigger full GC immediately.
}
// Trigger a full GC if the live data is very large or if we have exceeeded
// the target ratio over several GCs (this smooths out small variations).
if ((minorGCsSinceMajor > 4 && g > predictedRatio*0.8) || majorGCPageFaults > 100)
fullGCNextTime = true;
return true;
}
// Estimate the GC cost for a given heap size. The result is the ratio of
// GC time to application time.
// This is really guesswork.
double HeapSizeParameters::costFunction(uintptr_t heapSize, bool withSharing, bool withSharingCost)
{
uintptr_t heapSpace = gMem.SpaceForHeap() < highWaterMark ? gMem.SpaceForHeap() : highWaterMark;
uintptr_t currentFreeSpace = heapSpace < currentSpaceUsed ? 0: heapSpace - currentSpaceUsed;
uintptr_t averageFree = (lastFreeSpace + currentFreeSpace) / 2;
uintptr_t spaceUsed = currentSpaceUsed; // N.B. currentSpaceUsed includes the new space we want
if (heapSize <= currentSpaceUsed)
return 1.0E6;
// If we run the sharing pass the live space will be smaller.
if (withSharing)
spaceUsed -= (POLYUNSIGNED)((double)currentSpaceUsed * sharingRecoveryRate);
uintptr_t estimatedFree = heapSize - spaceUsed;
// The cost scales as the inverse of the amount of free space.
double result = lastMajorGCRatio * (double)averageFree / (double)estimatedFree;
// If we run the sharing pass the GC cost will increase.
if (withSharing && withSharingCost)
result += result*sharingCostFactor;
// The paging contribution depends on the page limit
double pagingCost = 0.0;
if (pagingLimitSize != 0)
{
double factor = ((double)heapSize - (double)pagingLimitSize) / (double)pagingLimitSize * PAGINGCOSTSTEEPNESS;
pagingCost = PAGINGCOSTFACTOR * exp(factor);
result += pagingCost;
}
if (debugOptions & DEBUG_HEAPSIZE)
{
Log("Heap: Cost for heap of size ");
LogSize(heapSize);
Log(" is %2.2f with paging contributing %2.2f with%s sharing pass.\n", result, pagingCost, withSharing ? "" : "out");
}
return result;
}
// Calculate the size for the minimum cost. Returns true if this is bounded by
// the user GC ratio and false if we minimised the cost
// TODO: This could definitely be improved although it's not likely to contribute much to
// the overall cost of a GC.
bool HeapSizeParameters::getCostAndSize(uintptr_t &heapSize, double &cost, bool withSharing)
{
bool isBounded = false;
uintptr_t heapSpace = gMem.SpaceForHeap() < highWaterMark ? gMem.SpaceForHeap() : highWaterMark;
// Calculate a new heap size. We allow a maximum doubling or halving of size.
// It's probably more important to limit the increase in case we hit paging.
uintptr_t sizeMax = heapSpace * 2;
if (sizeMax > maxHeapSize) sizeMax = maxHeapSize;
uintptr_t sizeMin = heapSpace / 2;
if (sizeMin < minHeapSize) sizeMin = minHeapSize;
// We mustn't reduce the heap size too far. If the application does a lot
// of work with few allocations and particularly if it calls PolyML.fullGC
// explicitly we could attempt to shrink the heap below the current live data size.
// Add 3*space size here. We require 2* after a minor GC. Add 1 for rounding.
uintptr_t minForAllocation = gMem.CurrentHeapSize() + gMem.DefaultSpaceSize() * 3;
if (minForAllocation > maxHeapSize) minForAllocation = maxHeapSize;
if (sizeMin < minForAllocation) sizeMin = minForAllocation;
double costMin = costFunction(sizeMin, withSharing, true);
if (costMin <= userGCRatio)
// If the cost of the minimum is below or at the target we
// use that and don't need to look further.
isBounded = true;
else
{
double costMax = costFunction(sizeMax, withSharing, true);
while (sizeMax > sizeMin + gMem.DefaultSpaceSize())
{
uintptr_t sizeNext = (sizeMin + sizeMax) / 2;
double cost = costFunction(sizeNext, withSharing, true);
if (cost < userGCRatio)
isBounded = true;
if (cost < userGCRatio || (costMax > costMin && costMax > userGCRatio))
{
sizeMax = sizeNext;
costMax = cost;
}
else
{
sizeMin = sizeNext;
costMin = cost;
}
ASSERT(costMin >= userGCRatio);
}
}
ASSERT(sizeMin >= minHeapSize && sizeMin <= maxHeapSize);
// If we are bounded by the user GC ratio we actually return the size and cost
// that is slightly above the user ratio.
heapSize = sizeMin;
cost = costMin;
return isBounded;
}
bool HeapSizeParameters::RunMajorGCImmediately()
{
if (fullGCNextTime)
{
fullGCNextTime = false;
return true;
}
return false;
}
static bool GetLastStats(TIMEDATA &userTime, TIMEDATA &systemTime, TIMEDATA &realTime, long &pageCount)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
FILETIME kt, ut;
FILETIME ct, et; // Unused
FILETIME rt;
GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut);
GetSystemTimeAsFileTime(&rt);
userTime = ut;
systemTime = kt;
realTime = rt;
pageCount = GetPaging(0);
#else
struct rusage rusage;
if (getrusage(RUSAGE_SELF, &rusage) != 0)
return false;
userTime = rusage.ru_utime;
systemTime = rusage.ru_stime;
struct timeval tv;
if (gettimeofday(&tv, NULL) != 0)
return false;
realTime = tv;
pageCount = GetPaging(rusage.ru_majflt);
#endif
return true;
}
void HeapSizeParameters::RecordAtStartOfMajorGC()
{
heapSizeAtStart = gMem.CurrentHeapSize();
allocationFailedBeforeLastMajorGC = !lastAllocationSucceeded;
}
// This function is called at the beginning and end of garbage
// collection to record the time used.
// This also reports the GC time if GC debugging is enabled.
void HeapSizeParameters::RecordGCTime(gcTime isEnd, const char *stage)
{
switch (isEnd)
{
case GCTimeStart:
{
// Start of GC
TIMEDATA userTime, systemTime, realTime;
long pageCount;
if (! GetLastStats(userTime, systemTime, realTime, pageCount))
break;
lastUsageU = userTime;
lastUsageS = systemTime;
lastRTime = realTime;
userTime.sub(startUsageU); // Times since the start
systemTime.sub(startUsageS);
realTime.sub(startRTime);
if (debugOptions & DEBUG_GC)
Log("GC: Non-GC time: CPU user: %0.3f system: %0.3f real: %0.3f page faults: %ld\n",
userTime.toSeconds(), systemTime.toSeconds(), realTime.toSeconds(), pageCount - startPF);
minorNonGCUserCPU.add(userTime);
majorNonGCUserCPU.add(userTime);
minorNonGCSystemCPU.add(systemTime);
majorNonGCSystemCPU.add(systemTime);
minorNonGCReal.add(realTime);
majorNonGCReal.add(realTime);
startUsageU = lastUsageU;
startUsageS = lastUsageS;
startRTime = lastRTime;
// Page faults in the application are included
minorGCPageFaults += pageCount - startPF;
majorGCPageFaults += pageCount - startPF;
startPF = pageCount;
break;
}
case GCTimeIntermediate:
// Report intermediate GC time for debugging
if (debugOptions & DEBUG_GC)
{
TIMEDATA userTime, systemTime, realTime;
long pageCount;
if (! GetLastStats(userTime, systemTime, realTime, pageCount))
break;
TIMEDATA nextU = userTime, nextS = systemTime, nextR = realTime;
userTime.sub(lastUsageU);
systemTime.sub(lastUsageS);
realTime.sub(lastRTime);
Log("GC: (%s) CPU user: %0.3f system: %0.3f real: %0.3f speed up %0.1f\n", stage, userTime.toSeconds(),
systemTime.toSeconds(), realTime.toSeconds(),
realTime.toSeconds() == 0.0 ? 0.0 : (userTime.toSeconds() + systemTime.toSeconds()) / realTime.toSeconds());
lastUsageU = nextU;
lastUsageS = nextS;
lastRTime = nextR;
}
break;
case GCTimeEnd: // End of GC.
{
TIMEDATA userTime, systemTime, realTime;
long pageCount;
if (! GetLastStats(userTime, systemTime, realTime, pageCount))
break;
lastUsageU = userTime;
lastUsageS = systemTime;
lastRTime = realTime;
userTime.sub(startUsageU); // Times since the start
systemTime.sub(startUsageS);
realTime.sub(startRTime);
totalGCUserCPU.add(userTime);
totalGCSystemCPU.add(systemTime);
totalGCReal.add(realTime);
if (debugOptions & DEBUG_GC)
{
Log("GC: CPU user: %0.3f system: %0.3f real: %0.3f speed up %0.1f page faults %ld\n", userTime.toSeconds(),
systemTime.toSeconds(), realTime.toSeconds(),
realTime.toSeconds() == 0.0 ? 0.0 : (userTime.toSeconds() + systemTime.toSeconds()) / realTime.toSeconds(),
pageCount - startPF);
}
minorGCUserCPU.add(userTime);
majorGCUserCPU.add(userTime);
minorGCSystemCPU.add(systemTime);
majorGCSystemCPU.add(systemTime);
minorGCReal.add(realTime);
majorGCReal.add(realTime);
startUsageU = lastUsageU;
startUsageS = lastUsageS;
startRTime = lastRTime;
minorGCPageFaults += pageCount - startPF;
majorGCPageFaults += pageCount - startPF;
startPF = pageCount;
globalStats.copyGCTimes(totalGCUserCPU, totalGCSystemCPU, totalGCReal);
}
break;
}
}
// Record the recovery rate and cost after running the GC sharing pass.
// TODO: We should probably average these because if we've run a full
// sharing pass and then a full GC after the recovery rate will be zero.
void HeapSizeParameters::RecordSharingData(POLYUNSIGNED recovery)
{
sharingWordsRecovered = recovery;
TIMEDATA userTime, systemTime, realTime;
long pageCount;
if (! GetLastStats(userTime, systemTime, realTime, pageCount))
return;
userTime.sub(startUsageU); // Times since the start
systemTime.sub(startUsageS);
sharingCPU = userTime;
sharingCPU.add(systemTime);
}
Handle HeapSizeParameters::getGCUtime(TaskData *taskData) const
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
return Make_arb_from_Filetime(taskData, totalGCUserCPU);
#else
return Make_arb_from_pair_scaled(taskData, ((struct timeval)totalGCUserCPU).tv_sec, ((struct timeval)totalGCUserCPU).tv_usec, 1000000);
#endif
}
Handle HeapSizeParameters::getGCStime(TaskData *taskData) const
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
return Make_arb_from_Filetime(taskData, totalGCSystemCPU);
#else
return Make_arb_from_pair_scaled(taskData, ((struct timeval)totalGCSystemCPU).tv_sec, ((struct timeval)totalGCSystemCPU).tv_usec, 1000000);
#endif
}
void HeapSizeParameters::Init()
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
// Record an initial time of day to use as the basis of real timing
FILETIME s;
GetSystemTimeAsFileTime(&s);
#else
struct timeval s;
gettimeofday(&s, NULL);
#endif
startTime = s; // Overall start time
startRTime = startTime; // Start of this non-gc phase
resetMajorTimingData();
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
startPF = GetPaging(0);
#else
startPF = GetPaging(0);
#endif
}
void HeapSizeParameters::Final()
{
// Print the overall statistics
if (debugOptions & (DEBUG_GC|DEBUG_HEAPSIZE))
{
TIMEDATA userTime, systemTime, realTime;
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
FILETIME kt, ut;
FILETIME ct, et; // Unused
FILETIME rt;
GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut);
GetSystemTimeAsFileTime(&rt);
userTime.add(ut);
systemTime.add(kt);
realTime.add(rt);
#else
struct rusage rusage;
struct timeval tv;
if (getrusage(RUSAGE_SELF, &rusage) != 0 || gettimeofday(&tv, NULL) != 0)
return;
userTime.add(rusage.ru_utime);
systemTime.add(rusage.ru_stime);
realTime.add(tv);
#endif
realTime.sub(startTime);
userTime.sub(totalGCUserCPU);
systemTime.sub(totalGCSystemCPU);
realTime.sub(totalGCReal);
if (debugOptions & DEBUG_GC)
{
Log("GC (Total): Non-GC time: CPU user: %0.3f system: %0.3f real: %0.3f\n",
userTime.toSeconds(), systemTime.toSeconds(), realTime.toSeconds());
Log("GC (Total): GC time: CPU user: %0.3f system: %0.3f real: %0.3f\n",
totalGCUserCPU.toSeconds(), totalGCSystemCPU.toSeconds(), totalGCReal.toSeconds());
}
if (debugOptions & DEBUG_HEAPSIZE)
{
TIMEDATA gc, nonGc;
gc.add(totalGCUserCPU);
gc.add(totalGCSystemCPU);
nonGc.add(userTime);
nonGc.add(systemTime);
Log("Heap: Total CPU GC time %0.3fsecs, Non-GC %0.3fsecs, ratio %0.3f\n",
gc.toSeconds(), nonGc.toSeconds(), gc.toSeconds() / nonGc.toSeconds());
}
}
}
void HeapSizeParameters::resetMinorTimingData(void)
{
minorNonGCUserCPU.fromSeconds(0);
minorNonGCSystemCPU.fromSeconds(0);
minorNonGCReal.fromSeconds(0);
minorGCUserCPU.fromSeconds(0);
minorGCSystemCPU.fromSeconds(0);
minorGCReal.fromSeconds(0);
minorGCPageFaults = 0;
}
void HeapSizeParameters::resetMajorTimingData(void)
{
resetMinorTimingData();
majorNonGCUserCPU.fromSeconds(0);
majorNonGCSystemCPU.fromSeconds(0);
majorNonGCReal.fromSeconds(0);
majorGCUserCPU.fromSeconds(0);
majorGCSystemCPU.fromSeconds(0);
majorGCReal.fromSeconds(0);
majorGCPageFaults = 0;
minorGCsSinceMajor = 0;
}
class HeapSizing: public RtsModule
{
public:
virtual void Init(void);
virtual void Stop(void);
};
// Declare this. It will be automatically added to the table.
static HeapSizing heapSizeModule;
void HeapSizing::Init(void)
{
gHeapSizeParameters.Init();
}
void HeapSizing::Stop()
{
gHeapSizeParameters.Final();
}
static size_t GetPhysicalMemorySize(void)
{
size_t maxMem = (size_t)0-1; // Maximum unsigned value.
-#if defined(HAVE_WINDOWS_H)
+#if defined(HAVE_WINDOWS_H) // Windows including Cygwin
{
MEMORYSTATUSEX memStatEx;
memset(&memStatEx, 0, sizeof(memStatEx));
memStatEx.dwLength = sizeof(memStatEx);
if (! GlobalMemoryStatusEx(&memStatEx))
memStatEx.ullTotalPhys = 0; // Clobber any rubbish since it says it failed.
if (memStatEx.ullTotalPhys) // If it's non-zero assume it succeeded
{
DWORDLONG dwlMax = maxMem;
if (memStatEx.ullTotalPhys > dwlMax)
return maxMem;
else
return (size_t)memStatEx.ullTotalPhys;
}
}
#endif
#if defined(_SC_PHYS_PAGES) && defined(_SC_PAGESIZE)
{
// Linux and Solaris. This gives a silly value in Cygwin.
long physPages = sysconf(_SC_PHYS_PAGES);
long physPagesize = sysconf(_SC_PAGESIZE);
if (physPages != -1 && physPagesize != -1)
{
unsigned long maxPages = maxMem / physPagesize;
if ((unsigned long)physPages > maxPages)
return maxMem;
else // We've checked it won't overflow.
return physPages*physPagesize;
}
}
#endif
#if defined(HAVE_SYSCTL) && defined(CTL_HW)
// FreeBSD and Mac OS X. It seems HW_MEMSIZE has been added to
// Max OS X to return a 64-bit value.
#ifdef HW_MEMSIZE
{
static int mib[2] = { CTL_HW, HW_MEMSIZE };
uint64_t physMem = 0;
size_t len = sizeof(physMem);
if (sysctl(mib, 2, &physMem, &len, NULL, 0) == 0 && len == sizeof(physMem))
{
if (physMem > (uint64_t)maxMem)
return maxMem;
else
return (POLYUNSIGNED)physMem;
}
}
#endif
#ifdef HW_PHYSMEM
// If HW_MEMSIZE isn't there or the call failed try this.
{
static int mib[2] = { CTL_HW, HW_PHYSMEM };
unsigned int physMem = 0;
size_t len = sizeof(physMem);
if (sysctl(mib, 2, &physMem, &len, NULL, 0) == 0 && len == sizeof(physMem))
{
if (physMem > maxMem)
return maxMem;
else
return physMem;
}
}
#endif
#endif
return 0; // Unable to determine
}
diff --git a/libpolyml/io_internal.h b/libpolyml/io_internal.h
index 8a5e7482..50b4151c 100644
--- a/libpolyml/io_internal.h
+++ b/libpolyml/io_internal.h
@@ -1,213 +1,213 @@
/*
Title: Data structures shared between basioio.c and network.c.
- Copyright (c) 2000, 2016, 2018 David C. J. Matthews
+ Copyright (c) 2000, 2016, 2018-19 David C. J. Matthews
Portions of this code are derived from the original stream io
package copyright CUTS 1983-2000.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef IO_INTERNAL_H
#define IO_INTERNAL_H
// Bits to define tests and results in poll.
// These are the values passed to and from ML.
#define POLL_BIT_IN 1
#define POLL_BIT_OUT 2
#define POLL_BIT_PRI 4
// Return values from fileKind
#define FILEKIND_FILE 0
#define FILEKIND_DIR 1
#define FILEKIND_LINK 2
#define FILEKIND_TTY 3
#define FILEKIND_PIPE 4
#define FILEKIND_SKT 5
#define FILEKIND_DEV 6
#define FILEKIND_UNKNOWN 7
#define FILEKIND_ERROR (-1)
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#include "locking.h" // For PLock
// Unlike Unix where select and poll can be used on both sockets and other
// streams, in Windows there is no single way of testing different sorts of
// streams.
class WinStreamBase
{
public:
virtual ~WinStreamBase() {} // Quieten some warnings
virtual int pollTest() { // Return the valid options for this descriptor
return 0;
}
virtual int poll(TaskData *taskData, int test) { // Return the values set
return 0;
}
// These are not currently used but could be used to poll
// multiple sockets or streams.
virtual SOCKET getSocket() {
return INVALID_SOCKET;
}
virtual HANDLE getHandle() {
return INVALID_HANDLE_VALUE;
}
};
typedef enum { OPENREAD, OPENWRITE, OPENAPPEND } openMode;
// Abstract Windows stream
class WinStream : public WinStreamBase
{
public:
virtual void closeEntry(TaskData *taskData) = 0;
// Block for a short time until either input is possible, returning true,
// or the time-out, which may be zero, has expired.
virtual bool testForInput(TaskData *taskData, unsigned waitMilliSecs) = 0;
// The same for output.
virtual bool testForOutput(TaskData *taskData, unsigned waitMilliSecs) = 0;
// These are really for backwards compatibility.
virtual void waitUntilAvailable(TaskData *taskData);
virtual void waitUntilOutputPossible(TaskData *taskData);
virtual size_t readStream(TaskData *taskData, byte *base, size_t length) {
unimplemented(taskData);
return 0;
}
virtual uint64_t getPos(TaskData *taskData) {
unimplemented(taskData);
return 0;
}
virtual void setPos(TaskData *taskData, uint64_t pos) {
unimplemented(taskData);
}
virtual uint64_t fileSize(TaskData *taskData) {
unimplemented(taskData);
return 0;
}
virtual size_t writeStream(TaskData *taskData, byte *base, size_t length) {
unimplemented(taskData);
return 0;
}
virtual int fileKind() = 0;
static int fileTypeOfHandle(HANDLE hStream);
protected:
void unimplemented(TaskData *taskData);
};
// Windows stream input using overlapped IO and the Windows calls.
class WinInOutStream : public WinStream
{
public:
WinInOutStream();
~WinInOutStream();
virtual void closeEntry(TaskData *taskData);
virtual void openFile(TaskData * taskData, TCHAR *name, openMode mode, bool text);
virtual size_t readStream(TaskData *taskData, byte *base, size_t length);
virtual bool testForInput(TaskData *taskData, unsigned waitMilliSecs);
virtual bool testForOutput(TaskData *taskData, unsigned waitMilliSecs);
virtual uint64_t getPos(TaskData *taskData);
virtual void setPos(TaskData *taskData, uint64_t pos);
virtual uint64_t fileSize(TaskData *taskData);
virtual size_t writeStream(TaskData *taskData, byte *base, size_t length);
// Open on a handle. This returns an error result rather than raising an exception
virtual bool openHandle(HANDLE hndl, openMode mode, bool isText);
virtual int fileKind() {
return WinStream::fileTypeOfHandle(hStream);
}
virtual int pollTest() {
// We can poll this to test for input.
return isRead ? POLL_BIT_IN : POLL_BIT_OUT;
}
virtual int poll(TaskData *taskData, int test);
virtual HANDLE getHandle() {
return hEvent;
}
protected:
bool beginReading();
void flushOut(TaskData *taskData);
uint64_t getOverlappedPos() {
return ((uint64_t)(overlap.OffsetHigh) << 32) + overlap.Offset;
}
void setOverlappedPos(uint64_t newPos) {
overlap.Offset = (DWORD)newPos;
overlap.OffsetHigh = (DWORD)(newPos >> 32);
}
bool isAvailable(TaskData *taskData);
bool canOutput(TaskData *taskData);
protected:
bool isRead;
bool isText; // Remove CRs?
byte *buffer;
unsigned buffSize, currentInBuffer, currentPtr;
bool endOfStream;
HANDLE hStream;
HANDLE hEvent;
OVERLAPPED overlap;
PLock lock;
};
// Create a new pipe.
extern void newPipeName(TCHAR *name);
#else
extern Handle wrapFileDescriptor(TaskData *taskData, int fd);
// Get a file descriptor and raise an exception if it is closed.
extern int getStreamFileDescriptor(TaskData *taskData, PolyWord strm);
extern int getStreamFileDescriptorWithoutCheck(PolyWord strm);
#endif
// This is used in both basicio and unix-specific
#if defined(HAVE_STRUCT_STAT_ST_ATIM)
# define STAT_SECS(stat,kind) (stat)->st_##kind##tim.tv_sec
# define STAT_USECS(stat,kind) (((stat)->st_##kind##tim.tv_nsec + 500) / 1000)
#elif defined(HAVE_STRUCT_STAT_ST_ATIMENSEC)
# define STAT_SECS(stat,kind) (stat)->st_##kind##time
# define STAT_USECS(stat,kind) (((stat)->st_##kind##timensec + 500) / 1000)
#elif defined(HAVE_STRUCT_STAT_ST_ATIMESPEC)
# define STAT_SECS(stat,kind) (stat)->st_##kind##timespec.tv_sec
# define STAT_USECS(stat,kind) (((stat)->st_##kind##timespec.tv_nsec + 500) / 1000)
#elif defined(HAVE_STRUCT_STAT_ST_ATIME_N)
# define STAT_SECS(stat,kind) (stat)->st_##kind##time
# define STAT_USECS(stat,kind) (((stat)->st_##kind##time_n + 500) / 1000)
#elif defined(HAVE_STRUCT_STAT_ST_UATIME)
# define STAT_SECS(stat,kind) (stat)->st_##kind##time
# define STAT_USECS(stat,kind) (stat)->st_u##kind##time
#else
# define STAT_SECS(stat,kind) (stat)->st_##kind##time
# define STAT_USECS(stat,kind) 0
#endif
#endif
diff --git a/libpolyml/libffi/libffi.vcxproj b/libpolyml/libffi/libffi.vcxproj
index ff61c457..9909c1db 100644
--- a/libpolyml/libffi/libffi.vcxproj
+++ b/libpolyml/libffi/libffi.vcxproj
@@ -1,708 +1,708 @@
Debug32in64Win32Debug32in64x64DebugWin32Int32in64DebugWin32Int32in64Debugx64Int32In64ReleaseWin32Int32In64Releasex64IntDebugWin32IntDebugx64IntReleaseWin32IntReleasex64Release32in64Win32Release32in64x64ReleaseWin32Debugx64Releasex64{6D86BC6F-E74E-40C5-9881-F8BB606BCA78}Win32Projlibffi
- 10.0.15063.0
+ 10.0StaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibrarytrue
- v141
+ v142UnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodeStaticLibraryfalse
- v141
+ v142trueUnicodetruetruetruetruetruetruetruetruefalsefalsefalsefalsefalsefalsefalsefalseLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3Disabled_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedDebugWindowstrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetrueLevel3MaxSpeedtruetrue_LIB;LONG_LONG_MAX=_I64_MAXmsvc32include;src\x86;includeMultiThreadedWindowstruetruetruetruetruetruetruetruetruetruetrueDocumentcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asmcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml /nologo /Fo $(IntDir)%(Filename).obj /c /coff $(IntDir)%(Filename).asm$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)truetruetruetruetruetruetruetrueDocumentcl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
cl /nologo /EP /Imsvc32include /Isrc\x86 /I. /Iinclude /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm
ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm
$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)$(IntDir)%(Filename).obj;$(IntDir)%(Filename).asm;%(Outputs)
\ No newline at end of file
diff --git a/libpolyml/locking.cpp b/libpolyml/locking.cpp
index 7386cacf..d064e7bc 100644
--- a/libpolyml/locking.cpp
+++ b/libpolyml/locking.cpp
@@ -1,329 +1,312 @@
/*
Title: Mutex and Condition Variable library.
- Copyright (c) 2007, 2012, 2015 David C. J. Matthews
+ Copyright (c) 2007, 2012, 2015, 2019 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
-#define HAVE_PTHREAD 1
+#if (!defined(_WIN32))
+// Configure requires pthread unless this is native Windows.
#include
-#elif (defined(HAVE_WINDOWS_H))
+#else
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_SYS_TIME_H
#include
#endif
#ifdef HAVE_TIME_H
#include
#endif
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (defined(HAVE_SEMAPHORE_H) && !defined(_WIN32))
// Don't include semaphore.h on Mingw. It's provided but doesn't compile.
#include
#endif
#ifdef HAVE_SYS_TYPES_H
#include
#endif
#ifdef HAVE_SYS_STAT_H
#include
#endif
#ifdef HAVE_FCNTL_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#include "locking.h"
#include "diagnostics.h"
// Report contended locks after this many attempts
#define LOCK_REPORT_COUNT 50
PLock::PLock(const char *n): lockName(n), lockCount(0)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_mutex_init(&lock, 0);
-#elif defined(HAVE_WINDOWS_H)
+#else
InitializeCriticalSection(&lock);
#endif
}
PLock::~PLock()
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_mutex_destroy(&lock);
-#elif defined(HAVE_WINDOWS_H)
+#else
DeleteCriticalSection(&lock);
#endif
}
void PLock::Lock(void)
{
-#if (defined(HAVE_PTHREAD) || defined(HAVE_WINDOWS_H))
if (debugOptions & DEBUG_CONTENTION)
{
// Report a heavily contended lock.
if (Trylock())
return;
if (++lockCount > LOCK_REPORT_COUNT)
{
if (lockName != 0)
Log("Lock: contention on lock: %s\n", lockName);
else
Log("Lock: contention on lock at %p\n", &lock);
lockCount = 0;
}
// Drop through to a normal lock
}
-#endif
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_mutex_lock(&lock);
-#elif defined(HAVE_WINDOWS_H)
+#else
EnterCriticalSection(&lock);
#endif
- // If we don't support threads this does nothing.
}
void PLock::Unlock(void)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_mutex_unlock(&lock);
-#elif defined(HAVE_WINDOWS_H)
+#else
LeaveCriticalSection(&lock);
#endif
}
bool PLock::Trylock(void)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
// Since we use normal mutexes this returns EBUSY if the
// current thread owns the mutex.
return pthread_mutex_trylock(&lock) != EBUSY;
-#elif defined(HAVE_WINDOWS_H)
+#else
// This is not implemented properly in Windows. There is
// TryEnterCriticalSection in Win NT and later but that
// returns TRUE if the current thread owns the mutex.
return TryEnterCriticalSection(&lock) == TRUE;
-#else
- return true; // Single-threaded.
#endif
}
PCondVar::PCondVar()
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_cond_init(&cond, NULL);
-#elif defined(HAVE_WINDOWS_H)
+#else
InitializeConditionVariable(&cond);
#endif
}
PCondVar::~PCondVar()
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_cond_destroy(&cond);
#endif
}
// Wait indefinitely. Drops the lock and reaquires it.
void PCondVar::Wait(PLock *pLock)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_cond_wait(&cond, &pLock->lock);
-#elif defined(HAVE_WINDOWS_H)
+#else
SleepConditionVariableCS(&cond, &pLock->lock, INFINITE);
#endif
}
// Wait until a specified absolute time. Drops the lock and reaquires it.
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
// Windows with Windows-style times
void PCondVar::WaitUntil(PLock *pLock, const FILETIME *time)
{
FILETIME now;
GetSystemTimeAsFileTime(&now);
LARGE_INTEGER liNow, liTime;
liNow.HighPart = now.dwHighDateTime;
liNow.LowPart = now.dwLowDateTime;
liTime.HighPart = time->dwHighDateTime;
liTime.LowPart = time->dwLowDateTime;
if (liNow.QuadPart >= liTime.QuadPart) // Already past the time
return;
DWORD toWait = (DWORD)((liTime.QuadPart - liNow.QuadPart) / (LONGLONG)10000);
(void)WaitFor(pLock, toWait);
}
#else
// Unix-style times
void PCondVar::WaitUntil(PLock *pLock, const timespec *time)
{
-#ifdef HAVE_PTHREAD
pthread_cond_timedwait(&cond, &pLock->lock, time);
-#elif defined(HAVE_WINDOWS_H)
- // This must be Cygwin but compiled with --without-threads
- struct timeval tv;
- if (gettimeofday(&tv, NULL) != 0)
- return;
- if (tv.tv_sec > time->tv_sec || (tv.tv_sec == time->tv_sec && tv.tv_usec >= time->tv_nsec/1000))
- return; // Already past the time
- WaitFor(pLock, (time->tv_sec - tv.tv_sec) * 1000 + time->tv_nsec/1000000 - tv.tv_usec/1000);
-#endif
}
#endif
// Wait for a number of milliseconds. Used within the RTS. Drops the lock and reaquires it.
// Returns true if the return was because the condition variable had been signalled.
// Returns false if the timeout expired or there was an error.
bool PCondVar::WaitFor(PLock *pLock, unsigned milliseconds)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
struct timespec waitTime;
struct timeval tv;
if (gettimeofday(&tv, NULL) != 0)
return false;
waitTime.tv_sec = tv.tv_sec + milliseconds / 1000;
waitTime.tv_nsec = (tv.tv_usec + (milliseconds % 1000) * 1000) * 1000;
if (waitTime.tv_nsec >= 1000*1000*1000)
{
waitTime.tv_nsec -= 1000*1000*1000;
waitTime.tv_sec += 1;
}
return pthread_cond_timedwait(&cond, &pLock->lock, &waitTime) == 0;
-#elif defined(HAVE_WINDOWS_H)
+#else
// SleepConditionVariableCS returns zero on error or timeout.
return SleepConditionVariableCS(&cond, &pLock->lock, milliseconds) != 0;
-#else
- return true; // Single-threaded. Return immediately.
#endif
}
// Wake up all the waiting threads.
void PCondVar::Signal(void)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_cond_broadcast(&cond);
-#elif defined(HAVE_WINDOWS_H)
+#else
WakeAllConditionVariable(&cond);
#endif
}
// Initialise a semphore. Tries to create an unnamed semaphore if
// it can but tries a named semaphore if it can't. Mac OS X only
// supports named semaphores.
// The semaphore is initialised with a count of zero.
PSemaphore::PSemaphore()
{
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (!defined(_WIN32))
sema = 0;
isLocal = true;
-#elif defined(HAVE_WINDOWS_H)
+#else
sema = NULL;
#endif
}
PSemaphore::~PSemaphore()
{
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (!defined(_WIN32))
if (sema && isLocal) sem_destroy(sema);
else if (sema && !isLocal) sem_close(sema);
-#elif defined(HAVE_WINDOWS_H)
+#else
if (sema != NULL) CloseHandle(sema);
#endif
}
bool PSemaphore::Init(unsigned init, unsigned max)
{
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (!defined(_WIN32))
isLocal = true;
if (sem_init(&localSema, 0, init) == 0) {
sema = &localSema;
return true;
}
#if (defined(__CYGWIN__))
// Cygwin doesn't define sem_unlink but that doesn't matter
// since sem_init works.
sema = 0;
return false;
#else
isLocal = false;
char semname[30];
static int count=0;
sprintf(semname, "poly%0d-%0d", (int)getpid(), count++);
sema = sem_open(semname, O_CREAT|O_EXCL, 00666, init);
if (sema == (sem_t*)SEM_FAILED) {
sema = 0;
return false;
}
sem_unlink(semname);
return true;
#endif
-#elif defined(HAVE_WINDOWS_H)
+#else
sema = CreateSemaphore(NULL, init, max, NULL);
return sema != NULL;
#endif
}
bool PSemaphore::Wait(void)
{
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (!defined(_WIN32))
// Wait until the semaphore is signalled. A Unix signal may interrupt
// it so we need to retry in that case.
while (sem_wait(sema) == -1)
{
if (errno != EINTR)
return false;
}
return true;
-#elif defined(HAVE_WINDOWS_H)
+#else
return WaitForSingleObject(sema, INFINITE) == WAIT_OBJECT_0;
#endif
}
void PSemaphore::Signal(void)
{
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (!defined(_WIN32))
sem_post(sema);
-#elif defined(HAVE_WINDOWS_H)
+#else
ReleaseSemaphore(sema, 1, NULL);
#endif
}
diff --git a/libpolyml/locking.h b/libpolyml/locking.h
index 94616485..74f20cbc 100644
--- a/libpolyml/locking.h
+++ b/libpolyml/locking.h
@@ -1,123 +1,123 @@
/*
Title: Mutex and Condition Variable library.
- Copyright (c) 2007, 2012 David C. J. Matthews
+ Copyright (c) 2007, 2012, 2019 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef LOCKING_H_DEFINED
#define LOCKING_H_DEFINED
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_WINDOWS_H
#include
#endif
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (defined(HAVE_SEMAPHORE_H) && !defined(_WIN32))
// Don't include semaphore.h on Mingw. It's provided but doesn't compile.
#include
#endif
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
-// Don't include pthread if this is native Windows and not Cygwin
+#if (!defined(_WIN32))
+// Don't include pthread if this is native Windows.
#include
#endif
// Simple Mutex.
class PLock {
public:
PLock(const char *n = 0);
~PLock();
void Lock(void); // Lock the mutex
void Unlock(void); // Unlock the mutex
bool Trylock(void); // Try to lock the mutex - returns true if succeeded
private:
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+#if (!defined(_WIN32))
pthread_mutex_t lock;
-#elif defined(HAVE_WINDOWS_H)
+#else
CRITICAL_SECTION lock;
#endif
// Debugging info.
const char *lockName;
unsigned lockCount;
friend class PCondVar;
};
// Lock a mutex and automatically unlock it in the destructor.
// This can be used in a function to lock a mutex and unlock it
// when the function either returns normally or raises an exception.
class PLocker {
public:
PLocker(PLock *lock): m_lock(lock) { m_lock->Lock(); }
~PLocker() { m_lock->Unlock(); }
private:
PLock *m_lock;
};
// Simple condition variable. N.B. The Windows code does not
// support multiple threads blocking on this condition variable.
class PCondVar {
public:
PCondVar();
~PCondVar();
void Wait(PLock *pLock); // Wait indefinitely. Drops the lock and reaquires it.
// Wait for a signal or until the time. The argument is an absolute time
// represented as a struct timespec in Unix and a FILETIME in Windows.
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
void WaitUntil(PLock *pLock, const FILETIME *timeArg);
#else
void WaitUntil(PLock *pLock, const timespec *timeArg);
#endif
// Wait for a time. This is used internally in the RTS.
bool WaitFor(PLock *pLock, unsigned milliseconds);
// N.B. Signal MUST be called only with the lock held.
void Signal(void); // Wake up the waiting thread.
private:
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_PTHREAD_H))
+#if (!defined(_WIN32))
pthread_cond_t cond;
-#elif defined(HAVE_WINDOWS_H)
+#else
CONDITION_VARIABLE cond;
#endif
};
// Semaphore. Wrapper for Posix semaphore or Windows semaphore.
class PSemaphore {
public:
PSemaphore();
~PSemaphore();
bool Init(unsigned init, unsigned max);
bool Wait(void);
void Signal(void);
private:
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (!defined(_WIN32))
sem_t localSema, *sema;
bool isLocal;
-#elif defined(HAVE_WINDOWS_H)
+#else
HANDLE sema;
#endif
};
#endif
diff --git a/libpolyml/mpoly.cpp b/libpolyml/mpoly.cpp
index 1e73852a..39014543 100644
--- a/libpolyml/mpoly.cpp
+++ b/libpolyml/mpoly.cpp
@@ -1,506 +1,506 @@
/*
Title: Main program
Copyright (c) 2000
Cambridge University Technical Services Limited
Further development copyright David C.J. Matthews 2001-12, 2015, 2017-19
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_STDARG_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#else
#define _T(x) x
#define _tcslen strlen
#define _tcstol strtol
#define _tcsncmp strncmp
#define _tcschr strchr
#endif
#include "globals.h"
#include "sys.h"
#include "gc.h"
#include "heapsizing.h"
#include "run_time.h"
#include "machine_dep.h"
#include "version.h"
#include "diagnostics.h"
#include "processes.h"
#include "mpoly.h"
#include "scanaddrs.h"
#include "save_vec.h"
#include "../polyexports.h"
#include "memmgr.h"
#include "pexport.h"
#include "polystring.h"
#include "statistics.h"
#include "noreturn.h"
#include "savestate.h"
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include "winstartup.h"
#include "winguiconsole.h"
static const TCHAR *lpszServiceName = 0; // DDE service name
#endif
FILE *polyStdout, *polyStderr; // Redirected in the Windows GUI
NORETURNFN(static void Usage(const char *message, ...));
struct _userOptions userOptions;
time_t exportTimeStamp;
enum {
OPT_HEAPMIN,
OPT_HEAPMAX,
OPT_HEAPINIT,
OPT_GCPERCENT,
OPT_RESERVE,
OPT_GCTHREADS,
OPT_DEBUGOPTS,
OPT_DEBUGFILE,
OPT_DDESERVICE,
OPT_CODEPAGE,
OPT_REMOTESTATS
};
static struct __argtab {
const TCHAR *argName;
const char *argHelp;
unsigned argKey;
} argTable[] =
{
{ _T("-H"), "Initial heap size (MB)", OPT_HEAPINIT },
{ _T("--minheap"), "Minimum heap size (MB)", OPT_HEAPMIN },
{ _T("--maxheap"), "Maximum heap size (MB)", OPT_HEAPMAX },
{ _T("--gcpercent"), "Target percentage time in GC (1-99)", OPT_GCPERCENT },
{ _T("--stackspace"), "Space to reserve for thread stacks and C++ heap(MB)", OPT_RESERVE },
{ _T("--gcthreads"), "Number of threads to use for garbage collection", OPT_GCTHREADS },
{ _T("--debug"), "Debug options: checkmem, gc, x", OPT_DEBUGOPTS },
{ _T("--logfile"), "Logging file (default is to log to stdout)", OPT_DEBUGFILE },
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#ifdef UNICODE
{ _T("--codepage"), "Code-page to use for file-names etc in Windows", OPT_CODEPAGE },
#endif
{ _T("-pServiceName"), "DDE service name for remote interrupt in Windows", OPT_DDESERVICE }
#else
{ _T("--exportstats"), "Enable another process to read the statistics", OPT_REMOTESTATS }
#endif
};
static struct __debugOpts {
const TCHAR *optName;
const char *optHelp;
unsigned optKey;
} debugOptTable[] =
{
{ _T("checkmem"), "Perform additional debugging checks on memory", DEBUG_CHECK_OBJECTS },
{ _T("gc"), "Log summary garbage-collector information", DEBUG_GC },
{ _T("gcenhanced"), "Log enhanced garbage-collector information", DEBUG_GC_ENHANCED },
{ _T("gcdetail"), "Log detailed garbage-collector information", DEBUG_GC_DETAIL },
{ _T("memmgr"), "Memory manager information", DEBUG_MEMMGR },
{ _T("threads"), "Thread related information", DEBUG_THREADS },
{ _T("gctasks"), "Log multi-thread GC information", DEBUG_GCTASKS },
{ _T("heapsize"), "Log heap resizing data", DEBUG_HEAPSIZE },
{ _T("x"), "Log X-windows information", DEBUG_X},
{ _T("sharing"), "Information from PolyML.shareCommonData", DEBUG_SHARING},
{ _T("locks"), "Information about contended locks", DEBUG_CONTENTION},
{ _T("rts"), "General run-time system calls", DEBUG_RTSCALLS},
{ _T("saving"), "Saving and loading state; exporting", DEBUG_SAVING }
};
// Parse a parameter that is meant to be a size. Returns the value as a number
// of kilobytes.
POLYUNSIGNED parseSize(const TCHAR *p, const TCHAR *arg)
{
POLYUNSIGNED result = 0;
if (*p < '0' || *p > '9')
// There must be at least one digit
Usage("Incomplete %s option\n", arg);
while (true)
{
result = result*10 + *p++ - '0';
if (*p == 0)
{
// The default is megabytes
result *= 1024;
break;
}
if (*p == 'G' || *p == 'g')
{
result *= 1024 * 1024;
p++;
break;
}
if (*p == 'M' || *p == 'm')
{
result *= 1024;
p++;
break;
}
if (*p == 'K' || *p == 'k')
{
p++;
break;
}
if (*p < '0' || *p > '9')
break;
}
if (*p != 0)
Usage("Malformed %s option\n", arg);
// The sizes must not exceed the possible heap size.
#ifdef POLYML32IN64
if (result > 16 * 1024 * 1024)
Usage("Value of %s option must not exceeed 16Gbytes\n", arg);
#elif (SIZEOF_VOIDP == 4)
if (result > 4 * 1024 * 1024)
Usage("Value of %s option must not exceeed 4Gbytes\n", arg);
#else
// For completion only!
if (result > (POLYUNSIGNED)8 * 1024 * 1024 * 1024 * 1024 * 1024)
Usage("Value of %s option must not exceeed 8Ebytes\n", arg);
#endif
return result;
}
/* In the Windows version this is called from WinMain in Console.c */
int polymain(int argc, TCHAR **argv, exportDescription *exports)
{
POLYUNSIGNED minsize=0, maxsize=0, initsize=0;
unsigned gcpercent=0;
/* Get arguments. */
memset(&userOptions, 0, sizeof(userOptions)); /* Reset it */
userOptions.gcthreads = 0; // Default multi-threaded
if (polyStdout == 0) polyStdout = stdout;
if (polyStderr == 0) polyStderr = stderr;
// Get the program name for CommandLine.name. This is allowed to be a full path or
// just the last component so we return whatever the system provides.
if (argc > 0)
userOptions.programName = argv[0];
else
userOptions.programName = _T(""); // Set it to a valid empty string
TCHAR *importFileName = 0;
debugOptions = 0;
userOptions.user_arg_count = 0;
userOptions.user_arg_strings = (TCHAR**)malloc(argc * sizeof(TCHAR*)); // Enough room for all of them
// Process the argument list removing those recognised by the RTS and adding the
// remainder to the user argument list.
for (int i = 1; i < argc; i++)
{
if (argv[i][0] == '-')
{
bool argUsed = false;
for (unsigned j = 0; j < sizeof(argTable)/sizeof(argTable[0]); j++)
{
size_t argl = _tcslen(argTable[j].argName);
if (_tcsncmp(argv[i], argTable[j].argName, argl) == 0)
{
const TCHAR *p = 0;
TCHAR *endp = 0;
if (argTable[j].argKey != OPT_REMOTESTATS)
{
if (_tcslen(argv[i]) == argl)
{ // If it has used all the argument pick the next
i++;
p = argv[i];
}
else
{
p = argv[i]+argl;
if (*p == '=') p++; // Skip an equals sign
}
if (i >= argc)
Usage("Incomplete %s option\n", argTable[j].argName);
}
switch (argTable[j].argKey)
{
case OPT_HEAPMIN:
minsize = parseSize(p, argTable[j].argName);
break;
case OPT_HEAPMAX:
maxsize = parseSize(p, argTable[j].argName);
break;
case OPT_HEAPINIT:
initsize = parseSize(p, argTable[j].argName);
break;
case OPT_GCPERCENT:
gcpercent = _tcstol(p, &endp, 10);
if (*endp != '\0')
Usage("Malformed %s option\n", argTable[j].argName);
if (gcpercent < 1 || gcpercent > 99)
{
Usage("%s argument must be between 1 and 99\n", argTable[j].argName);
gcpercent = 0;
}
break;
case OPT_RESERVE:
{
POLYUNSIGNED reserve = parseSize(p, argTable[j].argName);
if (reserve != 0)
gHeapSizeParameters.SetReservation(reserve);
break;
}
case OPT_GCTHREADS:
userOptions.gcthreads = _tcstol(p, &endp, 10);
if (*endp != '\0')
Usage("Incomplete %s option\n", argTable[j].argName);
break;
case OPT_DEBUGOPTS:
while (*p != '\0')
{
// Debug options are separated by commas
bool optFound = false;
const TCHAR *q = _tcschr(p, ',');
if (q == NULL) q = p+_tcslen(p);
for (unsigned k = 0; k < sizeof(debugOptTable)/sizeof(debugOptTable[0]); k++)
{
if (_tcslen(debugOptTable[k].optName) == (size_t)(q-p) &&
_tcsncmp(p, debugOptTable[k].optName, q-p) == 0)
{
debugOptions |= debugOptTable[k].optKey;
optFound = true;
}
}
if (! optFound)
Usage("Unknown argument to --debug\n");
if (*q == ',') p = q+1; else p = q;
}
if (debugOptions & DEBUG_GC_DETAIL) debugOptions |= DEBUG_GC_ENHANCED;
if (debugOptions & DEBUG_GC_ENHANCED) debugOptions |= DEBUG_GC;
break;
case OPT_DEBUGFILE:
SetLogFile(p);
break;
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
case OPT_DDESERVICE:
// Set the name for the DDE service. This allows the caller to specify the
// service name to be used to send Interrupt "signals".
lpszServiceName = p;
break;
#if (defined(UNICODE))
case OPT_CODEPAGE:
if (! setWindowsCodePage(p))
Usage("Unknown argument to --codepage. Use code page number or CP_ACP, CP_UTF8.\n");
break;
#endif
#endif
case OPT_REMOTESTATS:
// If set we export the statistics on Unix.
globalStats.exportStats = true;
break;
}
argUsed = true;
break;
}
}
if (! argUsed) // Add it to the user args.
userOptions.user_arg_strings[userOptions.user_arg_count++] = argv[i];
}
else if (exports == 0 && importFileName == 0)
importFileName = argv[i];
else
userOptions.user_arg_strings[userOptions.user_arg_count++] = argv[i];
}
if (!gMem.Initialise())
Usage("Unable to initialise memory allocator\n");
if (exports == 0 && importFileName == 0)
Usage("Missing import file name\n");
// If the maximum is provided it must be not less than the minimum.
if (maxsize != 0 && maxsize < minsize)
Usage("Minimum heap size must not be more than maximum size\n");
// The initial size must be not more than the maximum
if (maxsize != 0 && maxsize < initsize)
Usage("Initial heap size must not be more than maximum size\n");
// The initial size must be not less than the minimum
if (initsize != 0 && initsize < minsize)
Usage("Initial heap size must not be less than minimum size\n");
if (userOptions.gcthreads == 0)
{
// If the gcthreads option is missing or zero the default is to try to
// use as many threads as there are physical processors. The result may
// be zero in which case we use the number of processors. Because memory
// bandwidth is a limiting factor we want to avoid muliple GC threads on
// hyperthreaded "processors".
userOptions.gcthreads = NumberOfPhysicalProcessors();
if (userOptions.gcthreads == 0)
userOptions.gcthreads = NumberOfProcessors();
}
// Set the heap size if it has been provided otherwise use the default.
gHeapSizeParameters.SetHeapParameters(minsize, maxsize, initsize, gcpercent);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
SetupDDEHandler(lpszServiceName); // Windows: Start the DDE handler now we processed any service name.
#endif
// Initialise the run-time system before creating the heap.
InitModules();
CreateHeap();
PolyObject *rootFunction = 0;
if (exports != 0)
rootFunction = InitHeaderFromExport(exports);
else
{
if (importFileName != 0)
rootFunction = ImportPortable(importFileName);
if (rootFunction == 0)
exit(1);
}
StartModules();
// Set up the initial process to run the root function.
processes->BeginRootThread(rootFunction);
finish(0);
/*NOTREACHED*/
return 0; /* just to keep lint happy */
}
void Uninitialise(void)
// Close down everything and free all resources. Stop any threads or timers.
{
StopModules();
}
void finish (int n)
{
// Make sure we don't get any interrupts once the destructors are
// applied to globals or statics.
Uninitialise();
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
ExitThread(n);
#else
exit (n);
#endif
}
// Print a message and exit if an argument is malformed.
void Usage(const char *message, ...)
{
va_list vl;
fprintf(polyStdout, "\n");
va_start(vl, message);
vfprintf(polyStdout, message, vl);
va_end(vl);
for (unsigned j = 0; j < sizeof(argTable)/sizeof(argTable[0]); j++)
{
#if (defined(_WIN32) && defined(UNICODE))
fprintf(polyStdout, "%S <%s>\n", argTable[j].argName, argTable[j].argHelp);
#else
fprintf(polyStdout, "%s <%s>\n", argTable[j].argName, argTable[j].argHelp);
#endif
}
fprintf(polyStdout, "Debug options:\n");
for (unsigned k = 0; k < sizeof(debugOptTable)/sizeof(debugOptTable[0]); k++)
{
#if (defined(_WIN32) && defined(UNICODE))
fprintf(polyStdout, "%S <%s>\n", debugOptTable[k].optName, debugOptTable[k].optHelp);
#else
fprintf(polyStdout, "%s <%s>\n", debugOptTable[k].optName, debugOptTable[k].optHelp);
#endif
}
fflush(polyStdout);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
if (useConsole)
{
MessageBox(hMainWindow, _T("Poly/ML has exited"), _T("Poly/ML"), MB_OK);
}
#endif
exit (1);
}
// Return a string containing the argument names. Can be printed out in response
// to a --help argument. It is up to the ML application to do that since it may well
// want to produce information about any arguments it chooses to process.
char *RTSArgHelp(void)
{
static char buff[2000];
char *p = buff;
for (unsigned j = 0; j < sizeof(argTable)/sizeof(argTable[0]); j++)
{
#if (defined(_WIN32) && defined(UNICODE))
int spaces = sprintf(p, "%S <%s>\n", argTable[j].argName, argTable[j].argHelp);
#else
int spaces = sprintf(p, "%s <%s>\n", argTable[j].argName, argTable[j].argHelp);
#endif
p += spaces;
}
{
int spaces = sprintf(p, "Debug options:\n");
p += spaces;
}
for (unsigned k = 0; k < sizeof(debugOptTable)/sizeof(debugOptTable[0]); k++)
{
#if (defined(_WIN32) && defined(UNICODE))
int spaces = sprintf(p, "%S <%s>\n", debugOptTable[k].optName, debugOptTable[k].optHelp);
#else
int spaces = sprintf(p, "%s <%s>\n", debugOptTable[k].optName, debugOptTable[k].optHelp);
#endif
p += spaces;
}
ASSERT((unsigned)(p - buff) < (unsigned)sizeof(buff));
return buff;
}
diff --git a/libpolyml/mpoly.h b/libpolyml/mpoly.h
index f025bf7d..6b04cc64 100644
--- a/libpolyml/mpoly.h
+++ b/libpolyml/mpoly.h
@@ -1,62 +1,62 @@
/*
Title: exports signature for mpoly.c
Copyright (c) 2000-7
Cambridge University Technical Services Limited
- Further development copyright David C.J. Matthews 2001-12, 2015
+ Further development copyright David C.J. Matthews 2001-12, 2015, 2019
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef _MPOLY_H_DEFINED
#define _MPOLY_H_DEFINED
#ifdef HAVE_TCHAR_H
#include
#else
typedef char TCHAR;
#endif
#include "noreturn.h"
#include "../polyexports.h"
extern struct _userOptions {
unsigned user_arg_count;
TCHAR **user_arg_strings;
const TCHAR *programName;
unsigned gcthreads; // Number of threads to use for gc
} userOptions;
class PolyWord;
NORETURNFN(extern void finish(int n));
extern char *RTSArgHelp(void);
extern time_t exportTimeStamp;
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
extern int polymain(int argc, TCHAR **argv, exportDescription *exports);
#endif
#ifdef HAVE_STDIO_H
#include
#endif
// Outout streams. These are the same as stdOut and stdErr in Unix but
// may be redirected in Windows.
extern FILE *polyStdout, *polyStderr;
#endif /* _MPOLY_H_DEFINED */
diff --git a/libpolyml/network.cpp b/libpolyml/network.cpp
index 633f0171..e17b61eb 100644
--- a/libpolyml/network.cpp
+++ b/libpolyml/network.cpp
@@ -1,2221 +1,2222 @@
/*
Title: Network functions.
Copyright (c) 2000-7, 2016, 2018, 2019 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_SYS_PARAM_H
#include
#endif
#ifdef HAVE_SYS_TIME_H
#include
#endif
#ifdef HAVE_NETDB_H
#include
#endif
#ifdef HAVE_SYS_SOCKET_H
#include
#endif
#ifdef HAVE_NETINET_IN_H
#include
#endif
#ifdef HAVE_NETINET_TCP_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_SYS_IOCTL_H
#include
#endif
#ifdef HAVE_SYS_UN_H
#include
#endif
#ifdef HAVE_SYS_FILIO_H
#include
#endif
#ifdef HAVE_SYS_SOCKIO_H
#include
#endif
#ifdef HAVE_SYS_SELECT_H
#include
#endif
#ifdef HAVE_ARPA_INET_H
#include
#endif
#ifdef HAVE_LIMITS_H
#include
#endif
#ifndef HAVE_SOCKLEN_T
typedef int socklen_t;
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+
+#if (defined(_WIN32))
#include
#include // For getaddrinfo
#else
typedef int SOCKET;
#endif
#ifdef HAVE_WINDOWS_H
#include
#endif
#include
#include "globals.h"
#include "gc.h"
#include "arb.h"
#include "run_time.h"
#include "mpoly.h"
#include "processes.h"
#include "network.h"
#include "io_internal.h"
#include "sys.h"
#include "polystring.h"
#include "save_vec.h"
#include "rts_module.h"
#include "machine_dep.h"
#include "errors.h"
#include "rtsentry.h"
#include "timing.h"
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrList(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockTypeList(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocket(FirstArgument threadId, PolyWord af, PolyWord st, PolyWord prot);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetOption(FirstArgument threadId, PolyWord code, PolyWord sock, PolyWord opt);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetOption(FirstArgument threadId, PolyWord code, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSetLinger(FirstArgument threadId, PolyWord sock, PolyWord linger);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetLinger(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetPeerName(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSockName(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBytesAvailable(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAtMark(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkBind(FirstArgument threadId, PolyWord sock, PolyWord addr);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkListen(FirstArgument threadId, PolyWord sock, PolyWord back);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkShutdown(FirstArgument threadId, PolyWord skt, PolyWord smode);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateSocketPair(FirstArgument threadId, PolyWord af, PolyWord st, PolyWord prot);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixPathToSockAddr(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkUnixSockAddrToPath(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByName(FirstArgument threadId, PolyWord servName);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(FirstArgument threadId, PolyWord servName, PolyWord protName);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPort(FirstArgument threadId, PolyWord portNo);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(FirstArgument threadId, PolyWord portNo, PolyWord protName);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByName(FirstArgument threadId, PolyWord protocolName);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetProtByNo(FirstArgument threadId, PolyWord protoNo);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetHostName(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddrInfo(FirstArgument threadId, PolyWord hostName, PolyWord addrFamily);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetNameInfo(FirstArgument threadId, PolyWord sockAddr);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCloseSocket(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(FirstArgument threadId, PolyWord fdVecTriple, PolyWord maxMillisecs);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetSocketError(FirstArgument threadId, PolyWord skt);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(FirstArgument threadId, PolyWord skt, PolyWord addr);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(FirstArgument threadId, PolyWord skt);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(FirstArgument threadId, PolyWord args);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(FirstArgument threadId, PolyWord args);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(FirstArgument threadId, PolyWord args);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(FirstArgument threadId, PolyWord args);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(PolyWord sockAddress);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(FirstArgument threadId, PolyWord sockAddress);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(FirstArgument threadId, PolyWord ip4Address, PolyWord portNumber);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(FirstArgument threadId, PolyWord sockAddress);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(FirstArgument threadId, PolyWord ip6Address, PolyWord portNumber);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(FirstArgument threadId, PolyWord ip6Address);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(FirstArgument threadId, PolyWord stringRep);
}
#define SAVE(x) taskData->saveVec.push(x)
#define ALLOC(n) alloc_and_save(taskData, n)
#define SIZEOF(x) (sizeof(x)/sizeof(PolyWord))
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
static int winsock_init = 0; /* Check that it has been initialised. */
#else
#define INVALID_SOCKET (-1)
#define SOCKET_ERROR (-1)
#endif
#ifndef HAVE_SOCKLEN_T
typedef int socklen_t; // This must be int for Windows at least
#endif
#ifndef SHUT_RD
#define SHUT_RD 0
#endif
#ifndef SHUT_WR
#define SHUT_WR 1
#endif
#ifndef SHUT_RDWR
#define SHUT_RDWR 2
#endif
/* Address families. Although this table is in ascending
numerical order of address family nothing depends on that.
The only requirement is that "INET" => AF_INET must always
be present and "UNIX" => AF_UNIX must be present on Unix.
Other entries are entirely optional and are for amusement
only. */
struct af_tab_struct {
const char *af_name;
int af_num;
} af_table[] =
{
#ifdef AF_UNIX
{ "UNIX", AF_UNIX }, /* This is nearly always there. */
#endif
#ifdef AF_LOCAL
{ "LOCAL", AF_LOCAL },
#endif
{ "INET", AF_INET }, /* This one should always be there. */
#ifdef AF_IMPLINK
{ "IMPLINK", AF_IMPLINK },
#endif
#ifdef AF_PUP
{ "PUP", AF_PUP },
#endif
#ifdef AF_CHAOS
{ "CHAOS", AF_CHAOS },
#endif
#ifdef AF_IPX
{ "IPX", AF_IPX },
#endif
#ifdef AF_NS
{ "NS", AF_NS },
#endif
#ifdef AF_ISO
{ "ISO", AF_ISO },
#endif
#ifdef AF_OSI
{ "OSI", AF_OSI },
#endif
#ifdef AF_ECMA
{ "ECMA", AF_ECMA },
#endif
#ifdef AF_DATAKIT
{ "DATAKIT", AF_DATAKIT },
#endif
#ifdef AF_CCITT
{ "CCITT", AF_CCITT },
#endif
#ifdef AF_SNA
{ "SNA", AF_SNA },
#endif
#ifdef AF_DECnet
{ "DECnet", AF_DECnet },
#endif
#ifdef AF_DLI
{ "DLI", AF_DLI },
#endif
#ifdef AF_LAT
{ "LAT", AF_LAT },
#endif
#ifdef AF_HYLINK
{ "HYLINK", AF_HYLINK },
#endif
#ifdef AF_APPLETALK
{ "APPLETALK", AF_APPLETALK },
#endif
#ifdef AF_NETBIOS
{ "NETBIOS", AF_NETBIOS },
#endif
#ifdef AF_ROUTE
{ "ROUTE", AF_ROUTE },
#endif
#ifdef AF_VOICEVIEW
{ "VOICEVIEW", AF_VOICEVIEW },
#endif
#ifdef AF_FIREFOX
{ "FIREFOX", AF_FIREFOX },
#endif
#ifdef AF_BAN
{ "BAN", AF_BAN },
#endif
#ifdef AF_LINK
{ "LINK", AF_LINK },
#endif
#ifdef AF_COIP
{ "COIP", AF_COIP },
#endif
#ifdef AF_CNT
{ "CNT", AF_CNT },
#endif
#ifdef AF_SIP
{ "SIP", AF_SIP },
#endif
#ifdef AF_ISDN
{ "ISDN", AF_ISDN },
#endif
#ifdef AF_E164
{ "E164", AF_E164 },
#endif
#ifdef AF_INET6
{ "INET6", AF_INET6 }, // This one should always be there.
#endif
#ifdef AF_NATM
{ "NATM", AF_NATM },
#endif
#ifdef AF_ATM
{ "ATM", AF_ATM },
#endif
#ifdef AF_NETGRAPH
{ "NETGRAPH", AF_NETGRAPH },
#endif
#ifdef AF_CLUSTER
{ "CLUSTER", AF_CLUSTER },
#endif
#ifdef AF_12844
{ "12844", AF_12844 },
#endif
#ifdef AF_IRDA
{ "IRDA", AF_IRDA },
#endif
#ifdef AF_NETDES
{ "NETDES", AF_NETDES },
#endif
#ifdef AF_TCNPROCESS
{ "TCNPROCESS", AF_TCNPROCESS },
#endif
#ifdef AF_TCNMESSAGE
{ "TCNMESSAGE", AF_TCNMESSAGE },
#endif
#ifdef AF_ICLFXBM
{ "ICLFXBM", AF_ICLFXBM },
#endif
#ifdef AF_BTH
{ "BTH", AF_BTH },
#endif
#ifdef AF_HYPERV
{ "HYPERV", AF_HYPERV },
#endif
#ifdef AF_FILE
{ "FILE", AF_FILE },
#endif
#ifdef AF_AX25
{ "AX25", AF_AX25 },
#endif
#ifdef AF_NETROM
{ "NETROM", AF_NETROM },
#endif
#ifdef AF_BRIDGE
{ "BRIDGE", AF_BRIDGE },
#endif
#ifdef AF_ATMPVC
{ "ATMPVC", AF_ATMPVC },
#endif
#ifdef AF_X25
{ "X25", AF_X25 },
#endif
#ifdef AF_ROSE
{ "ROSE", AF_ROSE },
#endif
#ifdef AF_NETBEUI
{ "NETBEUI", AF_NETBEUI },
#endif
#ifdef AF_SECURITY
{ "SECURITY", AF_SECURITY },
#endif
#ifdef AF_KEY
{ "KEY", AF_KEY },
#endif
#ifdef AF_NETLINK
{ "NETLINK", AF_NETLINK },
#endif
#ifdef AF_PACKET
{ "PACKET", AF_PACKET },
#endif
#ifdef AF_ASH
{ "ASH", AF_ASH },
#endif
#ifdef AF_ECONET
{ "ECONET", AF_ECONET },
#endif
#ifdef AF_ATMSVC
{ "ATMSVC", AF_ATMSVC },
#endif
#ifdef AF_RDS
{ "RDS", AF_RDS },
#endif
#ifdef AF_PPPOX
{ "PPPOX", AF_PPPOX },
#endif
#ifdef AF_WANPIPE
{ "WANPIPE", AF_WANPIPE },
#endif
#ifdef AF_LLC
{ "LLC", AF_LLC },
#endif
#ifdef AF_IB
{ "IB", AF_IB },
#endif
#ifdef AF_MPLS
{ "MPLS", AF_MPLS },
#endif
#ifdef AF_CAN
{ "CAN", AF_CAN },
#endif
#ifdef AF_TIPC
{ "TIPC", AF_TIPC },
#endif
#ifdef AF_BLUETOOTH
{ "BLUETOOTH", AF_BLUETOOTH },
#endif
#ifdef AF_IUCV
{ "IUCV", AF_IUCV },
#endif
#ifdef AF_RXRPC
{ "RXRPC", AF_RXRPC },
#endif
#ifdef AF_PHONET
{ "PHONET", AF_PHONET },
#endif
#ifdef AF_IEEE802154
{ "IEEE802154", AF_IEEE802154 },
#endif
#ifdef AF_CAIF
{ "CAIF", AF_CAIF },
#endif
#ifdef AF_ALG
{ "ALG", AF_ALG },
#endif
#ifdef AF_NFC
{ "NFC", AF_NFC },
#endif
#ifdef AF_VSOCK
{ "VSOCK", AF_VSOCK },
#endif
#ifdef AF_KCM
{ "KCM", AF_KCM },
#endif
};
/* Socket types. Only STREAM and DGRAM are required. */
struct sk_tab_struct {
const char *sk_name;
int sk_num;
} sk_table[] =
{
{ "STREAM", SOCK_STREAM },
{ "DGRAM", SOCK_DGRAM },
{ "RAW", SOCK_RAW },
{ "RDM", SOCK_RDM },
{ "SEQPACKET", SOCK_SEQPACKET },
#ifdef SOCK_DCCP
{ "DCCP", SOCK_DCCP },
#endif
};
static Handle makeProtoEntry(TaskData *taskData, struct protoent *proto);
static Handle mkAftab(TaskData *taskData, void*, char *p);
static Handle mkSktab(TaskData *taskData, void*, char *p);
static Handle setSocketOption(TaskData *taskData, Handle sockHandle, Handle optHandle, int level, int opt);
static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#define GETERROR (WSAGetLastError())
#define TOOMANYFILES WSAEMFILE
#define NOMEMORY WSA_NOT_ENOUGH_MEMORY
#define STREAMCLOSED WSA_INVALID_HANDLE
#define WOULDBLOCK WSAEWOULDBLOCK
#define INPROGRESS WSAEINPROGRESS
#define CALLINTERRUPTED WSAEINTR
#undef EBADF
#undef EMFILE
#undef EAGAIN
#undef EINTR
#undef EWOULDBLOCK
#undef ENOMEM
#else
#define GETERROR (errno)
#define TOOMANYFILES EMFILE
#define NOMEMORY ENOMEM
#define STREAMCLOSED EBADF
#define ERRORNUMBER errno
#define FILEDOESNOTEXIST ENOENT
#define WOULDBLOCK EWOULDBLOCK
#define INPROGRESS EINPROGRESS
#define CALLINTERRUPTED EINTR
#endif
// Wait until "select" returns. In Windows this is used only for networking.
class WaitSelect: public Waiter
{
public:
WaitSelect(unsigned maxMillisecs=(unsigned)-1);
virtual void Wait(unsigned maxMillisecs);
void SetRead(SOCKET fd) { FD_SET(fd, &readSet); }
void SetWrite(SOCKET fd) { FD_SET(fd, &writeSet); }
void SetExcept(SOCKET fd) { FD_SET(fd, &exceptSet); }
bool IsSetRead(SOCKET fd) { return FD_ISSET(fd, &readSet) != 0; }
bool IsSetWrite(SOCKET fd) { return FD_ISSET(fd, &writeSet) != 0; }
bool IsSetExcept(SOCKET fd) { return FD_ISSET(fd, &exceptSet) != 0; }
// Save the result of the select call and any associated error
int SelectResult(void) { return selectResult; }
int SelectError(void) { return errorResult; }
private:
fd_set readSet, writeSet, exceptSet;
int selectResult;
int errorResult;
unsigned maxTime;
};
WaitSelect::WaitSelect(unsigned maxMillisecs)
{
FD_ZERO(&readSet);
FD_ZERO(&writeSet);
FD_ZERO(&exceptSet);
selectResult = 0;
errorResult = 0;
maxTime = maxMillisecs;
}
void WaitSelect::Wait(unsigned maxMillisecs)
{
if (maxTime < maxMillisecs) maxMillisecs = maxTime;
struct timeval toWait = { 0, 0 };
toWait.tv_sec = maxMillisecs / 1000;
toWait.tv_usec = (maxMillisecs % 1000) * 1000;
selectResult = select(FD_SETSIZE, &readSet, &writeSet, &exceptSet, &toWait);
if (selectResult < 0) errorResult = GETERROR;
}
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
class WinSocket : public WinStreamBase
{
public:
WinSocket(SOCKET skt) : socket(skt) {}
virtual SOCKET getSocket() {
return socket;
}
virtual int pollTest() {
// We can poll for any of these.
return POLL_BIT_IN | POLL_BIT_OUT | POLL_BIT_PRI;
}
virtual int poll(TaskData *taskData, int test);
public:
SOCKET socket;
};
// Poll without blocking.
int WinSocket::poll(TaskData *taskData, int bits)
{
int result = 0;
if (bits & POLL_BIT_PRI)
{
u_long atMark = 0;
if (ioctlsocket(socket, SIOCATMARK, &atMark) != 0)
raise_syscall(taskData, "ioctlsocket failed", GETERROR);
if (atMark) { result |= POLL_BIT_PRI; }
}
if (bits & (POLL_BIT_IN | POLL_BIT_OUT))
{
FD_SET readFds, writeFds;
TIMEVAL poll = { 0, 0 };
FD_ZERO(&readFds); FD_ZERO(&writeFds);
if (bits & POLL_BIT_IN) FD_SET(socket, &readFds);
if (bits & POLL_BIT_OUT) FD_SET(socket, &writeFds);
int selRes = select(FD_SETSIZE, &readFds, &writeFds, NULL, &poll);
if (selRes < 0)
raise_syscall(taskData, "select failed", GETERROR);
else if (selRes > 0)
{
// N.B. select only tells us about out-of-band data if SO_OOBINLINE is FALSE. */
if (FD_ISSET(socket, &readFds)) result |= POLL_BIT_IN;
if (FD_ISSET(socket, &writeFds)) result |= POLL_BIT_OUT;
}
}
return result;
}
static SOCKET getStreamSocket(TaskData *taskData, PolyWord strm)
{
WinSocket *winskt = *(WinSocket**)(strm.AsObjPtr());
if (winskt == 0)
raise_syscall(taskData, "Stream is closed", STREAMCLOSED);
return winskt->getSocket();
}
static Handle wrapStreamSocket(TaskData *taskData, SOCKET skt)
{
try {
WinSocket *winskt = new WinSocket(skt);
return MakeVolatileWord(taskData, winskt);
}
catch (std::bad_alloc&) {
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
}
}
#else
static SOCKET getStreamSocket(TaskData *taskData, PolyWord strm)
{
return getStreamFileDescriptor(taskData, strm);
}
static Handle wrapStreamSocket(TaskData *taskData, SOCKET skt)
{
return wrapFileDescriptor(taskData, skt);
}
#endif
static Handle makeProtoEntry(TaskData *taskData, struct protoent *proto)
{
int i;
char **p;
Handle aliases, name, protocol, result;
/* Canonical name. */
name = SAVE(C_string_to_Poly(taskData, proto->p_name));
/* Aliases. */
for (i=0, p = proto->p_aliases; *p != NULL; p++, i++);
aliases = convert_string_list(taskData, i, proto->p_aliases);
/* Protocol number. */
protocol = Make_fixed_precision(taskData, proto->p_proto);
/* Make the result structure. */
result = ALLOC(3);
DEREFHANDLE(result)->Set(0, name->Word());
DEREFHANDLE(result)->Set(1, aliases->Word());
DEREFHANDLE(result)->Set(2, protocol->Word());
return result;
}
static Handle makeServEntry(TaskData *taskData, struct servent *serv)
{
int i;
char **p;
Handle aliases, name, protocol, result, port;
/* Canonical name. */
name = SAVE(C_string_to_Poly(taskData, serv->s_name));
/* Aliases. */
for (i=0, p = serv->s_aliases; *p != NULL; p++, i++);
aliases = convert_string_list(taskData, i, serv->s_aliases);
/* Port number. */
port = Make_fixed_precision(taskData, ntohs(serv->s_port));
/* Protocol name. */
protocol = SAVE(C_string_to_Poly(taskData, serv->s_proto));
/* Make the result structure. */
result = ALLOC(4);
DEREFHANDLE(result)->Set(0, name->Word());
DEREFHANDLE(result)->Set(1, aliases->Word());
DEREFHANDLE(result)->Set(2, port->Word());
DEREFHANDLE(result)->Set(3, protocol->Word());
return result;
}
static Handle mkAftab(TaskData *taskData, void *arg, char *p)
{
struct af_tab_struct *af = (struct af_tab_struct *)p;
Handle result, name, num;
/* Construct a pair of the string and the number. */
name = SAVE(C_string_to_Poly(taskData, af->af_name));
num = Make_fixed_precision(taskData, af->af_num);
result = ALLOC(2);
DEREFHANDLE(result)->Set(0, name->Word());
DEREFHANDLE(result)->Set(1, num->Word());
return result;
}
static Handle mkSktab(TaskData *taskData, void *arg, char *p)
{
struct sk_tab_struct *sk = (struct sk_tab_struct *)p;
Handle result, name, num;
/* Construct a pair of the string and the number. */
name = SAVE(C_string_to_Poly(taskData, sk->sk_name));
num = Make_fixed_precision(taskData, sk->sk_num);
result = ALLOC(2);
DEREFHANDLE(result)->Set(0, name->Word());
DEREFHANDLE(result)->Set(1, num->Word());
return result;
}
/* This sets an option and can also be used to set an integer. */
static Handle setSocketOption(TaskData *taskData, Handle sockHandle, Handle optHandle, int level, int opt)
{
SOCKET sock = getStreamSocket(taskData, sockHandle->Word());
int onOff = get_C_int(taskData, optHandle->Word());
if (setsockopt(sock, level, opt,
(char*)&onOff, sizeof(int)) != 0)
raise_syscall(taskData, "setsockopt failed", GETERROR);
return Make_fixed_precision(taskData, 0);
}
// Get a socket option as an integer.
static Handle getSocketOption(TaskData *taskData, Handle args, int level, int opt)
{
SOCKET sock = getStreamSocket(taskData, args->Word());
int optVal = 0;
socklen_t size = sizeof(int);
if (getsockopt(sock, level, opt, (char*)&optVal, &size) != 0)
raise_syscall(taskData, "getsockopt failed", GETERROR);
return Make_fixed_precision(taskData, optVal);
}
// Get and clear the error state for the socket. Returns a SysWord.word value.
POLYUNSIGNED PolyNetworkGetSocketError(FirstArgument threadId, PolyWord skt)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
SOCKET sock = getStreamSocket(taskData, skt);
int intVal = 0;
socklen_t size = sizeof(int);
if (getsockopt(sock, SOL_SOCKET, SO_ERROR, (char*)&intVal, &size) != 0)
raise_syscall(taskData, "getsockopt failed", GETERROR);
result = Make_sysword(taskData, intVal);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Helper function for selectCall. Creates the result vector of active sockets.
static bool testBit(int offset, SOCKET fd, WaitSelect *pSelect)
{
switch (offset)
{
case 0: return pSelect->IsSetRead(fd);
case 1: return pSelect->IsSetWrite(fd);
case 2: return pSelect->IsSetExcept(fd);
default: return false;
}
}
static Handle getSelectResult(TaskData *taskData, Handle args, int offset, WaitSelect *pSelect)
{
/* Construct the result vectors. */
PolyObject *inVec = DEREFHANDLE(args)->Get(offset).AsObjPtr();
POLYUNSIGNED nVec = inVec->Length();
int nRes = 0;
POLYUNSIGNED i;
for (i = 0; i < nVec; i++) {
SOCKET sock = getStreamSocket(taskData, inVec->Get(i));
if (testBit(offset, sock, pSelect)) nRes++;
}
if (nRes == 0)
return ALLOC(0); /* None - return empty vector. */
else {
Handle result = ALLOC(nRes);
inVec = DEREFHANDLE(args)->Get(offset).AsObjPtr(); /* It could have moved as a result of a gc. */
nRes = 0;
for (i = 0; i < nVec; i++) {
SOCKET sock = getStreamSocket(taskData, inVec->Get(i));
if (testBit(offset, sock, pSelect))
DEREFWORDHANDLE(result)->Set(nRes++, inVec->Get(i));
}
return result;
}
}
/* Wrapper for "select" call. The arguments are arrays of socket ids. These arrays are
updated so that "active" sockets are left unchanged and inactive sockets are set to
minus one. */
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSelect(FirstArgument threadId, PolyWord fdVecTriple, PolyWord maxMillisecs)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned();
Handle fdVecTripleHandle = taskData->saveVec.push(fdVecTriple);
/* Set up the bitmaps for the select call from the arrays. */
try {
WaitSelect waitSelect((unsigned int)maxMilliseconds);
PolyObject *readVec = fdVecTripleHandle->WordP()->Get(0).AsObjPtr();
PolyObject *writeVec = fdVecTripleHandle->WordP()->Get(1).AsObjPtr();
PolyObject *excVec = fdVecTripleHandle->WordP()->Get(2).AsObjPtr();
for (POLYUNSIGNED i = 0; i < readVec->Length(); i++)
waitSelect.SetRead(getStreamSocket(taskData, readVec->Get(i)));
for (POLYUNSIGNED i = 0; i < writeVec->Length(); i++)
waitSelect.SetWrite(getStreamSocket(taskData, writeVec->Get(i)));
for (POLYUNSIGNED i = 0; i < excVec->Length(); i++)
waitSelect.SetExcept(getStreamSocket(taskData, excVec->Get(i)));
// Do the select. This may return immediately if the maximum time-out is short.
processes->ThreadPauseForIO(taskData, &waitSelect);
if (waitSelect.SelectResult() < 0)
raise_syscall(taskData, "select failed", waitSelect.SelectError());
// Construct the result vectors.
Handle rdResult = getSelectResult(taskData, fdVecTripleHandle, 0, &waitSelect);
Handle wrResult = getSelectResult(taskData, fdVecTripleHandle, 1, &waitSelect);
Handle exResult = getSelectResult(taskData, fdVecTripleHandle, 2, &waitSelect);
result = ALLOC(3);
DEREFHANDLE(result)->Set(0, rdResult->Word());
DEREFHANDLE(result)->Set(1, wrResult->Word());
DEREFHANDLE(result)->Set(2, exResult->Word());
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkConnect(FirstArgument threadId, PolyWord skt, PolyWord addr)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
SOCKET sock = getStreamSocket(taskData, skt);
PolyStringObject * psAddr = (PolyStringObject *)(addr.AsObjPtr());
struct sockaddr *psock = (struct sockaddr *)&psAddr->chars;
// Begin the connection. The socket is always non-blocking so this will return immediately.
if (connect(sock, psock, (int)psAddr->length) != 0)
raise_syscall(taskData, "connect failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned(); // Always returns unit
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkAccept(FirstArgument threadId, PolyWord skt)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
SOCKET sock = getStreamSocket(taskData, skt);
struct sockaddr_storage resultAddr;
socklen_t addrLen = sizeof(resultAddr);
SOCKET resultSkt = accept(sock, (struct sockaddr*)&resultAddr, &addrLen);
if (resultSkt == INVALID_SOCKET)
raise_syscall(taskData, "accept failed", GETERROR);
if (addrLen > sizeof(resultAddr)) addrLen = sizeof(resultAddr);
Handle addrHandle = taskData->saveVec.push(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen));
// Return a pair of the new socket and the address.
Handle resSkt = wrapStreamSocket(taskData, resultSkt);
result = alloc_and_save(taskData, 2);
result->WordP()->Set(0, resSkt->Word());
result->WordP()->Set(1, addrHandle->Word());
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSend(FirstArgument threadId, PolyWord argsAsWord)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle args = taskData->saveVec.push(argsAsWord);
#if(defined(_WIN32) && ! defined(_CYGWIN))
int sent = 0;
#else
ssize_t sent = 0;
#endif
try {
SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0));
PolyWord pBase = DEREFHANDLE(args)->Get(1);
POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2));
#if(defined(_WIN32) && ! defined(_CYGWIN))
int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3));
#else
ssize_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3));
#endif
unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4));
unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5));
int flags = 0;
if (dontRoute != 0) flags |= MSG_DONTROUTE;
if (outOfBand != 0) flags |= MSG_OOB;
char *base = (char*)pBase.AsObjPtr()->AsBytePtr();
sent = send(sock, base + offset, length, flags);
if (sent == SOCKET_ERROR)
raise_syscall(taskData, "send failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(sent).AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkSendTo(FirstArgument threadId, PolyWord argsAsWord)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle args = taskData->saveVec.push(argsAsWord);
#if(defined(_WIN32) && ! defined(_CYGWIN))
int sent = 0;
#else
ssize_t sent = 0;
#endif
try {
SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0));
PolyStringObject * psAddr = (PolyStringObject *)args->WordP()->Get(1).AsObjPtr();
PolyWord pBase = DEREFHANDLE(args)->Get(2);
POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3));
#if(defined(_WIN32) && ! defined(_CYGWIN))
int length = get_C_int(taskData, DEREFHANDLE(args)->Get(4));
#else
size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(4));
#endif
unsigned int dontRoute = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5));
unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(6));
int flags = 0;
if (dontRoute != 0) flags |= MSG_DONTROUTE;
if (outOfBand != 0) flags |= MSG_OOB;
char *base = (char*)pBase.AsObjPtr()->AsBytePtr();
sent = sendto(sock, base + offset, length, flags,
(struct sockaddr *)psAddr->chars, (int)psAddr->length);
if (sent == SOCKET_ERROR)
raise_syscall(taskData, "sendto failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(sent).AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceive(FirstArgument threadId, PolyWord argsAsWord)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle args = taskData->saveVec.push(argsAsWord);
#if(defined(_WIN32) && ! defined(_CYGWIN))
int recvd = 0;
#else
ssize_t recvd = 0;
#endif
try {
SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0));
char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr();
POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2));
#if(defined(_WIN32) && ! defined(_CYGWIN))
int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3));
#else
size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3));
#endif
unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4));
unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5));
int flags = 0;
if (peek != 0) flags |= MSG_PEEK;
if (outOfBand != 0) flags |= MSG_OOB;
recvd = recv(sock, base + offset, length, flags);
if (recvd == SOCKET_ERROR)
raise_syscall(taskData, "recv failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(recvd).AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReceiveFrom(FirstArgument threadId, PolyWord argsAsWord)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle args = taskData->saveVec.push(argsAsWord);
Handle result = 0;
try {
SOCKET sock = getStreamSocket(taskData, DEREFHANDLE(args)->Get(0));
char *base = (char*)DEREFHANDLE(args)->Get(1).AsObjPtr()->AsBytePtr();
POLYUNSIGNED offset = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(2));
#if(defined(_WIN32) && ! defined(_CYGWIN))
int length = get_C_int(taskData, DEREFHANDLE(args)->Get(3));
#else
size_t length = getPolyUnsigned(taskData, DEREFHANDLE(args)->Get(3));
#endif
unsigned int peek = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(4));
unsigned int outOfBand = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(5));
int flags = 0;
struct sockaddr_storage resultAddr;
socklen_t addrLen = sizeof(resultAddr);
if (peek != 0) flags |= MSG_PEEK;
if (outOfBand != 0) flags |= MSG_OOB;
#if(defined(_WIN32) && ! defined(_CYGWIN))
int recvd;
#else
ssize_t recvd;
#endif
recvd = recvfrom(sock, base + offset, length, flags, (struct sockaddr*)&resultAddr, &addrLen);
if (recvd == SOCKET_ERROR)
raise_syscall(taskData, "recvfrom failed", GETERROR);
if (recvd > (int)length) recvd = length;
Handle lengthHandle = Make_fixed_precision(taskData, recvd);
if (addrLen > sizeof(resultAddr)) addrLen = sizeof(resultAddr);
Handle addrHandle = SAVE(C_string_to_Poly(taskData, (char*)&resultAddr, addrLen));
result = ALLOC(2);
DEREFHANDLE(result)->Set(0, lengthHandle->Word());
DEREFHANDLE(result)->Set(1, addrHandle->Word());
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Return a list of known address families. */
POLYUNSIGNED PolyNetworkGetAddrList(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = makeList(taskData, sizeof(af_table) / sizeof(af_table[0]),
(char*)af_table, sizeof(af_table[0]), 0, mkAftab);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Return a list of known socket types. */
POLYUNSIGNED PolyNetworkGetSockTypeList(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = makeList(taskData, sizeof(sk_table) / sizeof(sk_table[0]),
(char*)sk_table, sizeof(sk_table[0]),
0, mkSktab);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Create a socket */
POLYUNSIGNED PolyNetworkCreateSocket(FirstArgument threadId, PolyWord family, PolyWord st, PolyWord prot)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
int af = (int)family.UnTagged();
int type = (int)st.UnTagged();
int proto = (int)prot.UnTagged();
try {
SOCKET skt = 0;
do {
skt = socket(af, type, proto);
} while (skt == INVALID_SOCKET && GETERROR == CALLINTERRUPTED);
if (skt == INVALID_SOCKET)
raise_syscall(taskData, "socket failed", GETERROR);
/* Set the socket to non-blocking mode. */
#if (defined(_WIN32) && ! defined(__CYGWIN__))
unsigned long onOff = 1;
if (ioctlsocket(skt, FIONBIO, &onOff) != 0)
#else
int onOff = 1;
if (ioctl(skt, FIONBIO, &onOff) < 0)
#endif
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
closesocket(skt);
#else
close(skt);
#endif
raise_syscall(taskData, "ioctl failed", GETERROR);
}
result = wrapStreamSocket(taskData, skt);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkSetOption(FirstArgument threadId, PolyWord code, PolyWord sock, PolyWord opt)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedSock = taskData->saveVec.push(sock);
Handle pushedOpt = taskData->saveVec.push(opt);
try {
switch (UNTAGGED(code))
{
case 15: /* Set TCP No-delay option. */
setSocketOption(taskData, pushedSock, pushedOpt, IPPROTO_TCP, TCP_NODELAY);
break;
case 17: /* Set Debug option. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_DEBUG);
break;
case 19: /* Set REUSEADDR option. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_REUSEADDR);
break;
case 21: /* Set KEEPALIVE option. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_KEEPALIVE);
break;
case 23: /* Set DONTROUTE option. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_DONTROUTE);
break;
case 25: /* Set BROADCAST option. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_BROADCAST);
break;
case 27: /* Set OOBINLINE option. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_OOBINLINE);
break;
case 29: /* Set SNDBUF size. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_SNDBUF);
break;
case 31: /* Set RCVBUF size. */
setSocketOption(taskData, pushedSock, pushedOpt, SOL_SOCKET, SO_RCVBUF);
break;
}
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetOption(FirstArgument threadId, PolyWord code, PolyWord arg)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
switch (UNTAGGED(code))
{
case 16: /* Get TCP No-delay option. */
result = getSocketOption(taskData, pushedArg, IPPROTO_TCP, TCP_NODELAY);
break;
case 18: /* Get Debug option. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_DEBUG);
break;
case 20: /* Get REUSEADDR option. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_REUSEADDR);
break;
case 22: /* Get KEEPALIVE option. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_KEEPALIVE);
break;
case 24: /* Get DONTROUTE option. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_DONTROUTE);
break;
case 26: /* Get BROADCAST option. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_BROADCAST);
break;
case 28: /* Get OOBINLINE option. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_OOBINLINE);
break;
case 30: /* Get SNDBUF size. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_SNDBUF);
break;
case 32: /* Get RCVBUF size. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_RCVBUF);
break;
case 33: /* Get socket type e.g. SOCK_STREAM. */
result = getSocketOption(taskData, pushedArg, SOL_SOCKET, SO_TYPE);
break;
}
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Set Linger time. */
POLYUNSIGNED PolyNetworkSetLinger(FirstArgument threadId, PolyWord sock, PolyWord lingerTime)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
SOCKET skt = getStreamSocket(taskData, sock);
int lTime = get_C_int(taskData, lingerTime);
struct linger linger;
/* We pass in a negative value to turn the option off,
zero or positive to turn it on. */
if (lTime < 0)
{
linger.l_onoff = 0;
linger.l_linger = 0;
}
else
{
linger.l_onoff = 1;
linger.l_linger = lTime;
}
if (setsockopt(skt, SOL_SOCKET, SO_LINGER,
(char*)& linger, sizeof(linger)) != 0)
raise_syscall(taskData, "setsockopt failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
/* Get Linger time. */
POLYUNSIGNED PolyNetworkGetLinger(FirstArgument threadId, PolyWord sock)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
SOCKET skt = getStreamSocket(taskData, sock);
socklen_t size = sizeof(linger);
int lTime = 0;
struct linger linger;
if (getsockopt(skt, SOL_SOCKET, SO_LINGER, (char*)& linger, &size) != 0)
raise_syscall(taskData, "getsockopt failed", GETERROR);
/* If the option is off return a negative. */
if (linger.l_onoff == 0) lTime = -1;
else lTime = linger.l_linger;
result = Make_arbitrary_precision(taskData, lTime); // Returns LargeInt.int
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Get peer name. */
POLYUNSIGNED PolyNetworkGetPeerName(FirstArgument threadId, PolyWord sock)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
SOCKET skt = getStreamSocket(taskData, sock);
struct sockaddr_storage sockA;
socklen_t size = sizeof(sockA);
if (getpeername(skt, (struct sockaddr*) & sockA, &size) != 0)
raise_syscall(taskData, "getpeername failed", GETERROR);
if (size > sizeof(sockA)) size = sizeof(sockA);
/* Addresses are treated as strings. */
result = (SAVE(C_string_to_Poly(taskData, (char*)& sockA, size)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Get socket name. */
POLYUNSIGNED PolyNetworkGetSockName(FirstArgument threadId, PolyWord sock)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
SOCKET skt = getStreamSocket(taskData, sock);
struct sockaddr_storage sockA;
socklen_t size = sizeof(sockA);
if (getsockname(skt, (struct sockaddr*) & sockA, &size) != 0)
raise_syscall(taskData, "getsockname failed", GETERROR);
if (size > sizeof(sockA)) size = sizeof(sockA);
result = (SAVE(C_string_to_Poly(taskData, (char*)& sockA, size)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Find number of bytes available. */
POLYUNSIGNED PolyNetworkBytesAvailable(FirstArgument threadId, PolyWord sock)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
SOCKET skt = getStreamSocket(taskData, sock);
#if (defined(_WIN32) && ! defined(__CYGWIN__))
unsigned long readable;
if (ioctlsocket(skt, FIONREAD, &readable) != 0)
raise_syscall(taskData, "ioctlsocket failed", GETERROR);
#else
int readable;
if (ioctl(skt, FIONREAD, &readable) < 0)
raise_syscall(taskData, "ioctl failed", GETERROR);
#endif
result = Make_fixed_precision(taskData, readable);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Find out if we are at the mark. */
POLYUNSIGNED PolyNetworkGetAtMark(FirstArgument threadId, PolyWord sock)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
SOCKET skt = getStreamSocket(taskData, sock);
#if (defined(_WIN32) && ! defined(__CYGWIN__))
unsigned long atMark;
if (ioctlsocket(skt, SIOCATMARK, &atMark) != 0)
raise_syscall(taskData, "ioctlsocket failed", GETERROR);
#else
int atMark;
if (ioctl(skt, SIOCATMARK, &atMark) < 0)
raise_syscall(taskData, "ioctl failed", GETERROR);
#endif
result = Make_fixed_precision(taskData, atMark == 0 ? 0 : 1);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Bind an address to a socket. */
POLYUNSIGNED PolyNetworkBind(FirstArgument threadId, PolyWord sock, PolyWord addr)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
SOCKET skt = getStreamSocket(taskData, sock);
PolyStringObject* psAddr = (PolyStringObject*)addr.AsObjPtr();
struct sockaddr* psock = (struct sockaddr*) & psAddr->chars;
if (bind(skt, psock, (int)psAddr->length) != 0)
raise_syscall(taskData, "bind failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
/* Put socket into listening mode. */
POLYUNSIGNED PolyNetworkListen(FirstArgument threadId, PolyWord skt, PolyWord back)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
SOCKET sock = getStreamSocket(taskData, skt);
int backlog = get_C_int(taskData, back);
if (listen(sock, backlog) != 0)
raise_syscall(taskData, "listen failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
/* Shutdown the socket. */
POLYUNSIGNED PolyNetworkShutdown(FirstArgument threadId, PolyWord skt, PolyWord smode)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
SOCKET sock = getStreamSocket(taskData, skt);
int mode = 0;
switch (get_C_ulong(taskData, smode))
{
case 1: mode = SHUT_RD; break;
case 2: mode = SHUT_WR; break;
case 3: mode = SHUT_RDWR;
}
if (shutdown(sock, mode) != 0)
raise_syscall(taskData, "shutdown failed", GETERROR);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
/* Create a socket pair. */
POLYUNSIGNED PolyNetworkCreateSocketPair(FirstArgument threadId, PolyWord family, PolyWord st, PolyWord prot)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* Not implemented. */
raise_syscall(taskData, "socketpair not implemented", WSAEAFNOSUPPORT);
#else
int af = family.UnTagged();
int type = st.UnTagged();
int proto = prot.UnTagged();
SOCKET skt[2];
int skPRes = 0;
do {
skPRes = socketpair(af, type, proto, skt);
} while (skPRes != 0 && GETERROR == CALLINTERRUPTED);
int onOff = 1;
/* Set the sockets to non-blocking mode. */
if (ioctl(skt[0], FIONBIO, &onOff) < 0 ||
ioctl(skt[1], FIONBIO, &onOff) < 0)
{
close(skt[0]);
close(skt[1]);
raise_syscall(taskData, "ioctl failed", GETERROR);
}
Handle str_token1 = wrapStreamSocket(taskData, skt[0]);
Handle str_token2 = wrapStreamSocket(taskData, skt[1]);
/* Return the two streams as a pair. */
result = ALLOC(2);
DEREFHANDLE(result)->Set(0, DEREFWORD(str_token1));
DEREFHANDLE(result)->Set(1, DEREFWORD(str_token2));
#endif
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Create a Unix socket address from a string. */
POLYUNSIGNED PolyNetworkUnixPathToSockAddr(FirstArgument threadId, PolyWord arg)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* Not implemented. */
raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT);
#else
struct sockaddr_un addr;
memset(&addr, 0, sizeof(addr));
addr.sun_family = AF_UNIX;
#ifdef HAVE_STRUCT_SOCKADDR_UN_SUN_LEN
addr.sun_len = sizeof(addr); // Used in FreeBSD only.
#endif
POLYUNSIGNED length = Poly_string_to_C(arg, addr.sun_path, sizeof(addr.sun_path));
if (length > (int)sizeof(addr.sun_path))
raise_syscall(taskData, "Address too long", ENAMETOOLONG);
result = SAVE(C_string_to_Poly(taskData, (char*)& addr, sizeof(addr)));
#endif
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Get the file name from a Unix socket address. */
POLYUNSIGNED PolyNetworkUnixSockAddrToPath(FirstArgument threadId, PolyWord arg)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* Not implemented. */
raise_syscall(taskData, "Unix addresses not implemented", WSAEAFNOSUPPORT);
#else
PolyStringObject* psAddr = (PolyStringObject*)arg.AsObjPtr();
struct sockaddr_un* psock = (struct sockaddr_un*) & psAddr->chars;
result = SAVE(C_string_to_Poly(taskData, psock->sun_path));
#endif
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetServByName(FirstArgument threadId, PolyWord serviceName)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
/* Get service given service name only. */
TempCString servName(Poly_string_to_C_alloc(serviceName));
struct servent *serv = getservbyname (servName, NULL);
// If this fails the ML function returns NONE
Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetServByNameAndProtocol(FirstArgument threadId, PolyWord serviceName, PolyWord protName)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
/* Get service given service name and protocol name. */
TempCString servName(Poly_string_to_C_alloc(serviceName));
TempCString protoName(Poly_string_to_C_alloc(protName));
struct servent *serv = getservbyname (servName, protoName);
Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetServByPort(FirstArgument threadId, PolyWord portNo)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
/* Get service given port number only. */
long port = htons(get_C_ushort(taskData, portNo));
struct servent *serv = getservbyport(port, NULL);
Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetServByPortAndProtocol(FirstArgument threadId, PolyWord portNo, PolyWord protName)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
/* Get service given port number and protocol name. */
long port = htons(get_C_ushort(taskData, portNo));
TempCString protoName(Poly_string_to_C_alloc(protName));
struct servent *serv = getservbyport (port, protoName);
Handle result = serv == NULL ? 0 : makeServEntry(taskData, serv);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetProtByName(FirstArgument threadId, PolyWord protocolName)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
/* Look up protocol entry. */
TempCString protoName(Poly_string_to_C_alloc(protocolName));
struct protoent *proto = getprotobyname(protoName);
// If this fails the ML function returns NONE
Handle result = proto == NULL ? 0 : makeProtoEntry(taskData, proto);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetProtByNo(FirstArgument threadId, PolyWord protoNo)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
/* Look up protocol entry. */
int pNum = get_C_int(taskData, protoNo);
struct protoent *proto = getprotobynumber(pNum);
Handle result = proto == NULL ? 0 : makeProtoEntry(taskData, proto);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetHostName(FirstArgument threadId)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try { /* Get the current host name. */
// Since the maximum length of a FQDN is 256 bytes it should fit in the buffer.
#ifdef HOST_NAME_MAX
char hostName[HOST_NAME_MAX+1];
#else
char hostName[1024];
#endif
int err = gethostname(hostName, sizeof(hostName));
if (err != 0)
raise_syscall(taskData, "gethostname failed", GETERROR);
// Add a null at the end just in case. See gethostname man page.
hostName[sizeof(hostName) - 1] = 0;
result = SAVE(C_string_to_Poly(taskData, hostName));
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkGetNameInfo(FirstArgument threadId, PolyWord sockAddr)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
PolyStringObject* psAddr = (PolyStringObject*)sockAddr.AsObjPtr();
struct sockaddr* psock = (struct sockaddr*) & psAddr->chars;
// Since the maximum length of a FQDN is 256 bytes it should fit in the buffer.
char hostName[1024];
int gniRes = getnameinfo(psock, (socklen_t)psAddr->length, hostName, sizeof(hostName), NULL, 0, 0);
if (gniRes != 0)
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
raise_syscall(taskData, "getnameinfo failed", GETERROR);
#else
if (gniRes == EAI_SYSTEM)
raise_syscall(taskData, "getnameinfo failed", GETERROR);
else raise_syscall(taskData, gai_strerror(gniRes), 0);
#endif
}
result = SAVE(C_string_to_Poly(taskData, hostName));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Copy addrInfo data into ML memory. We copy this although most of it
// is currently unused.
static Handle extractAddrInfo(TaskData *taskData, struct addrinfo *ainfo)
{
if (ainfo == 0)
return taskData->saveVec.push(ListNull);
Handle reset = taskData->saveVec.mark();
Handle tail = extractAddrInfo(taskData, ainfo->ai_next);
Handle name = 0;
// Only the first entry may have a canonical name.
if (ainfo->ai_canonname == 0)
name = taskData->saveVec.push(C_string_to_Poly(taskData, ""));
else name = taskData->saveVec.push(C_string_to_Poly(taskData, ainfo->ai_canonname));
Handle address = taskData->saveVec.push(C_string_to_Poly(taskData, (char*)ainfo->ai_addr, ainfo->ai_addrlen));
Handle value = alloc_and_save(taskData, 6);
value->WordP()->Set(0, TAGGED(ainfo->ai_flags));
value->WordP()->Set(1, TAGGED(ainfo->ai_family));
value->WordP()->Set(2, TAGGED(ainfo->ai_socktype));
value->WordP()->Set(3, TAGGED(ainfo->ai_protocol));
value->WordP()->Set(4, address->Word());
value->WordP()->Set(5, name->Word());
ML_Cons_Cell *next = (ML_Cons_Cell*)alloc(taskData, SIZEOF(ML_Cons_Cell));
next->h = value->Word();
next->t = tail->Word();
taskData->saveVec.reset(reset);
return taskData->saveVec.push(next);
}
POLYUNSIGNED PolyNetworkGetAddrInfo(FirstArgument threadId, PolyWord hName, PolyWord addrFamily)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
struct addrinfo *resAddr = 0;
try {
TempCString hostName(Poly_string_to_C_alloc(hName));
struct addrinfo hints;
memset(&hints, 0, sizeof(hints));
hints.ai_family = (int)UNTAGGED(addrFamily); // AF_INET or AF_INET6 or, possibly, AF_UNSPEC.
hints.ai_flags = AI_CANONNAME;
int gaiRes = getaddrinfo(hostName, 0, &hints, &resAddr);
if (gaiRes != 0)
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
raise_syscall(taskData, "getaddrinfo failed", GETERROR);
#else
if (gaiRes == EAI_SYSTEM)
raise_syscall(taskData, "getnameinfo failed", GETERROR);
else raise_syscall(taskData, gai_strerror(gaiRes), 0);
#endif
}
result = extractAddrInfo(taskData, resAddr);
}
catch (...) { } // Could raise an exception if we run out of heap space
if (resAddr) freeaddrinfo(resAddr);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYUNSIGNED PolyNetworkCloseSocket(FirstArgument threadId, PolyWord strm)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
Handle pushedStream = taskData->saveVec.push(strm);
try {
// This is defined to raise an exception if the socket has already been closed
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
WinSocket *winskt = *(WinSocket**)(pushedStream->WordP());
if (winskt != 0)
{
if (closesocket(winskt->getSocket()) != 0)
raise_syscall(taskData, "Error during close", GETERROR);
}
else raise_syscall(taskData, "Socket is closed", WSAEBADF);
*(WinSocket **)(pushedStream->WordP()) = 0; // Mark as closed
#else
int descr = getStreamFileDescriptorWithoutCheck(pushedStream->Word());
if (descr >= 0)
{
if (close(descr) != 0)
raise_syscall(taskData, "Error during close", GETERROR);
}
else raise_syscall(taskData, "Socket is closed", EBADF);
*(int*)(pushedStream->WordP()) = 0; // Mark as closed
#endif
result = Make_fixed_precision(taskData, 0);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Return the family
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetFamilyFromAddress(PolyWord sockAddress)
{
PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr();
struct sockaddr* psock = (struct sockaddr*) & psAddr->chars;
return TAGGED(psock->sa_family).AsUnsigned();
}
// Return internet address and port from an internet socket address.
// Assumes that we've already checked the address family.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP4(FirstArgument threadId, PolyWord sockAddress)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr();
struct sockaddr_in* psock = (struct sockaddr_in*) & psAddr->chars;
Handle ipAddr = Make_arbitrary_precision(taskData, ntohl(psock->sin_addr.s_addr)); // IPv4 addr is LargeInt.int
result = alloc_and_save(taskData, 2);
result->WordP()->Set(0, ipAddr->Word());
result->WordP()->Set(1, TAGGED(ntohs(psock->sin_port)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Create a socket address from a port number and internet address.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP4Address(FirstArgument threadId, PolyWord ip4Address, PolyWord portNumber)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
struct sockaddr_in sockaddr;
memset(&sockaddr, 0, sizeof(sockaddr));
sockaddr.sin_family = AF_INET;
sockaddr.sin_port = htons(get_C_ushort(taskData, portNumber));
sockaddr.sin_addr.s_addr = htonl(get_C_unsigned(taskData, ip4Address));
result = SAVE(C_string_to_Poly(taskData, (char*)&sockaddr, sizeof(sockaddr)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Return the value of INADDR_ANY.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP4AddressAny(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = Make_arbitrary_precision(taskData, INADDR_ANY); // IPv4 addr is LargeInt.int
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkGetAddressAndPortFromIP6(FirstArgument threadId, PolyWord sockAddress)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
PolyStringObject* psAddr = (PolyStringObject*)sockAddress.AsObjPtr();
if (psAddr->length != sizeof(struct sockaddr_in6))
raise_fail(taskData, "Invalid length");
struct sockaddr_in6* psock = (struct sockaddr_in6*) & psAddr->chars;
Handle ipAddr = SAVE(C_string_to_Poly(taskData, (const char*)&psock->sin6_addr, sizeof(struct in6_addr)));
result = alloc_and_save(taskData, 2);
result->WordP()->Set(0, ipAddr->Word());
result->WordP()->Set(1, TAGGED(ntohs(psock->sin6_port)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkCreateIP6Address(FirstArgument threadId, PolyWord ip6Address, PolyWord portNumber)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
struct sockaddr_in6 addr;
memset(&addr, 0, sizeof(addr));
result = SAVE(C_string_to_Poly(taskData, (const char*)&addr, sizeof(struct in6_addr)));
addr.sin6_family = AF_INET6;
addr.sin6_port = htons(get_C_ushort(taskData, portNumber));
PolyStringObject* addrAsString = (PolyStringObject*)ip6Address.AsObjPtr();
if (addrAsString->length != sizeof(addr.sin6_addr))
raise_fail(taskData, "Invalid address length");
memcpy(&addr.sin6_addr, addrAsString->chars, sizeof(addr.sin6_addr));
result = SAVE(C_string_to_Poly(taskData, (char*)&addr, sizeof(addr)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkReturnIP6AddressAny(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = SAVE(C_string_to_Poly(taskData, (const char*)&in6addr_any, sizeof(struct in6_addr)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Convert an IPV6 address to string. This could be done in ML but the rules
// for converting zeros to double-colon are complicated.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkIP6AddressToString(FirstArgument threadId, PolyWord ip6Address)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
char buffer[80]; // 40 should actually be enough: 32 hex bytes, 7 colons and a null.
PolyStringObject* addrAsString = (PolyStringObject*)ip6Address.AsObjPtr();
if (addrAsString->length != sizeof(struct in6_addr))
raise_fail(taskData, "Invalid address length");
if (inet_ntop(AF_INET6, addrAsString->chars, buffer, sizeof(buffer)) == 0)
raise_syscall(taskData, "inet_ntop", GETERROR);
result = SAVE(C_string_to_Poly(taskData, buffer));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Convert a string to an IPv6 address. The parsing has to be done in ML.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyNetworkStringToIP6Address(FirstArgument threadId, PolyWord stringRep)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
struct in6_addr address;
TempCString stringAddr(Poly_string_to_C_alloc(stringRep));
if (inet_pton(AF_INET6, stringAddr, &address) != 1)
raise_fail(taskData, "Invalid IPv6 address");
result = taskData->saveVec.push(C_string_to_Poly(taskData, (const char *)&address, sizeof(struct in6_addr)));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
struct _entrypts networkingEPT[] =
{
{ "PolyNetworkGetAddrList", (polyRTSFunction)&PolyNetworkGetAddrList},
{ "PolyNetworkGetSockTypeList", (polyRTSFunction)&PolyNetworkGetSockTypeList},
{ "PolyNetworkCreateSocket", (polyRTSFunction)&PolyNetworkCreateSocket},
{ "PolyNetworkSetOption", (polyRTSFunction)&PolyNetworkSetOption},
{ "PolyNetworkGetOption", (polyRTSFunction)&PolyNetworkGetOption},
{ "PolyNetworkSetLinger", (polyRTSFunction)&PolyNetworkSetLinger},
{ "PolyNetworkGetLinger", (polyRTSFunction)&PolyNetworkGetLinger},
{ "PolyNetworkGetPeerName", (polyRTSFunction)&PolyNetworkGetPeerName},
{ "PolyNetworkGetSockName", (polyRTSFunction)&PolyNetworkGetSockName},
{ "PolyNetworkBytesAvailable", (polyRTSFunction)&PolyNetworkBytesAvailable},
{ "PolyNetworkGetAtMark", (polyRTSFunction)&PolyNetworkGetAtMark},
{ "PolyNetworkBind", (polyRTSFunction)&PolyNetworkBind},
{ "PolyNetworkListen", (polyRTSFunction)&PolyNetworkListen},
{ "PolyNetworkShutdown", (polyRTSFunction)&PolyNetworkShutdown},
{ "PolyNetworkCreateSocketPair", (polyRTSFunction)&PolyNetworkCreateSocketPair},
{ "PolyNetworkUnixPathToSockAddr", (polyRTSFunction)&PolyNetworkUnixPathToSockAddr},
{ "PolyNetworkUnixSockAddrToPath", (polyRTSFunction)&PolyNetworkUnixSockAddrToPath},
{ "PolyNetworkGetServByName", (polyRTSFunction)&PolyNetworkGetServByName},
{ "PolyNetworkGetServByNameAndProtocol", (polyRTSFunction)&PolyNetworkGetServByNameAndProtocol},
{ "PolyNetworkGetServByPort", (polyRTSFunction)&PolyNetworkGetServByPort},
{ "PolyNetworkGetServByPortAndProtocol", (polyRTSFunction)&PolyNetworkGetServByPortAndProtocol},
{ "PolyNetworkGetProtByName", (polyRTSFunction)&PolyNetworkGetProtByName},
{ "PolyNetworkGetProtByNo", (polyRTSFunction)&PolyNetworkGetProtByNo},
{ "PolyNetworkGetHostName", (polyRTSFunction)&PolyNetworkGetHostName},
{ "PolyNetworkGetNameInfo", (polyRTSFunction)&PolyNetworkGetNameInfo},
{ "PolyNetworkCloseSocket", (polyRTSFunction)&PolyNetworkCloseSocket },
{ "PolyNetworkSelect", (polyRTSFunction)&PolyNetworkSelect },
{ "PolyNetworkGetSocketError", (polyRTSFunction)&PolyNetworkGetSocketError },
{ "PolyNetworkConnect", (polyRTSFunction)&PolyNetworkConnect },
{ "PolyNetworkAccept", (polyRTSFunction)&PolyNetworkAccept },
{ "PolyNetworkSend", (polyRTSFunction)&PolyNetworkSend },
{ "PolyNetworkSendTo", (polyRTSFunction)&PolyNetworkSendTo },
{ "PolyNetworkReceive", (polyRTSFunction)&PolyNetworkReceive },
{ "PolyNetworkReceiveFrom", (polyRTSFunction)&PolyNetworkReceiveFrom },
{ "PolyNetworkGetAddrInfo", (polyRTSFunction)&PolyNetworkGetAddrInfo },
{ "PolyNetworkGetFamilyFromAddress", (polyRTSFunction)&PolyNetworkGetFamilyFromAddress },
{ "PolyNetworkGetAddressAndPortFromIP4", (polyRTSFunction)&PolyNetworkGetAddressAndPortFromIP4 },
{ "PolyNetworkCreateIP4Address", (polyRTSFunction)&PolyNetworkCreateIP4Address },
{ "PolyNetworkReturnIP4AddressAny", (polyRTSFunction)&PolyNetworkReturnIP4AddressAny },
{ "PolyNetworkGetAddressAndPortFromIP6", (polyRTSFunction)&PolyNetworkGetAddressAndPortFromIP6 },
{ "PolyNetworkCreateIP6Address", (polyRTSFunction)&PolyNetworkCreateIP6Address },
{ "PolyNetworkReturnIP6AddressAny", (polyRTSFunction)&PolyNetworkReturnIP4AddressAny },
{ "PolyNetworkIP6AddressToString", (polyRTSFunction)&PolyNetworkIP6AddressToString },
{ "PolyNetworkStringToIP6Address", (polyRTSFunction)&PolyNetworkStringToIP6Address },
{ NULL, NULL} // End of list.
};
class Networking: public RtsModule
{
public:
virtual void Init(void);
virtual void Stop(void);
};
// Declare this. It will be automatically added to the table.
static Networking networkingModule;
void Networking::Init(void)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#define WINSOCK_MAJOR_VERSION 2
#define WINSOCK_MINOR_VERSION 2
WSADATA wsaData;
WORD wVersion = MAKEWORD(WINSOCK_MINOR_VERSION, WINSOCK_MAJOR_VERSION);
/* Initialise the system and check that the version it supplied
is the one we requested. */
if(WSAStartup(wVersion, &wsaData) == 0)
{
if (wsaData.wVersion == wVersion)
winsock_init = 1;
else WSACleanup();
}
#endif
}
void Networking::Stop(void)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
if (winsock_init) WSACleanup();
winsock_init = 0;
#endif
}
diff --git a/libpolyml/poly_specific.cpp b/libpolyml/poly_specific.cpp
index e62e3f41..89c7a8e9 100644
--- a/libpolyml/poly_specific.cpp
+++ b/libpolyml/poly_specific.cpp
@@ -1,437 +1,447 @@
/*
Title: poly_specific.cpp - Poly/ML specific RTS calls.
Copyright (c) 2006, 2015-17, 2019 David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
/* This module is used for various run-time calls that are either in the
PolyML structure or otherwise specific to Poly/ML. */
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
#ifdef HAVE_STRING_H
#include
#endif
#include "globals.h"
#include "poly_specific.h"
#include "arb.h"
#include "mpoly.h"
#include "sys.h"
#include "machine_dep.h"
#include "polystring.h"
#include "run_time.h"
#include "version.h"
#include "save_vec.h"
#include "version.h"
#include "memmgr.h"
#include "processes.h"
#include "gc.h"
#include "rtsentry.h"
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI();
POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(FirstArgument threadId, PolyWord byteSeg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(FirstArgument threadId, PolyWord byteVec);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure);
POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord c, PolyWord flags);
POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord c);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset);
POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5);
}
#define SAVE(x) taskData->saveVec.push(x)
#ifndef GIT_VERSION
#define GIT_VERSION ""
#endif
Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORD(code));
switch (c)
{
case 9: // Return the GIT version if appropriate
{
return SAVE(C_string_to_Poly(taskData, GIT_VERSION));
}
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 12: // Return the architecture
// Used in InitialPolyML.ML for PolyML.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;
case MA_X86_64_32: arch = "X86_64_32"; break;
default: arch = "Unknown"; break;
}
return SAVE(C_string_to_Poly(taskData, arch));
}
case 19: // Return the RTS argument help string.
return SAVE(C_string_to_Poly(taskData, RTSArgHelp()));
default:
{
char msg[100];
sprintf(msg, "Unknown poly-specific function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
// General interface to poly-specific. Ideally the various cases will be made into
// separate functions.
POLYUNSIGNED PolySpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedCode = taskData->saveVec.push(code);
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = poly_dispatch_c(taskData, pushedArg, pushedCode);
} catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Return the ABI - i.e. the calling conventions used when calling external functions.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetABI()
{
// Return the ABI. For 64-bit we need to know if this is Windows.
#if (SIZEOF_VOIDP == 8)
#if (defined(_WIN32) || defined(__CYGWIN__))
return TAGGED(2).AsUnsigned(); // 64-bit Windows
#else
return TAGGED(1).AsUnsigned(); // 64-bit Unix
#endif
#else
return TAGGED(0).AsUnsigned(); // 32-bit Unix and Windows
#endif
}
// Code generation - Code is initially allocated in a byte segment. When all the
// values have been set apart from any addresses the byte segment is copied into
// a mutable code segment.
// PolyCopyByteVecToCode is now replaced by PolyCopyByteVecToClosure
POLYEXTERNALSYMBOL POLYUNSIGNED PolyCopyByteVecToCode(FirstArgument threadId, PolyWord byteVec)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(byteVec);
PolyObject *result = 0;
try {
if (!pushedArg->WordP()->IsByteObject())
raise_fail(taskData, "Not byte data area");
do {
PolyObject *initCell = pushedArg->WordP();
POLYUNSIGNED requiredSize = initCell->Length();
result = gMem.AllocCodeSpace(requiredSize);
if (result == 0)
{
// Could not allocate - must GC.
if (!QuickGC(taskData, pushedArg->WordP()->Length()))
raise_fail(taskData, "Insufficient memory");
}
else memcpy(result, initCell, requiredSize * sizeof(PolyWord));
} while (result == 0);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return ((PolyWord)result).AsUnsigned();
}
// Copy the byte vector into code space.
POLYUNSIGNED PolyCopyByteVecToClosure(FirstArgument threadId, PolyWord byteVec, PolyWord closure)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedByteVec = taskData->saveVec.push(byteVec);
Handle pushedClosure = taskData->saveVec.push(closure);
PolyObject *result = 0;
try {
if (!pushedByteVec->WordP()->IsByteObject())
raise_fail(taskData, "Not byte data area");
if (pushedClosure->WordP()->Length() != sizeof(PolyObject*)/sizeof(PolyWord))
raise_fail(taskData, "Invalid closure size");
if (!pushedClosure->WordP()->IsMutable())
raise_fail(taskData, "Closure is not mutable");
do {
PolyObject *initCell = pushedByteVec->WordP();
POLYUNSIGNED requiredSize = initCell->Length();
result = gMem.AllocCodeSpace(requiredSize);
if (result == 0)
{
// Could not allocate - must GC.
if (!QuickGC(taskData, pushedByteVec->WordP()->Length()))
raise_fail(taskData, "Insufficient memory");
}
else memcpy(result, initCell, requiredSize * sizeof(PolyWord));
} while (result == 0);
}
catch (...) {} // If an ML exception is raised
// Store the code address in the closure.
*((PolyObject**)pushedClosure->WordP()) = result;
// Lock the closure.
pushedClosure->WordP()->SetLengthWord(pushedClosure->WordP()->LengthWord() & ~_OBJ_MUTABLE_BIT);
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
// Code generation - Lock a mutable code segment and return the original address.
// Currently this does not allocate so other than the exception it could
// be a fast call.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableCode(FirstArgument threadId, PolyWord byteSeg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(byteSeg);
Handle result = 0;
try {
PolyObject *codeObj = pushedArg->WordP();
if (!codeObj->IsCodeObject() || !codeObj->IsMutable())
raise_fail(taskData, "Not mutable code area");
POLYUNSIGNED segLength = codeObj->Length();
codeObj->SetLengthWord(segLength, F_CODE_OBJ);
// In the future it may be necessary to return a different address here.
// N.B. The code area should only have execute permission in the native
// code version, not the interpreted version.
result = pushedArg; // Return the original address.
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Replacement for above
POLYEXTERNALSYMBOL POLYUNSIGNED PolyLockMutableClosure(FirstArgument threadId, PolyWord closure)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
PolyObject *codeObj = *(PolyObject**)(closure.AsObjPtr());
try {
if (!codeObj->IsCodeObject() || !codeObj->IsMutable())
raise_fail(taskData, "Not mutable code area");
POLYUNSIGNED segLength = codeObj->Length();
codeObj->SetLengthWord(segLength, F_CODE_OBJ);
// In the future it may be necessary to return a different address here.
// N.B. The code area should only have execute permission in the native
// code version, not the interpreted version.
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
// Set code constant. This can be a fast call.
// This is in the RTS both because we pass a closure in here and cannot have
// code addresses in 32-in-64 and also because we need to ensure there is no
// possibility of a GC while the code is an inconsistent state.
POLYUNSIGNED PolySetCodeConstant(PolyWord closure, PolyWord offset, PolyWord cWord, PolyWord flags)
{
byte *pointer;
// Previously we passed the code address in here and we need to
// retain that for legacy code. This is now the closure.
if (closure.AsObjPtr()->IsCodeObject())
pointer = closure.AsCodePtr();
else pointer = *(POLYCODEPTR*)(closure.AsObjPtr());
// pointer is the start of the code segment.
// c will usually be an address.
// offset is a byte offset
pointer += offset.UnTaggedUnsigned();
switch (UNTAGGED(flags))
{
case 0: // Absolute constant - size PolyWord
{
POLYUNSIGNED c = cWord.AsUnsigned();
+#ifdef WORDS_BIGENDIAN
+ // This is used to store constants in the constant area
+ // on the interpreted version.
+ for (unsigned i = sizeof(PolyWord); i > 0; i--)
+ {
+ pointer[i-1] = (byte)(c & 255);
+ c >>= 8;
+ }
+#else
for (unsigned i = 0; i < sizeof(PolyWord); i++)
{
pointer[i] = (byte)(c & 255);
c >>= 8;
}
+#endif
break;
}
case 1: // Relative constant - X86 - size 4 bytes
{
// The offset is relative to the END of the constant.
byte *target;
// In 32-in-64 we pass in the closure address here
// rather than the code address.
if (cWord.AsObjPtr()->IsCodeObject())
target = cWord.AsCodePtr();
else target = *(POLYCODEPTR*)(cWord.AsObjPtr());
size_t c = target - pointer - 4;
for (unsigned i = 0; i < sizeof(PolyWord); i++)
{
pointer[i] = (byte)(c & 255);
c >>= 8;
}
break;
}
}
return TAGGED(0).AsUnsigned();
}
// Set a code byte. This needs to be in the RTS because it uses the closure
POLYEXTERNALSYMBOL POLYUNSIGNED PolySetCodeByte(PolyWord closure, PolyWord offset, PolyWord cWord)
{
byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr());
pointer[UNTAGGED_UNSIGNED(offset)] = (byte)UNTAGGED_UNSIGNED(cWord);
return TAGGED(0).AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetCodeByte(PolyWord closure, PolyWord offset)
{
byte *pointer = *(POLYCODEPTR*)(closure.AsObjPtr());
return TAGGED(pointer[UNTAGGED_UNSIGNED(offset)]).AsUnsigned();
}
static int compare(const void *a, const void *b)
{
PolyWord *av = (PolyWord*)a;
PolyWord *bv = (PolyWord*)b;
if ((*av).IsTagged() || (*bv).IsTagged()) return 0; // Shouldn't happen
PolyObject *ao = (*av).AsObjPtr(), *bo = (*bv).AsObjPtr();
if (ao->Length() < 1 || bo->Length() < 1) return 0; // Shouldn't happen
if (ao->Get(0).AsUnsigned() < bo->Get(0).AsUnsigned())
return -1;
if (ao->Get(0).AsUnsigned() > bo->Get(0).AsUnsigned())
return 1;
return 0;
}
// Sort an array of addresses. This is used in the code-generator to search for
// duplicates in the address area. The argument is an array of pairs. The first
// item of each pair is an address, the second is an identifier of some kind.
POLYEXTERNALSYMBOL POLYUNSIGNED PolySortArrayOfAddresses(PolyWord array)
{
if (!array.IsDataPtr()) return(TAGGED(0)).AsUnsigned();
PolyObject *arrayP = array.AsObjPtr();
POLYUNSIGNED numberOfItems = arrayP->Length();
if (!arrayP->IsMutable()) return(TAGGED(0)).AsUnsigned();
qsort(arrayP, numberOfItems, sizeof(PolyWord), compare);
return (TAGGED(1)).AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest4(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4)
{
switch (arg1.UnTaggedUnsigned())
{
case 1: return arg1.AsUnsigned();
case 2: return arg2.AsUnsigned();
case 3: return arg3.AsUnsigned();
case 4: return arg4.AsUnsigned();
default: return TAGGED(0).AsUnsigned();
}
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyTest5(FirstArgument threadId, PolyWord arg1, PolyWord arg2, PolyWord arg3, PolyWord arg4, PolyWord arg5)
{
switch (arg1.UnTaggedUnsigned())
{
case 1: return arg1.AsUnsigned();
case 2: return arg2.AsUnsigned();
case 3: return arg3.AsUnsigned();
case 4: return arg4.AsUnsigned();
case 5: return arg5.AsUnsigned();
default: return TAGGED(0).AsUnsigned();
}
}
struct _entrypts polySpecificEPT[] =
{
{ "PolySpecificGeneral", (polyRTSFunction)&PolySpecificGeneral},
{ "PolyGetABI", (polyRTSFunction)&PolyGetABI },
{ "PolyCopyByteVecToCode", (polyRTSFunction)&PolyCopyByteVecToCode },
{ "PolyCopyByteVecToClosure", (polyRTSFunction)&PolyCopyByteVecToClosure },
{ "PolyLockMutableCode", (polyRTSFunction)&PolyLockMutableCode },
{ "PolyLockMutableClosure", (polyRTSFunction)&PolyLockMutableClosure },
{ "PolySetCodeConstant", (polyRTSFunction)&PolySetCodeConstant },
{ "PolySetCodeByte", (polyRTSFunction)&PolySetCodeByte },
{ "PolyGetCodeByte", (polyRTSFunction)&PolyGetCodeByte },
{ "PolySortArrayOfAddresses", (polyRTSFunction)&PolySortArrayOfAddresses },
{ "PolyTest4", (polyRTSFunction)&PolyTest4 },
{ "PolyTest5", (polyRTSFunction)&PolyTest5 },
{ NULL, NULL} // End of list.
};
diff --git a/libpolyml/polyffi.cpp b/libpolyml/polyffi.cpp
index 7c9feb2a..4bfad935 100644
--- a/libpolyml/polyffi.cpp
+++ b/libpolyml/polyffi.cpp
@@ -1,687 +1,686 @@
/*
Title: New Foreign Function Interface
- Copyright (c) 2015, 2018 David C.J. Matthews
+ Copyright (c) 2015, 2018, 2019 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#if (defined(_WIN32) || (defined(HAVE_DLOPEN)))
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_DLFCN_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_MALLOC_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#include "globals.h"
// TODO: Do we need this??
// We need to include globals.h before in mingw64 otherwise
// it messes up POLYUFMT/POLYSFMT.
#include
#include
#include "arb.h"
#include "save_vec.h"
#include "polyffi.h"
#include "run_time.h"
#include "sys.h"
#include "processes.h"
#include "polystring.h"
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#include "winstartup.h" /* For hApplicationInstance. */
#endif
#include "scanaddrs.h"
#include "diagnostics.h"
#include "reals.h"
#include "rts_module.h"
#include "rtsentry.h"
static Handle poly_ffi (TaskData *taskData, Handle args, Handle code);
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeFloat();
POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeDouble();
POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetError(PolyWord addr);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFISetError(PolyWord err);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg);
}
static struct _abiTable { const char *abiName; ffi_abi abiCode; } abiTable[] =
{
// Unfortunately the ABI entries are enums rather than #defines so we
// can't test individual entries.
#ifdef X86_WIN32
{"sysv", FFI_SYSV},
{"stdcall", FFI_STDCALL},
{"thiscall", FFI_THISCALL},
{"fastcall", FFI_FASTCALL},
{"ms_cdecl", FFI_MS_CDECL},
#elif defined(X86_WIN64)
{"win64", FFI_WIN64},
#elif defined(X86_ANY)
- {"sysv", FFI_SYSV},
{"unix64", FFI_UNIX64},
#endif
{ "default", FFI_DEFAULT_ABI}
};
// Table of constants returned by call 51
static int constantTable[] =
{
FFI_DEFAULT_ABI, // Default ABI
FFI_TYPE_VOID, // Type codes
FFI_TYPE_INT,
FFI_TYPE_FLOAT,
FFI_TYPE_DOUBLE,
FFI_TYPE_UINT8,
FFI_TYPE_SINT8,
FFI_TYPE_UINT16,
FFI_TYPE_SINT16,
FFI_TYPE_UINT32,
FFI_TYPE_SINT32,
FFI_TYPE_UINT64,
FFI_TYPE_SINT64,
FFI_TYPE_STRUCT,
FFI_TYPE_POINTER,
FFI_SIZEOF_ARG // Minimum size for result space
};
// Table of predefined ffi types
static ffi_type *ffiTypeTable[] =
{
&ffi_type_void,
&ffi_type_uint8,
&ffi_type_sint8,
&ffi_type_uint16,
&ffi_type_sint16,
&ffi_type_uint32,
&ffi_type_sint32,
&ffi_type_uint64,
&ffi_type_sint64,
&ffi_type_float,
&ffi_type_double,
&ffi_type_pointer,
&ffi_type_uchar, // These are all aliases for the above
&ffi_type_schar,
&ffi_type_ushort,
&ffi_type_sshort,
&ffi_type_uint,
&ffi_type_sint,
&ffi_type_ulong,
&ffi_type_slong
};
// Callback entry table
static struct _cbStructEntry {
PolyWord mlFunction; // The ML function to call
void *closureSpace; // Space allocated for the closure
void *resultFunction; // Executable address for the function. Needed to free.
} *callbackTable;
static unsigned callBackEntries = 0;
static PLock callbackTableLock; // Mutex to protect table.
static Handle mkAbitab(TaskData *taskData, void*, char *p);
static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data);
static Handle toSysWord(TaskData *taskData, void *p)
{
return Make_sysword(taskData, (uintptr_t)p);
}
Handle poly_ffi(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, code->Word());
switch (c)
{
case 0: // malloc
{
POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word());
return toSysWord(taskData, malloc(size));
}
case 1: // free
{
void *mem = *(void**)(args->WordP());
free(mem);
return taskData->saveVec.push(TAGGED(0));
}
case 2: // Load library
{
TempString libName(args->Word());
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
HINSTANCE lib = LoadLibrary(libName);
if (lib == NULL)
{
char buf[256];
#if (defined(UNICODE))
_snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", (LPCTSTR)libName, GetLastError());
#else
_snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", (const char*)libName, GetLastError());
#endif
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = dlopen(libName, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char *)libName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 3: // Load address of executable.
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
HINSTANCE lib = hApplicationInstance;
#else
void *lib = dlopen(NULL, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 4: // Unload library - Is this actually going to be used?
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
HMODULE hMod = *(HMODULE*)(args->WordP());
if (! FreeLibrary(hMod))
raise_syscall(taskData, "FreeLibrary failed", GetLastError());
#else
void *lib = *(void**)(args->WordP());
if (dlclose(lib) != 0)
{
char buf[256];
snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return taskData->saveVec.push(TAGGED(0));
}
case 5: // Load the address of a symbol from a library.
{
TempCString symName(args->WordP()->Get(1));
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress());
void *sym = (void*)GetProcAddress(hMod, symName);
if (sym == NULL)
{
char buf[256];
_snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", (LPCSTR)symName, GetLastError());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = *(void**)(args->WordP()->Get(0).AsAddress());
void *sym = dlsym(lib, symName);
if (sym == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char *)symName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, sym);
}
// Libffi functions
case 50: // Return a list of available ABIs
return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]),
(char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab);
case 51: // A constant from the table
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(constantTable) / sizeof(constantTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return Make_arbitrary_precision(taskData, constantTable[index]);
}
case 52: // Return an FFI type
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return toSysWord(taskData, ffiTypeTable[index]);
}
case 53: // Extract fields from ffi type.
{
ffi_type *ffit = *(ffi_type**)(args->WordP());
Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size);
Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment);
Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type);
Handle elemHandle = toSysWord(taskData, ffit->elements);
Handle resHandle = alloc_and_save(taskData, 4);
resHandle->WordP()->Set(0, sizeHandle->Word());
resHandle->WordP()->Set(1, alignHandle->Word());
resHandle->WordP()->Set(2, typeHandle->Word());
resHandle->WordP()->Set(3, elemHandle->Word());
return resHandle;
}
case 54: // Construct an ffi type.
{
// This is probably only used to create structs.
size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0));
unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1));
unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2));
unsigned nElems = 0;
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nElems++;
size_t space = sizeof(ffi_type);
// If we need the elements add space for the elements plus
// one extra for the zero terminator.
if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *);
ffi_type *result = (ffi_type*)calloc(1, space);
// Raise an exception rather than returning zero.
if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **elem = 0;
if (nElems != 0) elem = (ffi_type **)(result+1);
result->size = size;
result->alignment = align;
result->type = type;
result->elements = elem;
if (elem != 0)
{
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*elem++ = *(ffi_type**)(e.AsAddress());
}
*elem = 0;
}
return toSysWord(taskData, result);
}
case 55: // Create a CIF. This contains all the types and some extra information.
// The result is in allocated memory followed immediately by the argument type vector.
{
ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0));
ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress();
unsigned nArgs = 0;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nArgs++;
// Allocate space for the cif followed by the argument type vector
size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*);
ffi_cif *cif = (ffi_cif *)malloc(space);
if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **atypes = (ffi_type **)(cif+1);
// Copy the arguments types.
ffi_type **at = atypes;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*at++ = *(ffi_type**)(e.AsAddress());
}
ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes);
if (status == FFI_BAD_TYPEDEF)
raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif");
else if (status == FFI_BAD_ABI)
raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif");
else if (status != FFI_OK)
raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif");
return toSysWord(taskData, cif);
}
case 56: // Call a function.
{
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress();
void *f = *(void**)args->WordP()->Get(1).AsAddress();
void *res = *(void**)args->WordP()->Get(2).AsAddress();
void **arg = *(void***)args->WordP()->Get(3).AsAddress();
// We release the ML memory across the call so a GC can occur
// even if this thread is blocked in the C code.
processes->ThreadReleaseMLMemory(taskData);
ffi_call(cif, FFI_FN(f), res, arg);
// Do we need to save the value of errno/GetLastError here?
processes->ThreadUseMLMemory(taskData);
return taskData->saveVec.push(TAGGED(0));
}
case 57: // Create a callback.
{
#ifdef INTERPRETED
raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter");
#endif
Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0));
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress();
void *resultFunction;
// Allocate the memory. resultFunction is set to the executable address in or related to
// the memory.
ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction);
if (closure == 0)
raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory");
PLocker pLocker(&callbackTableLock);
// Find a free entry in the table if there is one.
unsigned entryNo = 0;
while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++;
if (entryNo == callBackEntries)
{
// Need to grow the table.
struct _cbStructEntry *newTable =
(struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry));
if (newTable == 0)
raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table");
callbackTable = newTable;
callBackEntries++;
}
callbackTable[entryNo].mlFunction = mlFunction->Word();
callbackTable[entryNo].closureSpace = closure;
callbackTable[entryNo].resultFunction = resultFunction;
if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK)
raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed");
return toSysWord(taskData, resultFunction);
}
case 58: // Free an existing callback.
{
// The address returned from call 57 above is the executable address that can
// be passed as a callback function. The writable memory address returned
// as the result of ffi_closure_alloc may or may not be the same. To be safe
// we need to search the table.
void *resFun = *(void**)args->Word().AsAddress();
PLocker pLocker(&callbackTableLock);
for (unsigned i = 0; i < callBackEntries; i++)
{
if (callbackTable[i].resultFunction == resFun)
{
ffi_closure_free(callbackTable[i].closureSpace);
callbackTable[i].closureSpace = 0;
callbackTable[i].resultFunction = 0;
callbackTable[i].mlFunction = TAGGED(0); // Release the ML function
return taskData->saveVec.push(TAGGED(0));
}
}
raise_exception_string(taskData, EXC_foreign, "Invalid callback entry");
}
default:
{
char msg[100];
sprintf(msg, "Unknown ffi function: %d", c);
raise_exception_string(taskData, EXC_foreign, msg);
return 0;
}
}
}
// Construct an entry in the ABI table.
static Handle mkAbitab(TaskData *taskData, void *arg, char *p)
{
struct _abiTable *ab = (struct _abiTable *)p;
// Construct a pair of the string and the code
Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName));
Handle code = Make_arbitrary_precision(taskData, ab->abiCode);
Handle result = alloc_and_save(taskData, 2);
result->WordP()->Set(0, name->Word());
result->WordP()->Set(1, code->Word());
return result;
}
// This is the C function that will get control when any callback is made. The "data"
// argument is the index of the entry in the callback table..
static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data)
{
uintptr_t cbIndex = (uintptr_t)data;
ASSERT(cbIndex < callBackEntries);
// We should get the task data for the thread that is running this code.
// If this thread has been created by the foreign code we will have to
// create a new one here.
TaskData *taskData = processes->GetTaskDataForThread();
if (taskData == 0)
{
try {
taskData = processes->CreateNewTaskData(0, 0, 0, TAGGED(0));
}
catch (std::bad_alloc &) {
::Exit("Unable to create thread data - insufficient memory");
}
catch (MemoryException &) {
::Exit("Unable to create thread data - insufficient memory");
}
}
else processes->ThreadUseMLMemory(taskData);
// We may get multiple calls to call-backs and we mustn't risk
// overflowing the save-vec.
Handle mark = taskData->saveVec.mark();
// In the future we might want to call C functions without some of the
// overhead that comes with an RTS call which may allocate in ML
// memory. If we do that we also have to ensure that callbacks
// don't allocate, so this code would have to change.
Handle mlEntryHandle;
{
// Get the ML function. Lock to avoid another thread moving
// callbackTable under our feet.
PLocker pLocker(&callbackTableLock);
struct _cbStructEntry *cbEntry = &callbackTable[cbIndex];
mlEntryHandle = taskData->saveVec.push(cbEntry->mlFunction);
}
// Create a pair of the arg vector and the result pointer.
Handle argHandle = toSysWord(taskData, args);
Handle resHandle = toSysWord(taskData, ret); // Result must go in here.
Handle pairHandle = alloc_and_save(taskData, 2);
pairHandle->WordP()->Set(0, argHandle->Word());
pairHandle->WordP()->Set(1, resHandle->Word());
taskData->EnterCallbackFunction(mlEntryHandle, pairHandle);
taskData->saveVec.reset(mark);
// Release ML memory now we're going back to C.
processes->ThreadReleaseMLMemory(taskData);
}
class PolyFFI: public RtsModule
{
public:
virtual void GarbageCollect(ScanAddress *process);
};
// Declare this. It will be automatically added to the table.
static PolyFFI polyFFIModule;
// We need to scan the callback table.
void PolyFFI::GarbageCollect(ScanAddress *process)
{
for (unsigned i = 0; i < callBackEntries; i++)
process->ScanRuntimeWord(&callbackTable[i].mlFunction);
}
#else
// The foreign function interface isn't available.
#include "polyffi.h"
#include "run_time.h"
#include "sys.h"
Handle poly_ffi(TaskData *taskData, Handle args, Handle code)
{
raise_exception_string(taskData, EXC_foreign, "The foreign function interface is not available on this platform");
}
#endif
// General interface to IO. Ideally the various cases will be made into
// separate functions.
POLYUNSIGNED PolyFFIGeneral(FirstArgument threadId, PolyWord code, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedCode = taskData->saveVec.push(code);
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = poly_ffi(taskData, pushedArg, pushedCode);
} catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// These functions are needed in the compiler
POLYUNSIGNED PolySizeFloat()
{
return TAGGED((POLYSIGNED)ffi_type_float.size).AsUnsigned();
}
POLYUNSIGNED PolySizeDouble()
{
return TAGGED((POLYSIGNED)ffi_type_double.size).AsUnsigned();
}
// Get either errno or GetLastError
POLYUNSIGNED PolyFFIGetError(PolyWord addr)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned(GetLastError()));
#else
addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned((POLYUNSIGNED)errno));
#endif
return 0;
}
// The argument is a SysWord.word value i.e. the address of a byte cell.
POLYUNSIGNED PolyFFISetError(PolyWord err)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
SetLastError((DWORD)(err.AsObjPtr()->Get(0).AsUnsigned()));
#else
errno = err.AsObjPtr()->Get(0).AsSigned();
#endif
return 0;
}
// Create an external function reference. The value returned has space for
// an address followed by the name of the external symbol. Because the
// address comes at the beginning it can be used in the same way as the
// SysWord value returned by the get-symbol call from a library.
POLYUNSIGNED PolyFFICreateExtFn(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = creatEntryPointObject(taskData, pushedArg, true);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Create an external reference to data. On a small number of platforms
// different forms of relocation are needed for data and for functions.
POLYUNSIGNED PolyFFICreateExtData(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = creatEntryPointObject(taskData, pushedArg, false);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
struct _entrypts polyFFIEPT[] =
{
{ "PolyFFIGeneral", (polyRTSFunction)&PolyFFIGeneral},
{ "PolySizeFloat", (polyRTSFunction)&PolySizeFloat},
{ "PolySizeDouble", (polyRTSFunction)&PolySizeDouble},
{ "PolyFFIGetError", (polyRTSFunction)&PolyFFIGetError},
{ "PolyFFISetError", (polyRTSFunction)&PolyFFISetError},
{ "PolyFFICreateExtFn", (polyRTSFunction)&PolyFFICreateExtFn},
{ "PolyFFICreateExtData", (polyRTSFunction)&PolyFFICreateExtData },
{ NULL, NULL} // End of list.
};
diff --git a/libpolyml/process_env.cpp b/libpolyml/process_env.cpp
index 799a983c..5c309476 100644
--- a/libpolyml/process_env.cpp
+++ b/libpolyml/process_env.cpp
@@ -1,721 +1,721 @@
/*
Title: Process environment.
Copyright (c) 2000-8, 2016-17, 2019
David C. J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_SYS_PARAM_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_SYS_WAIT_H
#include
#endif
#if (defined(__CYGWIN__) || defined(_WIN32))
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
// Include this next before errors.h since in WinCE at least the winsock errors are defined there.
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#include
#define NOMEMORY ERROR_NOT_ENOUGH_MEMORY
#undef ENOMEM
#else
typedef char TCHAR;
#define _tgetenv getenv
#define NOMEMORY ENOMEM
#endif
#include "globals.h"
#include "sys.h"
#include "run_time.h"
#include "process_env.h"
#include "arb.h"
#include "mpoly.h"
#include "gc.h"
#include "scanaddrs.h"
#include "polystring.h"
#include "save_vec.h"
#include "process_env.h"
#include "rts_module.h"
#include "machine_dep.h"
#include "processes.h"
#include "locking.h"
#include "errors.h"
#include "rtsentry.h"
#include "version.h"
extern "C" {
POLYEXTERNALSYMBOL void PolyFinish(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL void PolyTerminate(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize();
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize();
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber();
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyCommandLineName(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyCommandLineArgs(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg);
}
#define SAVE(x) taskData->saveVec.push(x)
#define ALLOC(n) alloc_and_save(taskData, n)
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#define ISPATHSEPARATOR(c) ((c) == '\\' || (c) == '/')
#define DEFAULTSEPARATOR "\\"
#else
#define ISPATHSEPARATOR(c) ((c) == '/')
#define DEFAULTSEPARATOR "/"
#endif
#ifdef _MSC_VER
// Don't tell me about ISO C++ changes.
#pragma warning(disable:4996)
#endif
// "environ" is declared in the headers on some systems but not all.
// Oddly, declaring it within process_env_dispatch_c causes problems
// on mingw where "environ" is actually a function.
#if __APPLE__
// On Mac OS X there may be problems accessing environ directly.
#include
#define environ (*_NSGetEnviron())
#else
extern char **environ;
#endif
/* Functions registered with atExit are added to this list. */
static PolyWord at_exit_list = TAGGED(0);
/* Once "exit" is called this flag is set and no further
calls to atExit are allowed. */
static bool exiting = false;
static PLock atExitLock; // Thread lock for above.
#ifdef __CYGWIN__
// Cygwin requires spawnvp to avoid the significant overhead of vfork
// but it doesn't seem to be thread-safe. Run it on the main thread
// to be sure.
class CygwinSpawnRequest: public MainThreadRequest
{
public:
CygwinSpawnRequest(char **argv): MainThreadRequest(MTP_CYGWINSPAWN), spawnArgv(argv) {}
virtual void Perform();
char **spawnArgv;
int pid;
};
void CygwinSpawnRequest::Perform()
{
pid = spawnvp(_P_NOWAIT, "/bin/sh", spawnArgv);
}
#endif
// These are now just legacy calls.
static Handle process_env_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORD(code));
switch (c)
{
case 1: /* Return the argument list. */
return convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings);
case 18: /* Register function to run at exit. */
{
PLocker locker(&atExitLock);
if (! exiting)
{
PolyObject *cell = alloc(taskData, 2);
cell->Set(0, at_exit_list);
cell->Set(1, args->Word());
at_exit_list = cell;
}
return Make_fixed_precision(taskData, 0);
}
case 19: /* Return the next function in the atExit list and set the
"exiting" flag to true. */
{
PLocker locker(&atExitLock);
Handle res;
exiting = true; /* Ignore further calls to atExit. */
if (at_exit_list == TAGGED(0))
raise_syscall(taskData, "List is empty", 0);
PolyObject *cell = at_exit_list.AsObjPtr();
res = SAVE(cell->Get(1));
at_exit_list = cell->Get(0);
return res;
}
default:
{
char msg[100];
sprintf(msg, "Unknown environment function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
// General interface to process-env. Ideally the various cases will be made into
// separate functions.
POLYUNSIGNED PolyProcessEnvGeneral(FirstArgument threadId, PolyWord code, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedCode = taskData->saveVec.push(code);
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = process_env_dispatch_c(taskData, pushedArg, pushedCode);
}
catch (KillException &) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Terminate normally with a result code.
void PolyFinish(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
int i = get_C_int(taskData, arg);
// Cause the other threads to exit and set the result code.
processes->RequestProcessExit(i);
// Exit this thread
processes->ThreadExit(taskData); // Doesn't return.
}
// Terminate without running the atExit list or flushing buffers
void PolyTerminate(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
int i = get_C_int(taskData, arg);
_exit(i); // Doesn't return.
}
// Get the name of a numeric error message.
POLYUNSIGNED PolyProcessEnvErrorName(FirstArgument threadId, PolyWord syserr)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
int e = (int)syserr.AsObjPtr()->Get(0).AsSigned();
// First look to see if we have the name in the error table. They should generally all be there.
const char *errorMsg = stringFromErrorCode(e);
if (errorMsg != NULL)
result = taskData->saveVec.push(C_string_to_Poly(taskData, errorMsg));
else
{ // If it isn't in the table.
char buff[40];
sprintf(buff, "ERROR%0d", e);
result = taskData->saveVec.push(C_string_to_Poly(taskData, buff));
}
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Get the explanatory message for an error. */
POLYUNSIGNED PolyProcessEnvErrorMessage(FirstArgument threadId, PolyWord syserr)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = errorMsg(taskData, (int)syserr.AsObjPtr()->Get(0).AsSigned());
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Try to convert an error string to an error number.
POLYUNSIGNED PolyProcessEnvErrorFromString(FirstArgument threadId, PolyWord string)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
char buff[40];
// Get the string.
Poly_string_to_C(string, buff, sizeof(buff));
// Look the string up in the table.
int err = 0;
if (errorCodeFromString(buff, &err))
result = Make_sysword(taskData, err);
else if (strncmp(buff, "ERROR", 5) == 0)
// If we don't find it then it may have been a constructed error name.
result = Make_sysword(taskData, atoi(buff+5));
else result = Make_sysword(taskData, 0); // Return 0w0 if it isn't there.
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Return the maximum size of a cell that can be allocated on the heap.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxAllocationSize()
{
return TAGGED(MAX_OBJECT_SIZE).AsUnsigned();
}
// Return the maximum string size (in bytes).
// It is the maximum number of bytes in a segment less one word for the length field.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetMaxStringSize()
{
return TAGGED((MAX_OBJECT_SIZE) * sizeof(PolyWord) - sizeof(PolyWord)).AsUnsigned();
}
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetPolyVersionNumber()
{
return TAGGED(POLY_version_number).AsUnsigned();
}
// Return the function name associated with a piece of compiled code.
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetFunctionName(FirstArgument threadId, PolyWord fnAddr)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
if (fnAddr.IsTagged()) raise_fail(taskData, "Not a code pointer");
PolyObject *pt = fnAddr.AsObjPtr();
// In 32-in-64 this may be a closure and the first word is the absolute address of the code.
if (pt->IsClosureObject())
{
// It may not be set yet.
pt = *(PolyObject**)pt;
if (((uintptr_t)pt & 1) == 1) raise_fail(taskData, "Not a code pointer");
}
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))
result = taskData->saveVec.push(C_string_to_Poly(taskData, ""));
else result = taskData->saveVec.push(name);
}
else raise_fail(taskData, "Not a code pointer");
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Return the program name. */
POLYUNSIGNED PolyCommandLineName(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = taskData->saveVec.push(C_string_to_Poly(taskData, userOptions.programName));
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Return the argument list. */
POLYUNSIGNED PolyCommandLineArgs(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = convert_string_list(taskData, userOptions.user_arg_count, userOptions.user_arg_strings);
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Return a string from the environment. */
POLYUNSIGNED PolyGetEnv(FirstArgument threadId, PolyWord arg)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
TempString buff(pushedArg->Word());
if (buff == 0)
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
TCHAR * res = _tgetenv(buff);
if (res == NULL)
raise_syscall(taskData, "Not Found", 0);
result = taskData->saveVec.push(C_string_to_Poly(taskData, res));
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Return the whole environment. Only available in Posix.ProcEnv.
POLYUNSIGNED PolyGetEnvironment(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
/* Count the environment strings */
int env_count = 0;
while (environ[env_count] != NULL) env_count++;
result = convert_string_list(taskData, env_count, environ);
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Return the success value. */
POLYUNSIGNED PolyProcessEnvSuccessValue(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = Make_fixed_precision(taskData, EXIT_SUCCESS);
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Return a failure value. */
POLYUNSIGNED PolyProcessEnvFailureValue(FirstArgument threadId)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = Make_fixed_precision(taskData, EXIT_FAILURE);
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
/* Run command. */
POLYUNSIGNED PolyProcessEnvSystem(FirstArgument threadId, PolyWord arg)
{
TaskData* taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
TempString buff(pushedArg->Word());
if (buff == 0) raise_syscall(taskData, "Insufficient memory", NOMEMORY);
int res = -1;
#if (defined(_WIN32) && ! defined(__CYGWIN__))
// Windows.
TCHAR * argv[4];
argv[0] = _tgetenv(_T("COMSPEC")); // Default CLI.
if (argv[0] == 0) argv[0] = (TCHAR*)_T("cmd.exe"); // Win NT etc.
argv[1] = (TCHAR*)_T("/c");
argv[2] = buff;
argv[3] = NULL;
// If _P_NOWAIT is given the result is the process handle.
// spawnvp does any necessary path searching if argv[0]
// does not contain a full path.
intptr_t pid = _tspawnvp(_P_NOWAIT, argv[0], argv);
if (pid == -1)
raise_syscall(taskData, "Function system failed", errno);
#else
// Cygwin and Unix
char* argv[4];
argv[0] = (char*)"sh";
argv[1] = (char*)"-c";
argv[2] = buff;
argv[3] = NULL;
#if (defined(__CYGWIN__))
CygwinSpawnRequest request(argv);
processes->MakeRootRequest(taskData, &request);
int pid = request.pid;
if (pid < 0)
raise_syscall(taskData, "Function system failed", errno);
#else
// We need to break this down so that we can unblock signals in the
// child process.
// The Unix "system" function seems to set SIGINT and SIGQUIT to
// SIG_IGN in the parent so that the wait will not be interrupted.
// That may make sense in a single-threaded application but is
// that right here?
int pid = vfork();
if (pid == -1)
raise_syscall(taskData, "Function system failed", errno);
else if (pid == 0)
{ // In child
sigset_t sigset;
sigemptyset(&sigset);
sigprocmask(SIG_SETMASK, &sigset, 0);
// Reset other signals?
execv("/bin/sh", argv);
_exit(1);
}
#endif
#endif
while (true)
{
try
{
// Test to see if the child has returned.
#if (defined(_WIN32) && ! defined(__CYGWIN__))
DWORD dwWait = WaitForSingleObject((HANDLE)pid, 0);
if (dwWait == WAIT_OBJECT_0)
{
DWORD dwResult;
BOOL fResult = GetExitCodeProcess((HANDLE)pid, &dwResult);
if (!fResult)
raise_syscall(taskData, "Function system failed", GetLastError());
CloseHandle((HANDLE)pid);
result = Make_fixed_precision(taskData, dwResult);
break;
}
else if (dwWait == WAIT_FAILED)
raise_syscall(taskData, "Function system failed", GetLastError());
else
{
// Wait for the process to exit or for the timeout
WaitHandle waiter((HANDLE)pid, 1000);
processes->ThreadPauseForIO(taskData, &waiter);
}
#else
int wRes = waitpid(pid, &res, WNOHANG);
if (wRes > 0)
break;
else if (wRes < 0)
{
raise_syscall(taskData, "Function system failed", errno);
}
// In Unix the best we can do is wait. This may be interrupted
// by SIGCHLD depending on where signals are processed.
// One possibility is for the main thread to somehow wake-up
// the thread when it processes a SIGCHLD.
else processes->ThreadPause(taskData);
#endif
}
catch (...)
{
// Either IOException or KillException.
// We're abandoning the wait. This will leave
// a zombie in Unix.
#if (defined(_WIN32) && ! defined(__CYGWIN__))
CloseHandle((HANDLE)pid);
#endif
throw;
}
}
result = Make_fixed_precision(taskData, res);
}
catch (KillException&) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset); // Ensure the save vec is reset
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
struct _entrypts processEnvEPT[] =
{
{ "PolyFinish", (polyRTSFunction)&PolyFinish},
{ "PolyTerminate", (polyRTSFunction)&PolyTerminate},
{ "PolyProcessEnvGeneral", (polyRTSFunction)&PolyProcessEnvGeneral},
{ "PolyProcessEnvErrorName", (polyRTSFunction)&PolyProcessEnvErrorName},
{ "PolyProcessEnvErrorMessage", (polyRTSFunction)&PolyProcessEnvErrorMessage},
{ "PolyProcessEnvErrorFromString", (polyRTSFunction)&PolyProcessEnvErrorFromString},
{ "PolyGetMaxAllocationSize", (polyRTSFunction)&PolyGetMaxAllocationSize },
{ "PolyGetMaxStringSize", (polyRTSFunction)&PolyGetMaxStringSize },
{ "PolyGetPolyVersionNumber", (polyRTSFunction)&PolyGetPolyVersionNumber },
{ "PolyGetFunctionName", (polyRTSFunction)&PolyGetFunctionName },
{ "PolyCommandLineName", (polyRTSFunction)& PolyCommandLineName },
{ "PolyCommandLineArgs", (polyRTSFunction)& PolyCommandLineArgs },
{ "PolyGetEnv", (polyRTSFunction)& PolyGetEnv },
{ "PolyGetEnvironment", (polyRTSFunction)& PolyGetEnvironment },
{ "PolyProcessEnvSuccessValue", (polyRTSFunction)& PolyProcessEnvSuccessValue },
{ "PolyProcessEnvFailureValue", (polyRTSFunction)& PolyProcessEnvFailureValue },
{ "PolyProcessEnvSystem", (polyRTSFunction)& PolyProcessEnvSystem },
{ NULL, NULL} // End of list.
};
class ProcessEnvModule: public RtsModule
{
public:
void GarbageCollect(ScanAddress *process);
};
// Declare this. It will be automatically added to the table.
static ProcessEnvModule processModule;
void ProcessEnvModule::GarbageCollect(ScanAddress *process)
/* Ensures that all the objects are retained and their addresses updated. */
{
if (at_exit_list.IsDataPtr())
{
PolyObject *obj = at_exit_list.AsObjPtr();
process->ScanRuntimeAddress(&obj, ScanAddress::STRENGTH_STRONG);
at_exit_list = obj;
}
}
diff --git a/libpolyml/processes.cpp b/libpolyml/processes.cpp
index 3afbb465..10752ebd 100644
--- a/libpolyml/processes.cpp
+++ b/libpolyml/processes.cpp
@@ -1,2224 +1,2208 @@
/*
Title: Thread functions
Author: David C.J. Matthews
Copyright (c) 2007,2008,2013-15, 2017, 2019 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_LIMITS_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
#ifdef HAVE_PROCESS_H
#include
#endif
#ifdef HAVE_SYS_TYPES_H
#include
#endif
#ifdef HAVE_SYS_STAT_H
#include
#endif
#ifdef HAVE_SYS_TIME_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include // Want unistd for _SC_NPROCESSORS_ONLN at least
#endif
#ifdef HAVE_SYS_SELECT_H
#include
#endif
#ifdef HAVE_WINDOWS_H
#include
#endif
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H))
-#define HAVE_PTHREAD 1
+#if (!defined(_WIN32))
#include
#endif
#ifdef HAVE_SYS_SYSCTL_H
// Used determine number of processors in Mac OS X.
#include
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#endif
#include
#include
/************************************************************************
*
* Include runtime headers
*
************************************************************************/
#include "globals.h"
#include "gc.h"
#include "mpoly.h"
#include "arb.h"
#include "machine_dep.h"
#include "diagnostics.h"
#include "processes.h"
#include "run_time.h"
#include "sys.h"
#include "sighandler.h"
#include "scanaddrs.h"
#include "save_vec.h"
#include "rts_module.h"
#include "noreturn.h"
#include "memmgr.h"
#include "locking.h"
#include "profiling.h"
#include "sharedata.h"
#include "exporter.h"
#include "statistics.h"
#include "rtsentry.h"
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillSelf(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexBlock(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMutexUnlock(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWait(FirstArgument threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWaitUntil(FirstArgument threadId, PolyWord lockArg, PolyWord timeArg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadCondVarWake(PolyWord targetThread);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadForkThread(FirstArgument threadId, PolyWord function, PolyWord attrs, PolyWord stack);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadIsActive(PolyWord targetThread);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadInterruptThread(PolyWord targetThread);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadKillThread(PolyWord targetThread);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumProcessors();
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadNumPhysicalProcessors();
POLYEXTERNALSYMBOL POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord newSize);
}
#define SAVE(x) taskData->saveVec.push(x)
#define SIZEOF(x) (sizeof(x)/sizeof(PolyWord))
// These values are stored in the second word of thread id object as
// a tagged integer. They may be set and read by the thread in the ML
// code.
#define PFLAG_BROADCAST 1 // If set, accepts a broadcast
// How to handle interrrupts
#define PFLAG_IGNORE 0 // Ignore interrupts completely
#define PFLAG_SYNCH 2 // Handle synchronously
#define PFLAG_ASYNCH 4 // Handle asynchronously
#define PFLAG_ASYNCH_ONCE 6 // First handle asynchronously then switch to synch.
#define PFLAG_INTMASK 6 // Mask of the above bits
struct _entrypts processesEPT[] =
{
{ "PolyThreadKillSelf", (polyRTSFunction)&PolyThreadKillSelf},
{ "PolyThreadMutexBlock", (polyRTSFunction)&PolyThreadMutexBlock},
{ "PolyThreadMutexUnlock", (polyRTSFunction)&PolyThreadMutexUnlock},
{ "PolyThreadCondVarWait", (polyRTSFunction)&PolyThreadCondVarWait},
{ "PolyThreadCondVarWaitUntil", (polyRTSFunction)&PolyThreadCondVarWaitUntil},
{ "PolyThreadCondVarWake", (polyRTSFunction)&PolyThreadCondVarWake},
{ "PolyThreadForkThread", (polyRTSFunction)&PolyThreadForkThread},
{ "PolyThreadIsActive", (polyRTSFunction)&PolyThreadIsActive},
{ "PolyThreadInterruptThread", (polyRTSFunction)&PolyThreadInterruptThread},
{ "PolyThreadKillThread", (polyRTSFunction)&PolyThreadKillThread},
{ "PolyThreadBroadcastInterrupt", (polyRTSFunction)&PolyThreadBroadcastInterrupt},
{ "PolyThreadTestInterrupt", (polyRTSFunction)&PolyThreadTestInterrupt},
{ "PolyThreadNumProcessors", (polyRTSFunction)&PolyThreadNumProcessors},
{ "PolyThreadNumPhysicalProcessors",(polyRTSFunction)&PolyThreadNumPhysicalProcessors},
{ "PolyThreadMaxStackSize", (polyRTSFunction)&PolyThreadMaxStackSize},
{ NULL, NULL} // End of list.
};
class Processes: public ProcessExternal, public RtsModule
{
public:
Processes();
virtual void Init(void);
virtual void Stop(void);
void GarbageCollect(ScanAddress *process);
public:
void BroadcastInterrupt(void);
void BeginRootThread(PolyObject *rootFunction);
void RequestProcessExit(int n); // Request all ML threads to exit and set the process result code.
// Called when a thread has completed - doesn't return.
virtual NORETURNFN(void ThreadExit(TaskData *taskData));
// Called when a thread may block. Returns some time later when perhaps
// the input is available.
virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait);
// Return the task data for the current thread.
virtual TaskData *GetTaskDataForThread(void);
// Create a new task data object for the current thread.
virtual TaskData *CreateNewTaskData(Handle threadId, Handle threadFunction,
Handle args, PolyWord flags);
// ForkFromRTS. Creates a new thread from within the RTS.
virtual bool ForkFromRTS(TaskData *taskData, Handle proc, Handle arg);
// Create a new thread. The "args" argument is only used for threads
// created in the RTS by the signal handler.
Handle ForkThread(TaskData *taskData, Handle threadFunction,
Handle args, PolyWord flags, PolyWord stacksize);
// Process general RTS requests from ML.
Handle ThreadDispatch(TaskData *taskData, Handle args, Handle code);
virtual void ThreadUseMLMemory(TaskData *taskData);
virtual void ThreadReleaseMLMemory(TaskData *taskData);
virtual poly_exn* GetInterrupt(void) { return interrupt_exn; }
// If the schedule lock is already held we need to use these functions.
void ThreadUseMLMemoryWithSchedLock(TaskData *taskData);
void ThreadReleaseMLMemoryWithSchedLock(TaskData *taskData);
// Requests from the threads for actions that need to be performed by
// the root thread. Make the request and wait until it has completed.
virtual void MakeRootRequest(TaskData *taskData, MainThreadRequest *request);
// Deal with any interrupt or kill requests.
virtual bool ProcessAsynchRequests(TaskData *taskData);
// Process an interrupt request synchronously.
virtual void TestSynchronousRequests(TaskData *taskData);
// Process any events, synchronous or asynchronous.
virtual void TestAnyEvents(TaskData *taskData);
// Set a thread to be interrupted or killed. Wakes up the
// thread if necessary. MUST be called with schedLock held.
void MakeRequest(TaskData *p, ThreadRequests request);
// Profiling control.
virtual void StartProfiling(void);
virtual void StopProfiling(void);
#ifdef HAVE_WINDOWS_H
// Windows: Called every millisecond while profiling is on.
void ProfileInterrupt(void);
#else
// Unix: Start a profile timer for a thread.
void StartProfilingTimer(void);
#endif
// Memory allocation. Tries to allocate space. If the allocation succeeds it
// may update the allocation values in the taskData object. If the heap is exhausted
// it may set this thread (or other threads) to raise an exception.
PolyWord *FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg);
// Get the task data value from the task reference.
// The task data reference is a volatile ref containing the
// address of the C++ task data.
// N.B. This is updated when the thread exits and the TaskData object
// is deleted.
TaskData *TaskForIdentifier(PolyObject *taskId) {
return *(TaskData**)(((ThreadObject*)taskId)->threadRef.AsObjPtr());
}
// Signal handling support. The ML signal handler thread blocks until it is
// woken up by the signal detection thread.
virtual bool WaitForSignal(TaskData *taskData, PLock *sigLock);
virtual void SignalArrived(void);
virtual void SetSingleThreaded(void) { singleThreaded = true; }
// Operations on mutexes
void MutexBlock(TaskData *taskData, Handle hMutex);
void MutexUnlock(TaskData *taskData, Handle hMutex);
// Operations on condition variables.
void WaitInfinite(TaskData *taskData, Handle hMutex);
void WaitUntilTime(TaskData *taskData, Handle hMutex, Handle hTime);
bool WakeThread(PolyObject *targetThread);
// Generally, the system runs with multiple threads. After a
// fork, though, there is only one thread.
bool singleThreaded;
// Each thread has an entry in this vector.
std::vector taskArray;
/* schedLock: This lock must be held when making scheduling decisions.
It must also be held before adding items to taskArray, removing
them or scanning the vector.
It must also be held before deleting a TaskData object
or using it in a thread other than the "owner" */
PLock schedLock;
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_key_t tlsId;
-#elif defined(HAVE_WINDOWS_H)
+#else
DWORD tlsId;
#endif
// We make an exception packet for Interrupt and store it here.
// This exception can be raised if we run out of store so we need to
// make sure we have the packet before we do.
poly_exn *interrupt_exn;
/* initialThreadWait: The initial thread waits on this for
wake-ups from the ML threads requesting actions such as GC or
close-down. */
PCondVar initialThreadWait;
// A requesting thread sets this to indicate the request. This value
// is only reset once the request has been satisfied.
MainThreadRequest *threadRequest;
PCondVar mlThreadWait; // All the threads block on here until the request has completed.
int exitResult;
bool exitRequest;
-#ifdef HAVE_WINDOWS_H
+#ifdef HAVE_WINDOWS_H /* Windows including Cygwin */
// Used in profiling
HANDLE hStopEvent; /* Signalled to stop all threads. */
HANDLE profilingHd;
HANDLE mainThreadHandle; // Handle for main thread
LONGLONG lastCPUTime; // CPU used by main thread.
#endif
TaskData *sigTask; // Pointer to current signal task.
};
// Global process data.
static Processes processesModule;
ProcessExternal *processes = &processesModule;
Processes::Processes(): singleThreaded(false),
schedLock("Scheduler"), interrupt_exn(0),
threadRequest(0), exitResult(0), exitRequest(false), sigTask(0)
{
#ifdef HAVE_WINDOWS_H
hStopEvent = NULL;
profilingHd = NULL;
lastCPUTime = 0;
mainThreadHandle = NULL;
#endif
}
enum _mainThreadPhase mainThreadPhase = MTP_USER_CODE;
// Get the attribute flags.
static POLYUNSIGNED ThreadAttrs(TaskData *taskData)
{
return UNTAGGED_UNSIGNED(taskData->threadObject->flags);
}
POLYUNSIGNED PolyThreadMutexBlock(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
if (profileMode == kProfileMutexContention)
taskData->addProfileCount(1);
try {
processesModule.MutexBlock(taskData, pushedArg);
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
POLYUNSIGNED PolyThreadMutexUnlock(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
try {
processesModule.MutexUnlock(taskData, pushedArg);
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
/* A mutex was locked i.e. the count was ~1 or less. We will have set it to
~1. This code blocks if the count is still ~1. It does actually return
if another thread tries to lock the mutex and hasn't yet set the value
to ~1 but that doesn't matter since whenever we return we simply try to
get the lock again. */
void Processes::MutexBlock(TaskData *taskData, Handle hMutex)
{
schedLock.Lock();
// We have to check the value again with schedLock held rather than
// simply waiting because otherwise the unlocking thread could have
// set the variable back to 1 (unlocked) and signalled any waiters
// before we actually got to wait.
if (UNTAGGED(DEREFHANDLE(hMutex)->Get(0)) < 0)
{
// Set this so we can see what we're blocked on.
taskData->blockMutex = DEREFHANDLE(hMutex);
// Now release the ML memory. A GC can start.
ThreadReleaseMLMemoryWithSchedLock(taskData);
// Wait until we're woken up. We mustn't block if we have been
// interrupted, and are processing interrupts asynchronously, or
// we've been killed.
switch (taskData->requests)
{
case kRequestKill:
// We've been killed. Handle this later.
break;
case kRequestInterrupt:
{
// We've been interrupted.
POLYUNSIGNED attrs = ThreadAttrs(taskData) & PFLAG_INTMASK;
if (attrs == PFLAG_ASYNCH || attrs == PFLAG_ASYNCH_ONCE)
break;
// If we're ignoring interrupts or handling them synchronously
// we don't do anything here.
}
case kRequestNone:
globalStats.incCount(PSC_THREADS_WAIT_MUTEX);
taskData->threadLock.Wait(&schedLock);
globalStats.decCount(PSC_THREADS_WAIT_MUTEX);
}
taskData->blockMutex = 0; // No longer blocked.
ThreadUseMLMemoryWithSchedLock(taskData);
}
// Return and try and get the lock again.
schedLock.Unlock();
// Test to see if we have been interrupted and if this thread
// processes interrupts asynchronously we should raise an exception
// immediately. Perhaps we do that whenever we exit from the RTS.
}
/* Unlock a mutex. Called after incrementing the count and discovering
that at least one other thread has tried to lock it. We may need
to wake up threads that are blocked. */
void Processes::MutexUnlock(TaskData *taskData, Handle hMutex)
{
// The caller has already set the variable to 1 (unlocked).
// We need to acquire schedLock so that we can
// be sure that any thread that is trying to lock sees either
// the updated value (and so doesn't wait) or has successfully
// waited on its threadLock (and so will be woken up).
schedLock.Lock();
// Unlock any waiters.
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *p = *i;
// If the thread is blocked on this mutex we can signal the thread.
if (p && p->blockMutex == DEREFHANDLE(hMutex))
p->threadLock.Signal();
}
schedLock.Unlock();
}
POLYUNSIGNED PolyThreadCondVarWait(FirstArgument threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
try {
processesModule.WaitInfinite(taskData, pushedArg);
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
POLYUNSIGNED PolyThreadCondVarWaitUntil(FirstArgument threadId, PolyWord lockArg, PolyWord timeArg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedLockArg = taskData->saveVec.push(lockArg);
Handle pushedTimeArg = taskData->saveVec.push(timeArg);
try {
processesModule.WaitUntilTime(taskData, pushedLockArg, pushedTimeArg);
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
// Atomically drop a mutex and wait for a wake up.
// It WILL NOT RAISE AN EXCEPTION unless it is set to handle exceptions
// asynchronously (which it shouldn't do if the ML caller code is correct).
// It may return as a result of any of the following:
// an explicit wake up.
// an interrupt, either direct or broadcast
// a trap i.e. a request to handle an asynchronous event.
void Processes::WaitInfinite(TaskData *taskData, Handle hMutex)
{
schedLock.Lock();
// Atomically release the mutex. This is atomic because we hold schedLock
// so no other thread can call signal or broadcast.
Handle decrResult = taskData->AtomicIncrement(hMutex);
if (UNTAGGED(decrResult->Word()) != 1)
{
taskData->AtomicReset(hMutex);
// The mutex was locked so we have to release any waiters.
// Unlock any waiters.
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *p = *i;
// If the thread is blocked on this mutex we can signal the thread.
if (p && p->blockMutex == DEREFHANDLE(hMutex))
p->threadLock.Signal();
}
}
// Wait until we're woken up. Don't block if we have been interrupted
// or killed.
if (taskData->requests == kRequestNone)
{
// Now release the ML memory. A GC can start.
ThreadReleaseMLMemoryWithSchedLock(taskData);
globalStats.incCount(PSC_THREADS_WAIT_CONDVAR);
taskData->threadLock.Wait(&schedLock);
globalStats.decCount(PSC_THREADS_WAIT_CONDVAR);
// We want to use the memory again.
ThreadUseMLMemoryWithSchedLock(taskData);
}
schedLock.Unlock();
}
// Atomically drop a mutex and wait for a wake up or a time to wake up
void Processes::WaitUntilTime(TaskData *taskData, Handle hMutex, Handle hWakeTime)
{
// Convert the time into the correct format for WaitUntil before acquiring
// schedLock. div_longc could do a GC which requires schedLock.
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
// On Windows it is the number of 100ns units since the epoch
FILETIME tWake;
getFileTimeFromArb(taskData, hWakeTime, &tWake);
#else
// Unix style times.
struct timespec tWake;
// On Unix we represent times as a number of microseconds.
Handle hMillion = Make_arbitrary_precision(taskData, 1000000);
tWake.tv_sec =
get_C_ulong(taskData, DEREFWORD(div_longc(taskData, hMillion, hWakeTime)));
tWake.tv_nsec =
1000*get_C_ulong(taskData, DEREFWORD(rem_longc(taskData, hMillion, hWakeTime)));
#endif
schedLock.Lock();
// Atomically release the mutex. This is atomic because we hold schedLock
// so no other thread can call signal or broadcast.
Handle decrResult = taskData->AtomicIncrement(hMutex);
if (UNTAGGED(decrResult->Word()) != 1)
{
taskData->AtomicReset(hMutex);
// The mutex was locked so we have to release any waiters.
// Unlock any waiters.
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *p = *i;
// If the thread is blocked on this mutex we can signal the thread.
if (p && p->blockMutex == DEREFHANDLE(hMutex))
p->threadLock.Signal();
}
}
// Wait until we're woken up. Don't block if we have been interrupted
// or killed.
if (taskData->requests == kRequestNone)
{
// Now release the ML memory. A GC can start.
ThreadReleaseMLMemoryWithSchedLock(taskData);
globalStats.incCount(PSC_THREADS_WAIT_CONDVAR);
(void)taskData->threadLock.WaitUntil(&schedLock, &tWake);
globalStats.decCount(PSC_THREADS_WAIT_CONDVAR);
// We want to use the memory again.
ThreadUseMLMemoryWithSchedLock(taskData);
}
schedLock.Unlock();
}
bool Processes::WakeThread(PolyObject *targetThread)
{
bool result = false; // Default to failed.
// Acquire the schedLock first. This ensures that this is
// atomic with respect to waiting.
schedLock.Lock();
TaskData *p = TaskForIdentifier(targetThread);
if (p && p->threadObject == targetThread)
{
POLYUNSIGNED attrs = ThreadAttrs(p) & PFLAG_INTMASK;
if (p->requests == kRequestNone ||
(p->requests == kRequestInterrupt && attrs == PFLAG_IGNORE))
{
p->threadLock.Signal();
result = true;
}
}
schedLock.Unlock();
return result;
}
POLYUNSIGNED PolyThreadCondVarWake(PolyWord targetThread)
{
if (processesModule.WakeThread(targetThread.AsObjPtr()))
return TAGGED(1).AsUnsigned();
else return TAGGED(0).AsUnsigned();
}
// Test if a thread is active.
POLYUNSIGNED PolyThreadIsActive(PolyWord targetThread)
{
// There's a race here: the thread may be exiting but since we're not doing
// anything with the TaskData object we don't need a lock.
TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr());
if (p != 0) return TAGGED(1).AsUnsigned();
else return TAGGED(0).AsUnsigned();
}
// Send an interrupt to a specific thread
POLYUNSIGNED PolyThreadInterruptThread(PolyWord targetThread)
{
// Must lock here because the thread may be exiting.
processesModule.schedLock.Lock();
TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr());
if (p) processesModule.MakeRequest(p, kRequestInterrupt);
processesModule.schedLock.Unlock();
// If the thread cannot be identified return false.
// The caller can then raise an exception
if (p == 0) return TAGGED(0).AsUnsigned();
else return TAGGED(1).AsUnsigned();
}
// Kill a specific thread
POLYUNSIGNED PolyThreadKillThread(PolyWord targetThread)
{
processesModule.schedLock.Lock();
TaskData *p = processesModule.TaskForIdentifier(targetThread.AsObjPtr());
if (p) processesModule.MakeRequest(p, kRequestKill);
processesModule.schedLock.Unlock();
// If the thread cannot be identified return false.
// The caller can then raise an exception
if (p == 0) return TAGGED(0).AsUnsigned();
else return TAGGED(1).AsUnsigned();
}
POLYUNSIGNED PolyThreadBroadcastInterrupt(FirstArgument /*threadId*/)
{
processesModule.BroadcastInterrupt();
return TAGGED(0).AsUnsigned();
}
POLYUNSIGNED PolyThreadTestInterrupt(FirstArgument threadId)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
processesModule.TestSynchronousRequests(taskData);
// Also process any asynchronous requests that may be pending.
// These will be handled "soon" but if we have just switched from deferring
// interrupts this guarantees that any deferred interrupts will be handled now.
if (processesModule.ProcessAsynchRequests(taskData))
throw IOException();
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
// Return the number of processors.
// Returns 1 if there is any problem.
POLYUNSIGNED PolyThreadNumProcessors(void)
{
return TAGGED(NumberOfProcessors()).AsUnsigned();
}
// Return the number of physical processors.
// Returns 0 if there is any problem.
POLYUNSIGNED PolyThreadNumPhysicalProcessors(void)
{
return TAGGED(NumberOfPhysicalProcessors()).AsUnsigned();
}
// Set the maximum stack size.
POLYUNSIGNED PolyThreadMaxStackSize(FirstArgument threadId, PolyWord newSize)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
taskData->threadObject->mlStackSize = newSize;
if (newSize != TAGGED(0))
{
uintptr_t current = taskData->currentStackSpace(); // Current size in words
uintptr_t newWords = getPolyUnsigned(taskData, newSize);
if (current > newWords)
raise_exception0(taskData, EXC_interrupt);
}
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
// Old dispatch function. This is only required because the pre-built compiler
// may use some of these e.g. fork.
Handle Processes::ThreadDispatch(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, code->Word());
TaskData *ptaskData = taskData;
switch (c)
{
case 1:
MutexBlock(taskData, args);
return SAVE(TAGGED(0));
case 2:
MutexUnlock(taskData, args);
return SAVE(TAGGED(0));
case 7: // Fork a new thread. The arguments are the function to run and the attributes.
return ForkThread(ptaskData, SAVE(args->WordP()->Get(0)),
(Handle)0, args->WordP()->Get(1),
// For backwards compatibility we check the length here
args->WordP()->Length() <= 2 ? TAGGED(0) : args->WordP()->Get(2));
case 10: // Broadcast an interrupt to all threads that are interested.
BroadcastInterrupt();
return SAVE(TAGGED(0));
default:
{
char msg[100];
sprintf(msg, "Unknown thread function: %u", c);
raise_fail(taskData, msg);
return 0;
}
}
}
// Fill unused allocation space with a dummy object to preserve the invariant
// that memory is always valid.
void TaskData::FillUnusedSpace(void)
{
if (allocPointer > allocLimit)
gMem.FillUnusedSpace(allocLimit, allocPointer-allocLimit);
}
TaskData::TaskData(): allocPointer(0), allocLimit(0), allocSize(MIN_HEAP_SIZE), allocCount(0),
- stack(0), threadObject(0), signalStack(0), foreignStack(TAGGED(0)),
+ stack(0), threadObject(0), signalStack(0),
inML(false), requests(kRequestNone), blockMutex(0), inMLHeap(false),
runningProfileTimer(false)
{
#ifdef HAVE_WINDOWS_H
lastCPUTime = 0;
#endif
#ifdef HAVE_WINDOWS_H
threadHandle = 0;
#endif
threadExited = false;
}
TaskData::~TaskData()
{
if (signalStack) free(signalStack);
if (stack) gMem.DeleteStackSpace(stack);
#ifdef HAVE_WINDOWS_H
if (threadHandle) CloseHandle(threadHandle);
#endif
}
// Broadcast an interrupt to all relevant threads.
void Processes::BroadcastInterrupt(void)
{
// If a thread is set to accept broadcast interrupts set it to
// "interrupted".
schedLock.Lock();
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *p = *i;
if (p)
{
POLYUNSIGNED attrs = ThreadAttrs(p);
if (attrs & PFLAG_BROADCAST)
MakeRequest(p, kRequestInterrupt);
}
}
schedLock.Unlock();
}
// Set the asynchronous request variable for the thread. Must be called
// with the schedLock held. Tries to wake the thread up if possible.
void Processes::MakeRequest(TaskData *p, ThreadRequests request)
{
// We don't override a request to kill by an interrupt request.
if (p->requests < request)
{
p->requests = request;
p->InterruptCode();
p->threadLock.Signal();
// Set the value in the ML object as well so the ML code can see it
p->threadObject->requestCopy = TAGGED(request);
}
}
void Processes::ThreadExit(TaskData *taskData)
{
if (debugOptions & DEBUG_THREADS)
Log("THREAD: Thread %p exiting\n", taskData);
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
// Block any profile interrupt from now on. We're deleting the ML stack for this thread.
sigset_t block_sigs;
sigemptyset(&block_sigs);
sigaddset(&block_sigs, SIGVTALRM);
pthread_sigmask(SIG_BLOCK, &block_sigs, NULL);
// Remove the thread-specific data since it's no
// longer valid.
pthread_setspecific(tlsId, 0);
#endif
if (singleThreaded) finish(0);
schedLock.Lock();
ThreadReleaseMLMemoryWithSchedLock(taskData); // Allow a GC if it was waiting for us.
taskData->threadExited = true;
initialThreadWait.Signal(); // Tell it we've finished.
schedLock.Unlock();
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_exit(0);
-#elif defined(HAVE_WINDOWS_H)
+#else
ExitThread(0);
#endif
}
// These two functions are used for calls from outside where
// the lock has not yet been acquired.
void Processes::ThreadUseMLMemory(TaskData *taskData)
{
// Trying to acquire the lock here may block if a GC is in progress
schedLock.Lock();
ThreadUseMLMemoryWithSchedLock(taskData);
schedLock.Unlock();
}
void Processes::ThreadReleaseMLMemory(TaskData *taskData)
{
schedLock.Lock();
ThreadReleaseMLMemoryWithSchedLock(taskData);
schedLock.Unlock();
}
// Called when a thread wants to resume using the ML heap. That could
// be after a wait for some reason or after executing some foreign code.
// Since there could be a GC in progress already at this point we may either
// be blocked waiting to acquire schedLock or we may need to wait until
// we are woken up at the end of the GC.
void Processes::ThreadUseMLMemoryWithSchedLock(TaskData *taskData)
{
TaskData *ptaskData = taskData;
// If there is a request outstanding we have to wait for it to
// complete. We notify the root thread and wait for it.
while (threadRequest != 0)
{
initialThreadWait.Signal();
// Wait for the GC to happen
mlThreadWait.Wait(&schedLock);
}
ASSERT(! ptaskData->inMLHeap);
ptaskData->inMLHeap = true;
}
// Called to indicate that the thread has temporarily finished with the
// ML memory either because it is going to wait for something or because
// it is going to run foreign code. If there is an outstanding GC request
// that can proceed.
void Processes::ThreadReleaseMLMemoryWithSchedLock(TaskData *taskData)
{
TaskData *ptaskData = taskData;
ASSERT(ptaskData->inMLHeap);
ptaskData->inMLHeap = false;
// Put a dummy object in any unused space. This maintains the
// invariant that the allocated area is filled with valid objects.
ptaskData->FillUnusedSpace();
//
if (threadRequest != 0)
initialThreadWait.Signal();
}
// Make a request to the root thread.
void Processes::MakeRootRequest(TaskData *taskData, MainThreadRequest *request)
{
if (singleThreaded)
{
mainThreadPhase = request->mtp;
ThreadReleaseMLMemoryWithSchedLock(taskData); // Primarily to call FillUnusedSpace
request->Perform();
ThreadUseMLMemoryWithSchedLock(taskData);
mainThreadPhase = MTP_USER_CODE;
}
else
{
PLocker locker(&schedLock);
// Wait for any other requests.
while (threadRequest != 0)
{
// Deal with any pending requests.
ThreadReleaseMLMemoryWithSchedLock(taskData);
ThreadUseMLMemoryWithSchedLock(taskData); // Drops schedLock while waiting.
}
// Now the other requests have been dealt with (and we have schedLock).
request->completed = false;
threadRequest = request;
// Wait for it to complete.
while (! request->completed)
{
ThreadReleaseMLMemoryWithSchedLock(taskData);
ThreadUseMLMemoryWithSchedLock(taskData); // Drops schedLock while waiting.
}
}
}
// Find space for an object. Returns a pointer to the start. "words" must include
// the length word and the result points at where the length word will go.
PolyWord *Processes::FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg)
{
bool triedInterrupt = false;
#ifdef POLYML32IN64
if (words & 1) words++; // Must always be an even number of words.
#endif
while (1)
{
// After a GC allocPointer and allocLimit are zero and when allocating the
// heap segment we request a minimum of zero words.
if (taskData->allocPointer != 0 && taskData->allocPointer >= taskData->allocLimit + words)
{
// There's space in the current segment,
taskData->allocPointer -= words;
#ifdef POLYML32IN64
// Zero the last word. If we've rounded up an odd number the caller won't set it.
if (words != 0) taskData->allocPointer[words-1] = PolyWord::FromUnsigned(0);
ASSERT((uintptr_t)taskData->allocPointer & 4); // Must be odd-word aligned
#endif
return taskData->allocPointer;
}
else // Insufficient space in this area.
{
if (words > taskData->allocSize && ! alwaysInSeg)
{
// If the object we want is larger than the heap segment size
// we allocate it separately rather than in the segment.
PolyWord *foundSpace = gMem.AllocHeapSpace(words);
if (foundSpace) return foundSpace;
}
else
{
// Fill in any unused space in the existing segment
taskData->FillUnusedSpace();
// Get another heap segment with enough space for this object.
uintptr_t requestSpace = taskData->allocSize+words;
uintptr_t spaceSize = requestSpace;
// Get the space and update spaceSize with the actual size.
PolyWord *space = gMem.AllocHeapSpace(words, spaceSize);
if (space)
{
// Double the allocation size for the next time if
// we succeeded in allocating the whole space.
taskData->allocCount++;
if (spaceSize == requestSpace) taskData->allocSize = taskData->allocSize*2;
taskData->allocLimit = space;
taskData->allocPointer = space+spaceSize;
// Actually allocate the object
taskData->allocPointer -= words;
#ifdef POLYML32IN64
ASSERT((uintptr_t)taskData->allocPointer & 4); // Must be odd-word aligned
#endif
return taskData->allocPointer;
}
}
// It's possible that another thread has requested a GC in which case
// we will have memory when that happens. We don't want to start
// another GC.
if (! singleThreaded)
{
PLocker locker(&schedLock);
if (threadRequest != 0)
{
ThreadReleaseMLMemoryWithSchedLock(taskData);
ThreadUseMLMemoryWithSchedLock(taskData);
continue; // Try again
}
}
// Try garbage-collecting. If this failed return 0.
if (! QuickGC(taskData, words))
{
extern FILE *polyStderr;
if (! triedInterrupt)
{
triedInterrupt = true;
fprintf(polyStderr,"Run out of store - interrupting threads\n");
if (debugOptions & DEBUG_THREADS)
Log("THREAD: Run out of store, interrupting threads\n");
BroadcastInterrupt();
try {
if (ProcessAsynchRequests(taskData))
return 0; // Has been interrupted.
}
catch(KillException &)
{
// The thread may have been killed.
ThreadExit(taskData);
}
// Not interrupted: pause this thread to allow for other
// interrupted threads to free something.
#if defined(_WIN32)
Sleep(5000);
#else
sleep(5);
#endif
// Try again.
}
else {
// That didn't work. Exit.
fprintf(polyStderr,"Failed to recover - exiting\n");
RequestProcessExit(1); // Begins the shutdown process
ThreadExit(taskData); // And terminate this thread.
}
}
// Try again. There should be space now.
}
}
}
#ifdef _MSC_VER
// Don't tell me that exitThread has a non-void type.
#pragma warning(disable:4646)
#endif
Handle exitThread(TaskData *taskData)
/* A call to this is put on the stack of a new thread so when the
thread function returns the thread goes away. */
{
processesModule.ThreadExit(taskData);
}
// Terminate the current thread. Never returns.
POLYUNSIGNED PolyThreadKillSelf(FirstArgument threadId)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall(); // Possibly not needed since we never return
processesModule.ThreadExit(taskData);
return 0;
}
/* Called when a thread is about to block, usually because of IO.
If this is interruptable (currently only used for Posix functions)
the process will be set to raise an exception if any signal is handled.
It may also raise an exception if another thread has called
broadcastInterrupt. */
void Processes::ThreadPauseForIO(TaskData *taskData, Waiter *pWait)
{
TestAnyEvents(taskData); // Consider this a blocking call that may raise Interrupt
ThreadReleaseMLMemory(taskData);
globalStats.incCount(PSC_THREADS_WAIT_IO);
pWait->Wait(1000); // Wait up to a second
globalStats.decCount(PSC_THREADS_WAIT_IO);
ThreadUseMLMemory(taskData);
TestAnyEvents(taskData); // Check if we've been interrupted.
}
// Default waiter: simply wait for the time. In Unix it may be woken
// up by a signal.
void Waiter::Wait(unsigned maxMillisecs)
{
// Since this is used only when we can't monitor the source directly
// we set this to 10ms so that we're not waiting too long.
if (maxMillisecs > 10) maxMillisecs = 10;
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
Sleep(maxMillisecs);
#else
// Unix
fd_set read_fds, write_fds, except_fds;
struct timeval toWait = { 0, 0 };
toWait.tv_sec = maxMillisecs / 1000;
toWait.tv_usec = (maxMillisecs % 1000) * 1000;
FD_ZERO(&read_fds);
FD_ZERO(&write_fds);
FD_ZERO(&except_fds);
select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait);
#endif
}
static Waiter defWait;
Waiter *Waiter::defaultWaiter = &defWait;
-#ifdef HAVE_WINDOWS_H
+#ifdef _WIN32
// Wait for the specified handle to be signalled.
void WaitHandle::Wait(unsigned maxMillisecs)
{
// Wait until we get input or we're woken up.
if (maxMillisecs > m_maxWait)
maxMillisecs = m_maxWait;
if (m_Handle == NULL)
Sleep(maxMillisecs);
else WaitForSingleObject(m_Handle, maxMillisecs);
}
-#endif
-#if (!defined(_WIN32) || defined(__CYGWIN__))
+#else
+
// Unix and Cygwin: Wait for a file descriptor on input.
void WaitInputFD::Wait(unsigned maxMillisecs)
{
fd_set read_fds, write_fds, except_fds;
struct timeval toWait = { 0, 0 };
toWait.tv_sec = maxMillisecs / 1000;
toWait.tv_usec = (maxMillisecs % 1000) * 1000;
FD_ZERO(&read_fds);
if (m_waitFD >= 0) FD_SET(m_waitFD, &read_fds);
FD_ZERO(&write_fds);
FD_ZERO(&except_fds);
select(FD_SETSIZE, &read_fds, &write_fds, &except_fds, &toWait);
}
#endif
// Get the task data for the current thread. This is held in
// thread-local storage. Normally this is passed in taskData but
// in a few cases this isn't available.
TaskData *Processes::GetTaskDataForThread(void)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
return (TaskData *)pthread_getspecific(tlsId);
-#elif defined(HAVE_WINDOWS_H)
- return (TaskData *)TlsGetValue(tlsId);
#else
- // If there's no threading.
- return taskArray[0];
+ return (TaskData *)TlsGetValue(tlsId);
#endif
}
// Called to create a task data object in the current thread.
// This is currently only used if a thread created in foreign code calls
// a callback.
TaskData *Processes::CreateNewTaskData(Handle threadId, Handle threadFunction,
Handle args, PolyWord flags)
{
TaskData *taskData = machineDependent->CreateTaskData();
#if defined(HAVE_WINDOWS_H)
HANDLE thisProcess = GetCurrentProcess();
DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess,
&(taskData->threadHandle), THREAD_ALL_ACCESS, FALSE, 0);
#endif
unsigned thrdIndex;
{
PLocker lock(&schedLock);
// See if there's a spare entry in the array.
for (thrdIndex = 0;
thrdIndex < taskArray.size() && taskArray[thrdIndex] != 0;
thrdIndex++);
if (thrdIndex == taskArray.size()) // Need to expand the array
{
try {
taskArray.push_back(taskData);
} catch (std::bad_alloc&) {
delete(taskData);
throw MemoryException();
}
}
else
{
taskArray[thrdIndex] = taskData;
}
}
taskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize());
if (taskData->stack == 0)
{
delete(taskData);
throw MemoryException();
}
// TODO: Check that there isn't a problem if we try to allocate
// memory here and result in a GC.
taskData->InitStackFrame(taskData, threadFunction, args);
ThreadUseMLMemory(taskData);
// If the forking thread has created an ML thread object use that
// otherwise create a new one in the current context.
if (threadId != 0)
taskData->threadObject = (ThreadObject*)threadId->WordP();
else
{
// Make a thread reference to point to this taskData object.
Handle threadRef = MakeVolatileWord(taskData, taskData);
// Make a thread object. Since it's in the thread table it can't be garbage collected.
taskData->threadObject = (ThreadObject*)alloc(taskData, sizeof(ThreadObject)/sizeof(PolyWord), F_MUTABLE_BIT);
taskData->threadObject->threadRef = threadRef->Word();
taskData->threadObject->flags = flags != TAGGED(0) ? TAGGED(PFLAG_SYNCH): flags;
taskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store
taskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state
taskData->threadObject->mlStackSize = TAGGED(0); // Unlimited stack size
for (unsigned i = 0; i < sizeof(taskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++)
taskData->threadObject->debuggerSlots[i] = TAGGED(0);
}
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
initThreadSignals(taskData);
pthread_setspecific(tlsId, taskData);
-#elif defined(HAVE_WINDOWS_H)
+#else
TlsSetValue(tlsId, taskData);
#endif
globalStats.incCount(PSC_THREADS);
return taskData;
}
// This function is run when a new thread has been forked. The
// parameter is the taskData value for the new thread. This function
// is also called directly for the main thread.
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
static void *NewThreadFunction(void *parameter)
{
TaskData *taskData = (TaskData *)parameter;
#ifdef HAVE_WINDOWS_H
// Cygwin: Get the Windows thread handle in case it's needed for profiling.
HANDLE thisProcess = GetCurrentProcess();
DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess,
&(taskData->threadHandle), THREAD_ALL_ACCESS, FALSE, 0);
#endif
initThreadSignals(taskData);
pthread_setspecific(processesModule.tlsId, taskData);
taskData->saveVec.init(); // Remove initial data
globalStats.incCount(PSC_THREADS);
processes->ThreadUseMLMemory(taskData);
try {
(void)taskData->EnterPolyCode(); // Will normally (always?) call ExitThread.
}
catch (KillException &) {
processesModule.ThreadExit(taskData);
}
return 0;
}
-#elif defined(HAVE_WINDOWS_H)
+#else
static DWORD WINAPI NewThreadFunction(void *parameter)
{
TaskData *taskData = (TaskData *)parameter;
TlsSetValue(processesModule.tlsId, taskData);
taskData->saveVec.init(); // Removal initial data
globalStats.incCount(PSC_THREADS);
processes->ThreadUseMLMemory(taskData);
try {
(void)taskData->EnterPolyCode();
}
catch (KillException &) {
processesModule.ThreadExit(taskData);
}
return 0;
}
-#else
-static void NewThreadFunction(void *parameter)
-{
- TaskData *taskData = (TaskData *)parameter;
- initThreadSignals(taskData);
- taskData->saveVec.init(); // Removal initial data
- globalStats.incCount(PSC_THREADS);
- processes->ThreadUseMLMemory(taskData);
- try {
- (void)taskData->EnterPolyCode();
- }
- catch (KillException &) {
- processesModule.ThreadExit(taskData);
- }
-}
#endif
// Sets up the initial thread from the root function. This is run on
// the initial thread of the process so it will work if we don't
// have pthreads.
// When multithreading this thread also deals with all garbage-collection
// and similar operations and the ML threads send it requests to deal with
// that. These require all the threads to pause until the operation is complete
// since they affect all memory but they are also sometimes highly recursive.
// On Mac OS X and on Linux if the stack limit is set to unlimited only the
// initial thread has a large stack and newly created threads have smaller
// stacks. We need to make sure that any significant stack usage occurs only
// on the inital thread.
void Processes::BeginRootThread(PolyObject *rootFunction)
{
int exitLoopCount = 100; // Maximum 100 * 400 ms.
if (taskArray.size() < 1) {
try {
taskArray.push_back(0);
} catch (std::bad_alloc&) {
::Exit("Unable to create the initial thread - insufficient memory");
}
}
try {
// We can't use ForkThread because we don't have a taskData object before we start
TaskData *taskData = machineDependent->CreateTaskData();
Handle threadRef = MakeVolatileWord(taskData, taskData);
taskData->threadObject = (ThreadObject*)alloc(taskData, sizeof(ThreadObject) / sizeof(PolyWord), F_MUTABLE_BIT);
taskData->threadObject->threadRef = threadRef->Word();
// The initial thread is set to accept broadcast interrupt requests
// and handle them synchronously. This is for backwards compatibility.
taskData->threadObject->flags = TAGGED(PFLAG_BROADCAST|PFLAG_ASYNCH); // Flags
taskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store
taskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state
taskData->threadObject->mlStackSize = TAGGED(0); // Unlimited stack size
for (unsigned i = 0; i < sizeof(taskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++)
taskData->threadObject->debuggerSlots[i] = TAGGED(0);
#if defined(HAVE_WINDOWS_H)
taskData->threadHandle = mainThreadHandle;
#endif
taskArray[0] = taskData;
taskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize());
if (taskData->stack == 0)
::Exit("Unable to create the initial thread - insufficient memory");
taskData->InitStackFrame(taskData, taskData->saveVec.push(rootFunction), (Handle)0);
// Create a packet for the Interrupt exception once so that we don't have to
// allocate when we need to raise it.
// We can only do this once the taskData object has been created.
if (interrupt_exn == 0)
interrupt_exn = makeExceptionPacket(taskData, EXC_interrupt);
if (singleThreaded)
{
// If we don't have threading enter the code as if this were a new thread.
// This will call finish so will never return.
NewThreadFunction(taskData);
}
schedLock.Lock();
int errorCode = 0;
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
if (pthread_create(&taskData->threadId, NULL, NewThreadFunction, taskData) != 0)
errorCode = errno;
-#elif defined(HAVE_WINDOWS_H)
+#else
taskData->threadHandle =
CreateThread(NULL, 0, NewThreadFunction, taskData, 0, NULL);
if (taskData->threadHandle == NULL) errorCode = GetLastError();
#endif
if (errorCode != 0)
{
// Thread creation failed.
taskArray[0] = 0;
delete(taskData);
ExitWithError("Unable to create initial thread:", errorCode);
}
if (debugOptions & DEBUG_THREADS)
Log("THREAD: Forked initial root thread %p\n", taskData);
}
catch (std::bad_alloc &) {
::Exit("Unable to create the initial thread - insufficient memory");
}
// Wait until the threads terminate or make a request.
// We only release schedLock while waiting.
while (1)
{
// Look at the threads to see if they are running.
bool allStopped = true;
bool noUserThreads = true;
bool signalThreadRunning = false;
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *p = *i;
if (p)
{
if (p == sigTask) signalThreadRunning = true;
else if (! p->threadExited) noUserThreads = false;
if (p->inMLHeap)
{
allStopped = false;
// It must be running - interrupt it if we are waiting.
if (threadRequest != 0) p->InterruptCode();
}
else if (p->threadExited) // Has the thread terminated?
{
// Wait for it to actually stop then delete the task data.
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_join(p->threadId, NULL);
-#elif defined(HAVE_WINDOWS_H)
+#else
WaitForSingleObject(p->threadHandle, INFINITE);
#endif
// The thread ref is no longer valid.
*(TaskData**)(p->threadObject->threadRef.AsObjPtr()) = 0;
delete(p); // Delete the task Data
*i = 0;
globalStats.decCount(PSC_THREADS);
}
}
}
if (noUserThreads)
{
// If all threads apart from the signal thread have exited then
// we can finish but we must make sure that the signal thread has
// exited before we finally finish and deallocate the memory.
if (signalThreadRunning) exitRequest = true;
else break; // Really no threads.
}
if (allStopped && threadRequest != 0)
{
mainThreadPhase = threadRequest->mtp;
gMem.ProtectImmutable(false); // GC, sharing and export may all write to the immutable area
threadRequest->Perform();
gMem.ProtectImmutable(true);
mainThreadPhase = MTP_USER_CODE;
threadRequest->completed = true;
threadRequest = 0; // Allow a new request.
mlThreadWait.Signal();
}
// Have we had a request to stop? This may have happened while in the GC.
if (exitRequest)
{
// Set this to kill the threads.
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *taskData = *i;
if (taskData && taskData->requests != kRequestKill)
MakeRequest(taskData, kRequestKill);
}
// Leave exitRequest set so that if we're in the process of
// creating a new thread we will request it to stop when the
// taskData object has been added to the table.
}
// Now release schedLock and wait for a thread
// to wake us up or for the timer to expire to update the statistics.
if (! initialThreadWait.WaitFor(&schedLock, 400))
{
// We didn't receive a request in the last 400ms
if (exitRequest)
{
if (--exitLoopCount < 0)
{
// The loop count has expired and there is at least one thread that hasn't exited.
// Assume we've deadlocked.
#if defined(HAVE_WINDOWS_H)
ExitProcess(1);
#else
_exit(1); // Something is stuck. Get out without calling destructors.
#endif
}
}
}
// Update the periodic stats.
// Calculate the free memory. We have to be careful here because although
// we have the schedLock we don't have any lock that prevents a thread
// from allocating a new segment. Since these statistics are only
// very rough it doesn't matter if there's a glitch.
// One possibility would be see if the value of
// gMem.GetFreeAllocSpace() has changed from what it was at the
// start and recalculate if it has.
// We also count the number of threads in ML code. Taking the
// lock in EnterPolyCode on every RTS call turned out to be
// expensive.
uintptr_t freeSpace = 0;
unsigned threadsInML = 0;
for (std::vector::iterator j = taskArray.begin(); j != taskArray.end(); j++)
{
TaskData *taskData = *j;
if (taskData)
{
// This gets the values last time it was in the RTS.
PolyWord *limit = taskData->allocLimit, *ptr = taskData->allocPointer;
if (limit < ptr && (uintptr_t)(ptr-limit) < taskData->allocSize)
freeSpace += ptr-limit;
if (taskData->inML) threadsInML++;
}
}
// Add the space in the allocation areas after calculating the sizes for the
// threads in case a thread has allocated some more.
freeSpace += gMem.GetFreeAllocSpace();
globalStats.updatePeriodicStats(freeSpace, threadsInML);
}
schedLock.Unlock();
finish(exitResult); // Close everything down and exit.
}
// Create a new thread. Returns the ML thread identifier object if it succeeds.
// May raise an exception.
Handle Processes::ForkThread(TaskData *taskData, Handle threadFunction,
Handle args, PolyWord flags, PolyWord stacksize)
{
if (singleThreaded)
raise_exception_string(taskData, EXC_thread, "Threads not available");
try {
// Create a taskData object for the new thread
TaskData *newTaskData = machineDependent->CreateTaskData();
// We allocate the thread object in the PARENT's space
Handle threadRef = MakeVolatileWord(taskData, newTaskData);
Handle threadId = alloc_and_save(taskData, sizeof(ThreadObject) / sizeof(PolyWord), F_MUTABLE_BIT);
newTaskData->threadObject = (ThreadObject*)DEREFHANDLE(threadId);
newTaskData->threadObject->threadRef = threadRef->Word();
newTaskData->threadObject->flags = flags; // Flags
newTaskData->threadObject->threadLocal = TAGGED(0); // Empty thread-local store
newTaskData->threadObject->requestCopy = TAGGED(0); // Cleared interrupt state
newTaskData->threadObject->mlStackSize = stacksize;
for (unsigned i = 0; i < sizeof(newTaskData->threadObject->debuggerSlots)/sizeof(PolyWord); i++)
newTaskData->threadObject->debuggerSlots[i] = TAGGED(0);
unsigned thrdIndex;
schedLock.Lock();
// Before forking a new thread check to see whether we have been asked
// to exit. Processes::Exit sets the current set of threads to exit but won't
// see a new thread.
if (taskData->requests == kRequestKill)
{
schedLock.Unlock();
// Raise an exception although the thread may exit before we get there.
raise_exception_string(taskData, EXC_thread, "Thread is exiting");
}
// See if there's a spare entry in the array.
for (thrdIndex = 0;
thrdIndex < taskArray.size() && taskArray[thrdIndex] != 0;
thrdIndex++);
if (thrdIndex == taskArray.size()) // Need to expand the array
{
try {
taskArray.push_back(newTaskData);
} catch (std::bad_alloc&) {
delete(newTaskData);
schedLock.Unlock();
raise_exception_string(taskData, EXC_thread, "Too many threads");
}
}
else
{
taskArray[thrdIndex] = newTaskData;
}
schedLock.Unlock();
newTaskData->stack = gMem.NewStackSpace(machineDependent->InitialStackSize());
if (newTaskData->stack == 0)
{
delete(newTaskData);
raise_exception_string(taskData, EXC_thread, "Unable to allocate thread stack");
}
// Allocate anything needed for the new stack in the parent's heap.
// The child still has inMLHeap set so mustn't GC.
newTaskData->InitStackFrame(taskData, threadFunction, args);
// Now actually fork the thread.
bool success = false;
schedLock.Lock();
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
success = pthread_create(&newTaskData->threadId, NULL, NewThreadFunction, newTaskData) == 0;
-#elif defined(HAVE_WINDOWS_H)
+#else
newTaskData->threadHandle =
CreateThread(NULL, 0, NewThreadFunction, newTaskData, 0, NULL);
success = newTaskData->threadHandle != NULL;
#endif
if (success)
{
schedLock.Unlock();
if (debugOptions & DEBUG_THREADS)
Log("THREAD: Forking new thread %p from thread %p\n", newTaskData, taskData);
return threadId;
}
// Thread creation failed.
taskArray[thrdIndex] = 0;
delete(newTaskData);
schedLock.Unlock();
if (debugOptions & DEBUG_THREADS)
Log("THREAD: Fork from thread %p failed\n", taskData);
raise_exception_string(taskData, EXC_thread, "Thread creation failed");
}
catch (std::bad_alloc &) {
raise_exception_string(taskData, EXC_thread, "Insufficient memory");
}
}
// ForkFromRTS. Creates a new thread from within the RTS. This is currently used
// only to run a signal function.
bool Processes::ForkFromRTS(TaskData *taskData, Handle proc, Handle arg)
{
try {
(void)ForkThread(taskData, proc, arg, TAGGED(PFLAG_SYNCH), TAGGED(0));
return true;
} catch (IOException &)
{
// If it failed
return false;
}
}
POLYUNSIGNED PolyThreadForkThread(FirstArgument threadId, PolyWord function, PolyWord attrs, PolyWord stack)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedFunction = taskData->saveVec.push(function);
Handle result = 0;
try {
result = processesModule.ForkThread(taskData, pushedFunction, (Handle)0, attrs, stack);
}
catch (KillException &) {
processes->ThreadExit(taskData); // TestSynchronousRequests may test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Deal with any interrupt or kill requests.
bool Processes::ProcessAsynchRequests(TaskData *taskData)
{
bool wasInterrupted = false;
TaskData *ptaskData = taskData;
schedLock.Lock();
switch (ptaskData->requests)
{
case kRequestNone:
schedLock.Unlock();
break;
case kRequestInterrupt:
{
// Handle asynchronous interrupts only.
// We've been interrupted.
POLYUNSIGNED attrs = ThreadAttrs(ptaskData);
POLYUNSIGNED intBits = attrs & PFLAG_INTMASK;
if (intBits == PFLAG_ASYNCH || intBits == PFLAG_ASYNCH_ONCE)
{
if (intBits == PFLAG_ASYNCH_ONCE)
{
// Set this so from now on it's synchronous.
// This word is only ever set by the thread itself so
// we don't need to synchronise.
attrs = (attrs & (~PFLAG_INTMASK)) | PFLAG_SYNCH;
ptaskData->threadObject->flags = TAGGED(attrs);
}
ptaskData->requests = kRequestNone; // Clear this
ptaskData->threadObject->requestCopy = TAGGED(0); // And in the ML copy
schedLock.Unlock();
// Don't actually throw the exception here.
taskData->SetException(interrupt_exn);
wasInterrupted = true;
}
else schedLock.Unlock();
}
break;
case kRequestKill: // The thread has been asked to stop.
schedLock.Unlock();
throw KillException();
// Doesn't return.
}
#ifndef HAVE_WINDOWS_H
// Start the profile timer if needed.
if (profileMode == kProfileTime)
{
if (! ptaskData->runningProfileTimer)
{
ptaskData->runningProfileTimer = true;
StartProfilingTimer();
}
}
else ptaskData->runningProfileTimer = false;
// The timer will be stopped next time it goes off.
#endif
return wasInterrupted;
}
// If this thread is processing interrupts synchronously and has been
// interrupted clear the interrupt and raise the exception. This is
// called from IO routines which may block.
void Processes::TestSynchronousRequests(TaskData *taskData)
{
TaskData *ptaskData = taskData;
schedLock.Lock();
switch (ptaskData->requests)
{
case kRequestNone:
schedLock.Unlock();
break;
case kRequestInterrupt:
{
// Handle synchronous interrupts only.
// We've been interrupted.
POLYUNSIGNED attrs = ThreadAttrs(ptaskData);
POLYUNSIGNED intBits = attrs & PFLAG_INTMASK;
if (intBits == PFLAG_SYNCH)
{
ptaskData->requests = kRequestNone; // Clear this
ptaskData->threadObject->requestCopy = TAGGED(0);
schedLock.Unlock();
taskData->SetException(interrupt_exn);
throw IOException();
}
else schedLock.Unlock();
}
break;
case kRequestKill: // The thread has been asked to stop.
schedLock.Unlock();
throw KillException();
// Doesn't return.
}
}
// Check for asynchronous or synchronous events
void Processes::TestAnyEvents(TaskData *taskData)
{
TestSynchronousRequests(taskData);
if (ProcessAsynchRequests(taskData))
throw IOException();
}
// Request that the process should exit.
// This will usually be called from an ML thread as a result of
// a call to OS.Process.exit but on Windows it can be called from the GUI thread.
void Processes::RequestProcessExit(int n)
{
if (singleThreaded)
finish(n);
exitResult = n;
exitRequest = true;
PLocker lock(&schedLock); // Lock so we know the main thread is waiting
initialThreadWait.Signal(); // Wake it if it's sleeping.
}
/******************************************************************************/
/* */
/* catchVTALRM - handler for alarm-clock signal */
/* */
/******************************************************************************/
#if !defined(HAVE_WINDOWS_H)
// N.B. This may be called either by an ML thread or by the main thread.
// On the main thread taskData will be null.
static void catchVTALRM(SIG_HANDLER_ARGS(sig, context))
{
ASSERT(sig == SIGVTALRM);
if (profileMode != kProfileTime)
{
// We stop the timer for this thread on the next signal after we end profile
static struct itimerval stoptime = {{0, 0}, {0, 0}};
/* Stop the timer */
setitimer(ITIMER_VIRTUAL, & stoptime, NULL);
}
else {
TaskData *taskData = processes->GetTaskDataForThread();
handleProfileTrap(taskData, (SIGNALCONTEXT*)context);
}
}
#else /* Windows including Cygwin */
// This runs as a separate thread. Every millisecond it checks the CPU time used
// by each ML thread and increments the count for each thread that has used a
// millisecond of CPU time.
static bool testCPUtime(HANDLE hThread, LONGLONG &lastCPUTime)
{
FILETIME cTime, eTime, kTime, uTime;
// Try to get the thread CPU time if possible. This isn't supported
// in Windows 95/98 so if it fails we just include this thread anyway.
if (GetThreadTimes(hThread, &cTime, &eTime, &kTime, &uTime))
{
LONGLONG totalTime = 0;
LARGE_INTEGER li;
li.LowPart = kTime.dwLowDateTime;
li.HighPart = kTime.dwHighDateTime;
totalTime += li.QuadPart;
li.LowPart = uTime.dwLowDateTime;
li.HighPart = uTime.dwHighDateTime;
totalTime += li.QuadPart;
if (totalTime - lastCPUTime >= 10000)
{
lastCPUTime = totalTime;
return true;
}
return false;
}
else return true; // Failed to get thread time, maybe Win95.
}
void Processes::ProfileInterrupt(void)
{
// Wait for millisecond or until the stop event is signalled.
while (WaitForSingleObject(hStopEvent, 1) == WAIT_TIMEOUT)
{
// We need to hold schedLock to examine the taskArray but
// that is held during garbage collection.
if (schedLock.Trylock())
{
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *p = *i;
if (p && p->threadHandle)
{
if (testCPUtime(p->threadHandle, p->lastCPUTime))
{
CONTEXT context;
SuspendThread(p->threadHandle);
context.ContextFlags = CONTEXT_CONTROL; /* Get Eip and Esp */
if (GetThreadContext(p->threadHandle, &context))
{
handleProfileTrap(p, &context);
}
ResumeThread(p->threadHandle);
}
}
}
schedLock.Unlock();
}
// Check the CPU time used by the main thread. This is used for GC
// so we need to check that as well.
if (testCPUtime(mainThreadHandle, lastCPUTime))
handleProfileTrap(NULL, NULL);
}
}
DWORD WINAPI ProfilingTimer(LPVOID parm)
{
processesModule.ProfileInterrupt();
return 0;
}
#endif
// Profiling control. Called by the root thread.
void Processes::StartProfiling(void)
{
#ifdef HAVE_WINDOWS_H
DWORD threadId;
extern FILE *polyStdout;
if (profilingHd)
return;
ResetEvent(hStopEvent);
profilingHd = CreateThread(NULL, 0, ProfilingTimer, NULL, 0, &threadId);
if (profilingHd == NULL)
+ {
fputs("Creating ProfilingTimer thread failed.\n", polyStdout);
+ return;
+ }
/* Give this a higher than normal priority so it pre-empts the main
thread. Without this it will tend only to be run when the main
thread blocks for some reason. */
SetThreadPriority(profilingHd, THREAD_PRIORITY_ABOVE_NORMAL);
#else
// In Linux, at least, we need to run a timer in each thread.
// We request each to enter the RTS so that it will start the timer.
// Since this is being run by the main thread while all the ML threads
// are paused this may not actually be necessary.
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
TaskData *taskData = *i;
if (taskData)
{
taskData->InterruptCode();
}
}
StartProfilingTimer(); // Start the timer in the root thread.
#endif
}
void Processes::StopProfiling(void)
{
#ifdef HAVE_WINDOWS_H
if (hStopEvent) SetEvent(hStopEvent);
// Wait for the thread to stop
- if (profilingHd) WaitForSingleObject(profilingHd, 10000);
- CloseHandle(profilingHd);
+ if (profilingHd)
+ {
+ WaitForSingleObject(profilingHd, 10000);
+ CloseHandle(profilingHd);
+ }
profilingHd = NULL;
#endif
}
// Called by the ML signal handling thread. It blocks until a signal
// arrives. There should only be a single thread waiting here.
bool Processes::WaitForSignal(TaskData *taskData, PLock *sigLock)
{
TaskData *ptaskData = taskData;
// We need to hold the signal lock until we have acquired schedLock.
schedLock.Lock();
sigLock->Unlock();
if (sigTask != 0)
{
schedLock.Unlock();
return false;
}
sigTask = ptaskData;
if (ptaskData->requests == kRequestNone)
{
// Now release the ML memory. A GC can start.
ThreadReleaseMLMemoryWithSchedLock(ptaskData);
globalStats.incCount(PSC_THREADS_WAIT_SIGNAL);
ptaskData->threadLock.Wait(&schedLock);
globalStats.decCount(PSC_THREADS_WAIT_SIGNAL);
// We want to use the memory again.
ThreadUseMLMemoryWithSchedLock(ptaskData);
}
sigTask = 0;
schedLock.Unlock();
return true;
}
// Called by the signal detection thread to wake up the signal handler
// thread. Must be called AFTER releasing sigLock.
void Processes::SignalArrived(void)
{
PLocker locker(&schedLock);
if (sigTask)
sigTask->threadLock.Signal();
}
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
// This is called when the thread exits in foreign code and
// ThreadExit has not been called.
static void threaddata_destructor(void *p)
{
TaskData *pt = (TaskData *)p;
pt->threadExited = true;
// This doesn't actually wake the main thread and relies on the
// regular check to release the task data.
}
#endif
void Processes::Init(void)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_key_create(&tlsId, threaddata_destructor);
-#elif defined(HAVE_WINDOWS_H)
- tlsId = TlsAlloc();
#else
- singleThreaded = true;
+ tlsId = TlsAlloc();
#endif
#if defined(HAVE_WINDOWS_H) /* Windows including Cygwin. */
// Create stop event for time profiling.
hStopEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
// Get the thread handle for this thread.
HANDLE thisProcess = GetCurrentProcess();
DuplicateHandle(thisProcess, GetCurrentThread(), thisProcess,
&mainThreadHandle, THREAD_ALL_ACCESS, FALSE, 0);
#else
// Set up a signal handler. This will be the same for all threads.
markSignalInuse(SIGVTALRM);
setSignalHandler(SIGVTALRM, catchVTALRM);
#endif
}
#ifndef HAVE_WINDOWS_H
// On Linux, at least, each thread needs to run this.
void Processes::StartProfilingTimer(void)
{
// set virtual timer to go off every millisecond
struct itimerval starttime;
starttime.it_interval.tv_sec = starttime.it_value.tv_sec = 0;
starttime.it_interval.tv_usec = starttime.it_value.tv_usec = 1000;
setitimer(ITIMER_VIRTUAL,&starttime,NULL);
}
#endif
void Processes::Stop(void)
{
-#ifdef HAVE_PTHREAD
+#if (!defined(_WIN32))
pthread_key_delete(tlsId);
-#elif defined(HAVE_WINDOWS_H)
+#else
TlsFree(tlsId);
#endif
#if defined(HAVE_WINDOWS_H)
/* Stop the timer and profiling threads. */
if (hStopEvent) SetEvent(hStopEvent);
if (profilingHd)
{
WaitForSingleObject(profilingHd, 10000);
CloseHandle(profilingHd);
profilingHd = NULL;
}
if (hStopEvent) CloseHandle(hStopEvent);
hStopEvent = NULL;
if (mainThreadHandle) CloseHandle(mainThreadHandle);
mainThreadHandle = NULL;
#else
profileMode = kProfileOff;
// Make sure the timer is not running
struct itimerval stoptime;
memset(&stoptime, 0, sizeof(stoptime));
setitimer(ITIMER_VIRTUAL, &stoptime, NULL);
#endif
}
void Processes::GarbageCollect(ScanAddress *process)
/* Ensures that all the objects are retained and their addresses updated. */
{
/* The interrupt exn */
if (interrupt_exn != 0) {
PolyObject *p = interrupt_exn;
process->ScanRuntimeAddress(&p, ScanAddress::STRENGTH_STRONG);
interrupt_exn = (PolyException*)p;
}
for (std::vector::iterator i = taskArray.begin(); i != taskArray.end(); i++)
{
if (*i)
(*i)->GarbageCollect(process);
}
}
void TaskData::GarbageCollect(ScanAddress *process)
{
saveVec.gcScan(process);
if (threadObject != 0)
{
PolyObject *p = threadObject;
process->ScanRuntimeAddress(&p, ScanAddress::STRENGTH_STRONG);
threadObject = (ThreadObject*)p;
}
if (blockMutex != 0)
process->ScanRuntimeAddress(&blockMutex, ScanAddress::STRENGTH_STRONG);
// The allocation spaces are no longer valid.
allocPointer = 0;
allocLimit = 0;
// Divide the allocation size by four. If we have made a single allocation
// since the last GC the size will have been doubled after the allocation.
// On average for each thread, apart from the one that ran out of space
// and requested the GC, half of the space will be unused so reducing by
// four should give a good estimate for next time.
if (allocCount != 0)
{ // Do this only once for each GC.
allocCount = 0;
allocSize = allocSize/4;
if (allocSize < MIN_HEAP_SIZE)
allocSize = MIN_HEAP_SIZE;
}
- process->ScanRuntimeWord(&foreignStack);
}
// Return the number of processors.
extern unsigned NumberOfProcessors(void)
{
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
SYSTEM_INFO info;
memset(&info, 0, sizeof(info));
GetSystemInfo(&info);
if (info.dwNumberOfProcessors == 0) // Just in case
info.dwNumberOfProcessors = 1;
return info.dwNumberOfProcessors;
#elif(defined(_SC_NPROCESSORS_ONLN))
long res = sysconf(_SC_NPROCESSORS_ONLN);
if (res <= 0) res = 1;
return res;
#elif(defined(HAVE_SYSCTL) && defined(CTL_HW) && defined(HW_NCPU))
static int mib[2] = { CTL_HW, HW_NCPU };
int nCPU = 1;
size_t len = sizeof(nCPU);
if (sysctl(mib, 2, &nCPU, &len, NULL, 0) == 0 && len == sizeof(nCPU))
return nCPU;
else return 1;
#else
// Can't determine.
return 1;
#endif
}
// Return the number of physical processors. If hyperthreading is
// enabled this returns less than NumberOfProcessors. Returns zero if
// it cannot be determined.
// This can be used in Cygwin as well as native Windows.
#if (defined(HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION))
typedef BOOL (WINAPI *GETP)(SYSTEM_LOGICAL_PROCESSOR_INFORMATION*, PDWORD);
// Windows - use GetLogicalProcessorInformation if it's available.
static unsigned WinNumPhysicalProcessors(void)
{
GETP getProcInfo = (GETP) GetProcAddress(GetModuleHandle(_T("kernel32")), "GetLogicalProcessorInformation");
if (getProcInfo == 0) return 0;
// It's there - use it.
SYSTEM_LOGICAL_PROCESSOR_INFORMATION *buff = 0;
DWORD space = 0;
while (getProcInfo(buff, &space) == FALSE)
{
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER)
{
free(buff);
return 0;
}
free(buff);
buff = (PSYSTEM_LOGICAL_PROCESSOR_INFORMATION)malloc(space);
if (buff == 0) return 0;
}
// Calculate the number of full entries in case it's truncated.
unsigned nItems = space / sizeof(SYSTEM_LOGICAL_PROCESSOR_INFORMATION);
unsigned numProcs = 0;
for (unsigned i = 0; i < nItems; i++)
{
if (buff[i].Relationship == RelationProcessorCore)
numProcs++;
}
free(buff);
return numProcs;
}
#endif
// Read and parse /proc/cpuinfo
static unsigned LinuxNumPhysicalProcessors(void)
{
// Find out the total. This should be the maximum.
unsigned nProcs = NumberOfProcessors();
// If there's only one we don't need to check further.
if (nProcs <= 1) return nProcs;
long *cpus = (long*)calloc(nProcs, sizeof(long));
if (cpus == 0) return 0;
FILE *cpuInfo = fopen("/proc/cpuinfo", "r");
if (cpuInfo == NULL) { free(cpus); return 0; }
char line[40];
unsigned count = 0;
while (fgets(line, sizeof(line), cpuInfo) != NULL)
{
if (strncmp(line, "core id\t\t:", 10) == 0)
{
long n = strtol(line+10, NULL, 10);
unsigned i = 0;
// Skip this id if we've seen it already
while (i < count && cpus[i] != n) i++;
if (i == count) cpus[count++] = n;
}
if (strchr(line, '\n') == 0)
{
int ch;
do { ch = getc(cpuInfo); } while (ch != '\n' && ch != EOF);
}
}
fclose(cpuInfo);
free(cpus);
return count;
}
extern unsigned NumberOfPhysicalProcessors(void)
{
unsigned numProcs = 0;
#if (defined(HAVE_SYSTEM_LOGICAL_PROCESSOR_INFORMATION))
numProcs = WinNumPhysicalProcessors();
if (numProcs != 0) return numProcs;
#endif
#if (defined(HAVE_SYSCTLBYNAME) && defined(HAVE_SYS_SYSCTL_H))
// Mac OS X
int nCores;
size_t len = sizeof(nCores);
if (sysctlbyname("hw.physicalcpu", &nCores, &len, NULL, 0) == 0)
return (unsigned)nCores;
#endif
numProcs = LinuxNumPhysicalProcessors();
if (numProcs != 0) return numProcs;
// Any other cases?
return numProcs;
}
diff --git a/libpolyml/processes.h b/libpolyml/processes.h
index 653c6023..486bde0d 100644
--- a/libpolyml/processes.h
+++ b/libpolyml/processes.h
@@ -1,363 +1,362 @@
/*
Title: Lightweight process library
Author: David C.J. Matthews
Copyright (c) 2007-8, 2012, 2015, 2017, 2019 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef _PROCESSES_H_
#define _PROCESSES_H_
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#include "globals.h"
#include "rts_module.h"
#include "save_vec.h"
#include "noreturn.h"
#include "locking.h"
class SaveVecEntry;
typedef SaveVecEntry *Handle;
class StackSpace;
class PolyWord;
class ScanAddress;
class MDTaskData;
class Exporter;
class StackObject;
#ifdef HAVE_WINDOWS_H
typedef void *HANDLE;
#endif
#ifdef HAVE_SIGNAL_H
#include
#endif
#ifdef HAVE_UCONTEXT_H
#include
#endif
#ifdef HAVE_PTHREAD_H
#include
#endif
// SIGNALCONTEXT is the argument type that is passed to GetPCandSPFromContext
// to get the actual PC and SP in a profiling trap.
#if defined(HAVE_WINDOWS_H)
// First because it's used in both native Windows and Cygwin.
#include
#define SIGNALCONTEXT CONTEXT // This is the thread context.
#elif defined(HAVE_UCONTEXT_T)
#define SIGNALCONTEXT ucontext_t
#elif defined(HAVE_STRUCT_SIGCONTEXT)
#define SIGNALCONTEXT struct sigcontext
#else
#define SIGNALCONTEXT void
#endif
#define MIN_HEAP_SIZE 4096 // Minimum and initial heap segment size (words)
// This is the ML "thread identifier" object. The fields
// are read and set by the ML code.
class ThreadObject: public PolyObject {
public:
PolyWord threadRef; // Weak ref containing the address of the thread data. Not used by ML
PolyWord flags; // Tagged integer containing flags indicating how interrupts
// are handled. Set by ML but only by the thread itself
PolyWord threadLocal; // Head of a list of thread-local store items.
// Handled entirely by ML but only by the thread.
PolyWord requestCopy; // A tagged integer copy of the "requests" field.
// This is provided so that ML can easily test if there
// is an interrupt pending.
PolyWord mlStackSize; // A tagged integer with the maximum ML stack size in bytes
PolyWord debuggerSlots[4]; // These are used by the debugger.
};
// Other threads may make requests to a thread.
typedef enum {
kRequestNone = 0, // Increasing severity
kRequestInterrupt = 1,
kRequestKill = 2
} ThreadRequests;
// Per-thread data. This is subclassed for each architecture.
class TaskData {
public:
TaskData();
virtual ~TaskData();
void FillUnusedSpace(void);
virtual void GarbageCollect(ScanAddress *process);
virtual Handle EnterPolyCode() = 0; // Start running ML
virtual void InterruptCode() = 0;
virtual bool AddTimeProfileCount(SIGNALCONTEXT *context) = 0;
// Initialise the stack for a new thread. The parent task object is passed in because any
// allocation that needs to be made must be made in the parent.
virtual void InitStackFrame(TaskData *parentTask, Handle proc, Handle arg) = 0;
virtual void SetException(poly_exn *exc) = 0;
// If a foreign function calls back to ML we need to set up the call to the
// ML callback function.
virtual Handle EnterCallbackFunction(Handle func, Handle args) = 0;
// The scheduler needs versions of atomic increment and atomic reset that
// work in exactly the same way as the code-generated versions (if any).
// Atomic decrement isn't needed since it only ever releases a mutex.
virtual Handle AtomicIncrement(Handle mutexp) = 0;
// Reset a mutex to one. This needs to be atomic with respect to the
// atomic increment and decrement instructions.
virtual void AtomicReset(Handle mutexp) = 0;
virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length,
StackObject *new_stack, uintptr_t new_length) = 0;
virtual uintptr_t currentStackSpace(void) const = 0;
// Add a count to the local function if we are using store profiling.
virtual void addProfileCount(POLYUNSIGNED words) = 0;
// Functions called before and after an RTS call.
virtual void PreRTSCall(void) { inML = false; }
virtual void PostRTSCall(void) { inML = true; }
SaveVec saveVec;
PolyWord *allocPointer; // Allocation pointer - decremented towards...
PolyWord *allocLimit; // ... lower limit of allocation
uintptr_t allocSize; // The preferred heap segment size
unsigned allocCount; // The number of allocations since the last GC
StackSpace *stack;
ThreadObject *threadObject; // Pointer to the thread object.
int lastError; // Last error from foreign code.
void *signalStack; // Stack to handle interrupts (Unix only)
- PolyWord foreignStack; // Stack of saved data used in call_sym_and_convert
bool inML; // True when this is in ML, false in the RTS
// Get a TaskData pointer given the ML taskId.
// This is called at the start of every RTS function that may allocate memory.
// It is can be called safely to get the thread's own TaskData object without
// a lock but any call to get the TaskData for another thread must take the
// schedLock first in case the thread is exiting.
static TaskData *FindTaskForId(PolyWord taskId) {
return *(TaskData**)(((ThreadObject*)taskId.AsObjPtr())->threadRef.AsObjPtr());
}
private:
// If a thread has to block it will block on this.
PCondVar threadLock;
// External requests made are stored here until they
// can be actioned.
ThreadRequests requests;
// Pointer to the mutex when blocked. Set to NULL when it doesn't apply.
PolyObject *blockMutex;
// This is set to false when a thread blocks or enters foreign code,
// While it is true the thread can manipulate ML memory so no other
// thread can garbage collect.
bool inMLHeap;
// In Linux, at least, we need to run a separate timer in each thread
bool runningProfileTimer;
#ifdef HAVE_WINDOWS_H
LONGLONG lastCPUTime; // Used for profiling
#endif
public:
bool threadExited;
private:
#ifdef HAVE_PTHREAD_H
pthread_t threadId;
#endif
#ifdef HAVE_WINDOWS_H
public: // Because, on Cygwin, it's used in NewThreadFunction
HANDLE threadHandle;
private:
#endif
friend class Processes;
};
NORETURNFN(extern Handle exitThread(TaskData *mdTaskData));
class ScanAddress;
// Indicate what the main thread is doing if the profile
// timer goes off.
extern enum _mainThreadPhase {
MTP_USER_CODE=0,
MTP_GCPHASESHARING,
MTP_GCPHASEMARK,
MTP_GCPHASECOMPACT,
MTP_GCPHASEUPDATE,
MTP_GCQUICK,
MTP_SHARING,
MTP_EXPORTING,
MTP_SAVESTATE,
MTP_LOADSTATE,
MTP_PROFILING,
MTP_SIGHANDLER,
MTP_CYGWINSPAWN,
MTP_STOREMODULE,
MTP_LOADMODULE,
MTP_MAXENTRY
} mainThreadPhase;
// Data structure used for requests from a thread to the root
// thread. These are GCs or similar.
class MainThreadRequest
{
public:
MainThreadRequest (enum _mainThreadPhase phase): mtp(phase), completed(false) {}
virtual ~MainThreadRequest () {} // Suppress silly GCC warning
const enum _mainThreadPhase mtp;
bool completed;
virtual void Perform() = 0;
};
class PLock;
// Class to wait for a given time or for an event, whichever comes first.
//
// A pointer to this class or a subclass is passed to ThreadPauseForIO.
// Because a thread may be interrupted or killed by another ML thread we
// don't allow any thread to block indefinitely. Instead whenever a
// thread wants to do an operation that may block we have it enter a
// loop that polls for the desired condition and if it is not ready it
// calls ThreadPauseForIO. The default action is to block for a short
// period and then return so that the caller can poll again. That can
// limit performance when, for example, reading from a pipe so where possible
// we use a sub-class that waits until either input is available or it times
// out, whichever comes first, using "select" in Unix or MsgWaitForMultipleObjects
// in Windows.
// During a call to Waiter::Wait the thread is set as "not using ML memory"
// so a GC can happen while this thread is blocked.
class Waiter
{
public:
Waiter() {}
virtual ~Waiter() {}
virtual void Wait(unsigned maxMillisecs);
static Waiter *defaultWaiter;
};
-#ifdef HAVE_WINDOWS_H
+#ifdef _WIN32
class WaitHandle: public Waiter
{
public:
WaitHandle(HANDLE h, unsigned maxWait): m_Handle(h), m_maxWait(maxWait) {}
virtual void Wait(unsigned maxMillisecs);
private:
HANDLE m_Handle;
unsigned m_maxWait;
};
-#endif
-#if (! defined(_WIN32) || defined(__CYGWIN__))
+#else
+
// Unix: Wait until a file descriptor is available for input
class WaitInputFD: public Waiter
{
public:
WaitInputFD(int fd): m_waitFD(fd) {}
virtual void Wait(unsigned maxMillisecs);
private:
int m_waitFD;
};
#endif
// External interface to the Process module. These functions are all implemented
// by the Processes class.
class ProcessExternal
{
public:
virtual ~ProcessExternal() {} // Defined to suppress a warning from GCC
virtual TaskData *GetTaskDataForThread(void) = 0;
virtual TaskData *CreateNewTaskData(Handle threadId, Handle threadFunction,
Handle args, PolyWord flags) = 0;
// Request all ML threads to exit and set the result code. Does not cause
// the calling thread itself to exit since this may be called on the GUI thread.
virtual void RequestProcessExit(int n) = 0;
// Exit from this thread.
virtual NORETURNFN(void ThreadExit(TaskData *taskData)) = 0;
virtual void BroadcastInterrupt(void) = 0;
virtual void BeginRootThread(PolyObject *rootFunction) = 0;
// Called when a thread may block. Returns some time later when perhaps
// the input is available.
virtual void ThreadPauseForIO(TaskData *taskData, Waiter *pWait) = 0;
// As ThreadPauseForIO but when there is no stream
virtual void ThreadPause(TaskData *taskData) { ThreadPauseForIO(taskData, Waiter::defaultWaiter); }
// If a thread is blocking for some time it should release its use
// of the ML memory. That allows a GC. ThreadUseMLMemory returns true if
// a GC was in progress.
virtual void ThreadUseMLMemory(TaskData *taskData) = 0;
virtual void ThreadReleaseMLMemory(TaskData *taskData) = 0;
// Requests from the threads for actions that need to be performed by
// the root thread.
virtual void MakeRootRequest(TaskData *taskData, MainThreadRequest *request) = 0;
// Deal with any interrupt or kill requests.
virtual bool ProcessAsynchRequests(TaskData *taskData) = 0;
// Process an interrupt request synchronously.
virtual void TestSynchronousRequests(TaskData *taskData) = 0;
// Process any events, synchronous or asynchronous.
virtual void TestAnyEvents(TaskData *taskData) = 0;
// ForkFromRTS. Creates a new thread from within the RTS.
virtual bool ForkFromRTS(TaskData *taskData, Handle proc, Handle arg) = 0;
// Profiling control.
virtual void StartProfiling(void) = 0;
virtual void StopProfiling(void) = 0;
// Find space for an object. Returns a pointer to the start. "words" must include
// the length word and the result points at where the length word will go.
// If the allocation succeeds it may update the allocation values in the taskData object.
// If the heap is exhausted it may set this thread (or other threads) to raise an exception.
virtual PolyWord *FindAllocationSpace(TaskData *taskData, POLYUNSIGNED words, bool alwaysInSeg) = 0;
// Signal handling support. The ML signal handler thread blocks until it is
// woken up by the signal detection thread.
virtual bool WaitForSignal(TaskData *taskData, PLock *sigLock) = 0;
virtual void SignalArrived(void) = 0;
// After a Unix fork we only have a single thread in the new process.
virtual void SetSingleThreaded(void) = 0;
virtual poly_exn* GetInterrupt(void) = 0;
};
// Return the number of processors. Used when configuring multi-threaded GC.
extern unsigned NumberOfProcessors(void);
extern unsigned NumberOfPhysicalProcessors(void);
extern ProcessExternal *processes;
extern struct _entrypts processesEPT[];
#endif
diff --git a/libpolyml/run_time.cpp b/libpolyml/run_time.cpp
index 255bbccd..3bc894f4 100644
--- a/libpolyml/run_time.cpp
+++ b/libpolyml/run_time.cpp
@@ -1,417 +1,417 @@
/*
Title: Run-time system.
Author: Dave Matthews, Cambridge University Computer Laboratory
Copyright (c) 2000
Cambridge University Technical Services Limited
Further work copyright David C. J. Matthews 2009, 2012, 2015-18
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
#include "globals.h"
#include "gc.h"
#include "mpoly.h"
#include "arb.h"
#include "diagnostics.h"
#include "processes.h"
#include "profiling.h"
#include "run_time.h"
#include "sys.h"
#include "polystring.h"
#include "save_vec.h"
#include "rtsentry.h"
#include "memmgr.h"
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolyFullGC(FirstArgument threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyIsBigEndian();
}
#define SAVE(x) taskData->saveVec.push(x)
#define SIZEOF(x) (sizeof(x)/sizeof(PolyWord))
// This is the storage allocator for allocating heap objects in the RTS.
PolyObject *alloc(TaskData *taskData, uintptr_t data_words, unsigned flags)
/* Allocate a number of words. */
{
// Check the size. This might possibly happen with a long string.
if (data_words > MAX_OBJECT_SIZE)
raise_exception0(taskData, EXC_size);
POLYUNSIGNED words = (POLYUNSIGNED)data_words + 1;
if (profileMode == kProfileStoreAllocation)
taskData->addProfileCount(words);
PolyWord *foundSpace = processes->FindAllocationSpace(taskData, words, false);
if (foundSpace == 0)
{
// Failed - the thread is set to raise an exception.
throw IOException();
}
PolyObject *pObj = (PolyObject*)(foundSpace + 1);
pObj->SetLengthWord((POLYUNSIGNED)data_words, flags);
// Must initialise object here, because GC doesn't clean store.
// Is this necessary any more? This used to be necessary when we used
// structural equality and wanted to make sure that unused bytes were cleared.
// N.B. This sets the store to zero NOT TAGGED(0).
for (POLYUNSIGNED i = 0; i < data_words; i++) pObj->Set(i, PolyWord::FromUnsigned(0));
return pObj;
}
Handle alloc_and_save(TaskData *taskData, uintptr_t size, unsigned flags)
/* Allocate and save the result on the vector. */
{
return taskData->saveVec.push(alloc(taskData, size, flags));
}
POLYUNSIGNED PolyFullGC(FirstArgument threadId)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
try {
// Can this raise an exception e.g. if there is insufficient memory?
FullGC(taskData);
} catch (...) { } // If an ML exception is raised
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned(); // Returns unit.
}
/******************************************************************************/
/* */
/* Error Messages */
/* */
/******************************************************************************/
// Return the handle to a string error message. This will return
// something like "Unknown error" from strerror if it doesn't match
// anything.
Handle errorMsg(TaskData *taskData, int err)
{
-#if (defined(_WIN32) || defined(__CYGWIN__))
+#if (defined(_WIN32))
LPTSTR lpMsg = NULL;
TCHAR *p;
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
FORMAT_MESSAGE_ALLOCATE_BUFFER |
FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, (DWORD)err, 0, (LPTSTR)&lpMsg, 1, NULL) > 0)
{
/* The message is returned with CRLF at the end. Remove them. */
for (p = lpMsg; *p != '\0' && *p != '\n' && *p != '\r'; p++);
*p = '\0';
Handle res = SAVE(C_string_to_Poly(taskData, lpMsg));
LocalFree(lpMsg);
return res;
}
#endif
// Unix and unknown Windows errors.
return SAVE(C_string_to_Poly(taskData, strerror(err)));
}
#define DEREFEXNHANDLE(_x) ((poly_exn *)DEREFHANDLE(_x))
static Handle make_exn(TaskData *taskData, int id, Handle arg, const char *fileName, int lineNo)
{
const char *exName;
switch (id) {
case EXC_interrupt: exName = "Interrupt"; break;
case EXC_syserr: exName = "SysErr"; break;
case EXC_size: exName = "Size"; break;
case EXC_overflow: exName = "Overflow"; break;
case EXC_underflow: exName = "Underflow"; break;
case EXC_divide: exName = "Div"; break;
case EXC_conversion: exName = "Conversion"; break;
case EXC_XWindows: exName = "XWindows"; break;
case EXC_subscript: exName = "Subscript"; break;
case EXC_foreign: exName = "Foreign"; break;
case EXC_Fail: exName = "Fail"; break;
case EXC_thread: exName = "Thread"; break;
case EXC_extrace: exName = "ExTrace"; break;
default: ASSERT(0); exName = "Unknown"; // Shouldn't happen.
}
Handle pushed_name = SAVE(C_string_to_Poly(taskData, exName));
Handle exnHandle = alloc_and_save(taskData, SIZEOF(poly_exn));
Handle location;
// The location data in an exception packet is either "NoLocation" (tagged 0)
// or the address of a record.
if (fileName == 0)
location = taskData->saveVec.push(TAGGED(0));
else
{
Handle file = taskData->saveVec.push(C_string_to_Poly(taskData, fileName));
Handle line = Make_fixed_precision(taskData, lineNo);
location = alloc_and_save(taskData, 5);
location->WordP()->Set(0, file->Word()); // file
location->WordP()->Set(1, line->Word()); // startLine
location->WordP()->Set(2, line->Word()); // endLine
location->WordP()->Set(3, TAGGED(0)); // startPosition
location->WordP()->Set(4, TAGGED(0)); // endPosition
}
DEREFEXNHANDLE(exnHandle)->ex_id = TAGGED(id);
DEREFEXNHANDLE(exnHandle)->ex_name = pushed_name->Word();
DEREFEXNHANDLE(exnHandle)->arg = arg->Word();
DEREFEXNHANDLE(exnHandle)->ex_location = location->Word();
return exnHandle;
}
// Create an exception packet, e.g. Interrupt, for later use. This does not have a
// location.
poly_exn *makeExceptionPacket(TaskData *taskData, int id)
{
Handle exn = make_exn(taskData, id, taskData->saveVec.push(TAGGED(0)), 0, 0);
return DEREFEXNHANDLE(exn);
}
static NORETURNFN(void raise_exception(TaskData *taskData, int id, Handle arg, const char *file, int line));
void raise_exception(TaskData *taskData, int id, Handle arg, const char *file, int line)
/* Raise an exception with no arguments. */
{
Handle exn = make_exn(taskData, id, arg, file, line);
taskData->SetException(DEREFEXNHANDLE(exn));
throw IOException(); /* Return to Poly code immediately. */
/*NOTREACHED*/
}
void raiseException0WithLocation(TaskData *taskData, int id, const char *file, int line)
/* Raise an exception with no arguments. */
{
raise_exception(taskData, id, SAVE(TAGGED(0)), file, line);
/*NOTREACHED*/
}
void raiseExceptionStringWithLocation(TaskData *taskData, int id, const char *str, const char *file, int line)
/* Raise an exception with a C string as the argument. */
{
raise_exception(taskData, id, SAVE(C_string_to_Poly(taskData, str)), file, line);
/*NOTREACHED*/
}
// This is called via a macro that puts in the file name and line number.
void raiseSycallWithLocation(TaskData *taskData, const char *errmsg, int err, const char *file, int line)
{
if (err == 0)
{
Handle pushed_option = SAVE(NONE_VALUE); /* NONE */
Handle pushed_name = SAVE(C_string_to_Poly(taskData, errmsg));
Handle pair = alloc_and_save(taskData, 2);
DEREFHANDLE(pair)->Set(0, pushed_name->Word());
DEREFHANDLE(pair)->Set(1, pushed_option->Word());
raise_exception(taskData, EXC_syserr, pair, file, line);
}
else
{
Handle errornum = Make_sysword(taskData, err);
Handle pushed_option = alloc_and_save(taskData, 1);
DEREFHANDLE(pushed_option)->Set(0, errornum->Word()); /* SOME err */
Handle pushed_name = errorMsg(taskData, err); // Generate the string.
Handle pair = alloc_and_save(taskData, 2);
DEREFHANDLE(pair)->Set(0, pushed_name->Word());
DEREFHANDLE(pair)->Set(1, pushed_option->Word());
raise_exception(taskData, EXC_syserr, pair, file, line);
}
}
void raiseExceptionFailWithLocation(TaskData *taskData, const char *str, const char *file, int line)
{
raiseExceptionStringWithLocation(taskData, EXC_Fail, str, file, line);
}
/* "Polymorphic" function to generate a list. */
Handle makeList(TaskData *taskData, int count, char *p, int size, void *arg,
Handle (mkEntry)(TaskData *, void*, char*))
{
Handle saved = taskData->saveVec.mark();
Handle list = SAVE(ListNull);
/* Start from the end of the list. */
p += count*size;
while (count > 0)
{
Handle value, next;
p -= size; /* Back up to the last entry. */
value = mkEntry(taskData, arg, p);
next = alloc_and_save(taskData, SIZEOF(ML_Cons_Cell));
DEREFLISTHANDLE(next)->h = value->Word();
DEREFLISTHANDLE(next)->t = list->Word();
taskData->saveVec.reset(saved);
list = SAVE(next->Word());
count--;
}
return list;
}
void CheckAndGrowStack(TaskData *taskData, uintptr_t minSize)
/* Expands the current stack if it has grown. We cannot shrink a stack segment
when it grows smaller because the frame is checked only at the beginning of
a function to ensure that there is enough space for the maximum that can
be allocated. */
{
/* Get current size of new stack segment. */
uintptr_t old_len = taskData->stack->spaceSize();
if (old_len >= minSize) return; /* Ok with present size. */
// If it is too small double its size.
uintptr_t new_len; /* New size */
for (new_len = old_len; new_len < minSize; new_len *= 2);
uintptr_t limitSize = getPolyUnsigned(taskData, taskData->threadObject->mlStackSize);
// Do not grow the stack if its size is already too big.
if ((limitSize != 0 && old_len >= limitSize) || ! gMem.GrowOrShrinkStack(taskData, new_len))
{
/* Cannot expand the stack any further. */
extern FILE *polyStderr;
fprintf(polyStderr, "Warning - Unable to increase stack - interrupting thread\n");
if (debugOptions & DEBUG_THREADS)
Log("THREAD: Unable to grow stack for thread %p from %lu to %lu\n", taskData, old_len, new_len);
// We really should do this only if the thread is handling interrupts
// asynchronously. On the other hand what else do we do?
taskData->SetException(processes->GetInterrupt());
}
else
{
if (debugOptions & DEBUG_THREADS)
Log("THREAD: Growing stack for thread %p from %lu to %lu\n", taskData, old_len, new_len);
}
}
Handle Make_fixed_precision(TaskData *taskData, int val)
{
if (val > MAXTAGGED || val < -MAXTAGGED-1)
raise_exception0(taskData, EXC_overflow);
return taskData->saveVec.push(TAGGED(val));
}
Handle Make_fixed_precision(TaskData *taskData, unsigned uval)
{
if (uval > MAXTAGGED)
raise_exception0(taskData, EXC_overflow);
return taskData->saveVec.push(TAGGED(uval));
}
Handle Make_fixed_precision(TaskData *taskData, long val)
{
if (val > MAXTAGGED || val < -MAXTAGGED-1)
raise_exception0(taskData, EXC_overflow);
return taskData->saveVec.push(TAGGED(val));
}
Handle Make_fixed_precision(TaskData *taskData, unsigned long uval)
{
if (uval > MAXTAGGED)
raise_exception0(taskData, EXC_overflow);
return taskData->saveVec.push(TAGGED(uval));
}
#ifdef HAVE_LONG_LONG
Handle Make_fixed_precision(TaskData *taskData, long long val)
{
if (val > MAXTAGGED || val < -MAXTAGGED-1)
raise_exception0(taskData, EXC_overflow);
return taskData->saveVec.push(TAGGED((POLYSIGNED)val));
}
Handle Make_fixed_precision(TaskData *taskData, unsigned long long uval)
{
if (uval > MAXTAGGED)
raise_exception0(taskData, EXC_overflow);
return taskData->saveVec.push(TAGGED((POLYUNSIGNED)uval));
}
#endif
Handle Make_sysword(TaskData *taskData, uintptr_t p)
{
Handle result = alloc_and_save(taskData, sizeof(uintptr_t)/sizeof(PolyWord), F_BYTE_OBJ);
*(uintptr_t*)(result->Word().AsCodePtr()) = p;
return result;
}
// A volatile ref is used for data that is not valid in a different session.
// When loaded from a saved state it is cleared to zero.
Handle MakeVolatileWord(TaskData *taskData, void *p)
{
Handle result = alloc_and_save(taskData,
WORDS(SIZEOF_VOIDP), F_BYTE_OBJ | F_WEAK_BIT | F_MUTABLE_BIT | F_NO_OVERWRITE);
*(void**)(result->Word().AsCodePtr()) = p;
return result;
}
Handle MakeVolatileWord(TaskData *taskData, uintptr_t p)
{
return MakeVolatileWord(taskData, (void*)p);
}
// This is used to determine the endian-ness that Poly/ML is running under.
// It's really only needed for the interpreter. In particular the pre-built
// compiler may be running under either byte order and has to check at
// run-time.
POLYUNSIGNED PolyIsBigEndian()
{
#ifdef WORDS_BIGENDIAN
return TAGGED(1).AsUnsigned();
#else
return TAGGED(0).AsUnsigned();
#endif
}
struct _entrypts runTimeEPT[] =
{
{ "PolyFullGC", (polyRTSFunction)&PolyFullGC},
{ "PolyIsBigEndian", (polyRTSFunction)&PolyIsBigEndian},
{ NULL, NULL} // End of list.
};
diff --git a/libpolyml/savestate.cpp b/libpolyml/savestate.cpp
index 8cc1c069..8b4822f9 100644
--- a/libpolyml/savestate.cpp
+++ b/libpolyml/savestate.cpp
@@ -1,2211 +1,2211 @@
/*
Title: savestate.cpp - Save and Load state
Copyright (c) 2007, 2015, 2017-19 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_WINDOWS_H
#include // For MAX_PATH
#endif
#ifdef HAVE_SYS_PARAM_H
#include // For MAX_PATH
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_TIME_H
#include
#endif
#ifdef HAVE_SYS_TYPES_H
#include
#endif
#ifdef HAVE_SYS_STAT_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include
#define ERRORNUMBER _doserrno
#define NOMEMORY ERROR_NOT_ENOUGH_MEMORY
#else
typedef char TCHAR;
#define _T(x) x
#define _tfopen fopen
#define _tcscpy strcpy
#define _tcsdup strdup
#define _tcslen strlen
#define _fputtc fputc
#define _fputts fputs
#ifndef lstrcmpi
#define lstrcmpi strcasecmp
#endif
#define ERRORNUMBER errno
#define NOMEMORY ENOMEM
#endif
#include "globals.h"
#include "savestate.h"
#include "processes.h"
#include "run_time.h"
#include "polystring.h"
#include "scanaddrs.h"
#include "arb.h"
#include "memmgr.h"
#include "mpoly.h" // For exportTimeStamp
#include "exporter.h" // For CopyScan
#include "machine_dep.h"
#include "osmem.h"
#include "gc.h" // For FullGC.
#include "timing.h"
#include "rtsentry.h"
#include "check_objects.h"
#include "rtsentry.h"
#include "../polyexports.h" // For InitHeaderFromExport
#include "version.h" // For InitHeaderFromExport
#ifdef _MSC_VER
// Don't tell me about ISO C++ changes.
#pragma warning(disable:4996)
#endif
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolySaveState(PolyObject *threadId, PolyWord fileName, PolyWord depth);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadState(PolyObject *threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowHierarchy(PolyObject *threadId);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyRenameParent(PolyObject *threadId, PolyWord childName, PolyWord parentName);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyShowParent(PolyObject *threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyStoreModule(PolyObject *threadId, PolyWord name, PolyWord contents);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadModule(PolyObject *threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyLoadHierarchy(PolyObject *threadId, PolyWord arg);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetModuleDirectory(PolyObject *threadId);
}
// Helper class to close files on exit.
class AutoClose {
public:
AutoClose(FILE *f = 0): m_file(f) {}
~AutoClose() { if (m_file) ::fclose(m_file); }
operator FILE*() { return m_file; }
FILE* operator = (FILE* p) { return (m_file = p); }
private:
FILE *m_file;
};
// This is probably generally useful so may be moved into
// a general header file.
template class AutoFree
{
public:
AutoFree(BASE p = 0): m_value(p) {}
~AutoFree() { free(m_value); }
// Automatic conversions to the base type.
operator BASE() { return m_value; }
BASE operator = (BASE p) { return (m_value = p); }
private:
BASE m_value;
};
/*
* Structure definitions for the saved state files.
*/
#define SAVEDSTATESIGNATURE "POLYSAVE"
#define SAVEDSTATEVERSION 2
// File header for a saved state file. This appears as the first entry
// in the file.
typedef struct _savedStateHeader
{
// These entries are primarily to check that we have a valid
// saved state file before we try to interpret anything else.
char headerSignature[8]; // Should contain SAVEDSTATESIGNATURE
unsigned headerVersion; // Should contain SAVEDSTATEVERSION
unsigned headerLength; // Number of bytes in the header
unsigned segmentDescrLength; // Number of bytes in a descriptor
// These entries contain the real data.
off_t segmentDescr; // Position of segment descriptor table
unsigned segmentDescrCount; // Number of segment descriptors in the table
off_t stringTable; // Pointer to the string table (zero if none)
size_t stringTableSize; // Size of string table
unsigned parentNameEntry; // Position of parent name in string table (0 if top)
time_t timeStamp; // The time stamp for this file.
time_t parentTimeStamp; // The time stamp for the parent.
void *originalBaseAddr; // Original base address (32-in-64 only)
} SavedStateHeader;
// Entry for segment table. This describes the segments on the disc that
// need to be loaded into memory.
typedef struct _savedStateSegmentDescr
{
off_t segmentData; // Position of the segment data
size_t segmentSize; // Size of the segment data
off_t relocations; // Position of the relocation table
unsigned relocationCount; // Number of entries in relocation table
unsigned relocationSize; // Size of a relocation entry
unsigned segmentFlags; // Segment flags (see SSF_ values)
unsigned segmentIndex; // The index of this segment or the segment it overwrites
void *originalAddress; // The base address when the segment was written.
} SavedStateSegmentDescr;
#define SSF_WRITABLE 1 // The segment contains mutable data
#define SSF_OVERWRITE 2 // The segment overwrites the data (mutable) in a parent.
#define SSF_NOOVERWRITE 4 // The segment must not be further overwritten
#define SSF_BYTES 8 // The segment contains only byte data
#define SSF_CODE 16 // The segment contains only code
typedef struct _relocationEntry
{
// Each entry indicates a location that has to be set to an address.
// The location to be set is determined by adding "relocAddress" to the base address of
// this segment (the one to which these relocations apply) and the value to store
// by adding "targetAddress" to the base address of the segment indicated by "targetSegment".
POLYUNSIGNED relocAddress; // The (byte) offset in this segment that we will set
POLYUNSIGNED targetAddress; // The value to add to the base of the destination segment
unsigned targetSegment; // The base segment. 0 is IO segment.
ScanRelocationKind relKind; // The kind of relocation (processor dependent).
} RelocationEntry;
#define SAVE(x) taskData->saveVec.push(x)
/*
* Hierarchy table: contains information about last loaded or saved state.
*/
// Pointer to list of files loaded in last load.
// There's no need for a lock since the update is only made when all
// the ML threads have stopped.
class HierarchyTable
{
public:
HierarchyTable(const TCHAR *file, time_t time):
fileName(_tcsdup(file)), timeStamp(time) { }
AutoFree fileName;
time_t timeStamp;
};
HierarchyTable **hierarchyTable;
static unsigned hierarchyDepth;
static bool AddHierarchyEntry(const TCHAR *fileName, time_t timeStamp)
{
// Add an entry to the hierarchy table for this file.
HierarchyTable *newEntry = new HierarchyTable(fileName, timeStamp);
if (newEntry == 0) return false;
HierarchyTable **newTable =
(HierarchyTable **)realloc(hierarchyTable, sizeof(HierarchyTable *)*(hierarchyDepth+1));
if (newTable == 0) return false;
hierarchyTable = newTable;
hierarchyTable[hierarchyDepth++] = newEntry;
return true;
}
// Test whether we're overwriting a parent of ourself.
#if (defined(_WIN32) || defined(__CYGWIN__))
static bool sameFile(const TCHAR *x, const TCHAR *y)
{
HANDLE hXFile = INVALID_HANDLE_VALUE, hYFile = INVALID_HANDLE_VALUE;
bool result = false;
hXFile = CreateFile(x, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
if (hXFile == INVALID_HANDLE_VALUE) goto closeAndExit;
hYFile = CreateFile(y, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
if (hYFile == INVALID_HANDLE_VALUE) goto closeAndExit;
BY_HANDLE_FILE_INFORMATION fileInfoX, fileInfoY;
if (! GetFileInformationByHandle(hXFile, &fileInfoX)) goto closeAndExit;
if (! GetFileInformationByHandle(hYFile, &fileInfoY)) goto closeAndExit;
result = fileInfoX.dwVolumeSerialNumber == fileInfoY.dwVolumeSerialNumber &&
fileInfoX.nFileIndexLow == fileInfoY.nFileIndexLow &&
fileInfoX.nFileIndexHigh == fileInfoY.nFileIndexHigh;
closeAndExit:
if (hXFile != INVALID_HANDLE_VALUE) CloseHandle(hXFile);
if (hYFile != INVALID_HANDLE_VALUE) CloseHandle(hYFile);
return result;
}
#else
static bool sameFile(const char *x, const char *y)
{
struct stat xStat, yStat;
// If either file does not exist that's fine.
if (stat(x, &xStat) != 0 || stat(y, &yStat) != 0)
return false;
return (xStat.st_dev == yStat.st_dev && xStat.st_ino == yStat.st_ino);
}
#endif
/*
* Saving state.
*/
// This class is used to create the relocations. It uses Exporter
// for this but this may perhaps be too heavyweight.
class SaveStateExport: public Exporter, public ScanAddress
{
public:
SaveStateExport(unsigned int h=0): Exporter(h), relocationCount(0) {}
public:
virtual void exportStore(void) {} // Not used.
private:
// ScanAddress overrides
virtual void ScanConstant(PolyObject *base, byte *addrOfConst, ScanRelocationKind code);
// At the moment we should only get calls to ScanConstant.
virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; }
protected:
void setRelocationAddress(void *p, POLYUNSIGNED *reloc);
PolyWord createRelocation(PolyWord p, void *relocAddr);
unsigned relocationCount;
friend class SaveRequest;
};
// Generate the address relative to the start of the segment.
void SaveStateExport::setRelocationAddress(void *p, POLYUNSIGNED *reloc)
{
unsigned area = findArea(p);
POLYUNSIGNED offset = (POLYUNSIGNED)((char*)p - (char*)memTable[area].mtOriginalAddr);
*reloc = offset;
}
// Create a relocation entry for an address at a given location.
PolyWord SaveStateExport::createRelocation(PolyWord p, void *relocAddr)
{
RelocationEntry reloc;
// Set the offset within the section we're scanning.
setRelocationAddress(relocAddr, &reloc.relocAddress);
void *addr = p.AsAddress();
unsigned addrArea = findArea(addr);
reloc.targetAddress = (POLYUNSIGNED)((char*)addr - (char*)memTable[addrArea].mtOriginalAddr);
reloc.targetSegment = (unsigned)memTable[addrArea].mtIndex;
reloc.relKind = PROCESS_RELOC_DIRECT;
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
return p; // Don't change the contents
}
/* This is called for each constant within the code.
Print a relocation entry for the word and return a value that means
that the offset is saved in original word. */
void SaveStateExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code)
{
PolyObject *p = GetConstantValue(addr, code);
if (p == 0)
return;
void *a = p;
unsigned aArea = findArea(a);
// We don't need a relocation if this is relative to the current segment
// since the relative address will already be right.
if (code == PROCESS_RELOC_I386RELATIVE && aArea == findArea(addr))
return;
// Set the value at the address to the offset relative to the symbol.
RelocationEntry reloc;
setRelocationAddress(addr, &reloc.relocAddress);
reloc.targetAddress = (POLYUNSIGNED)((char*)a - (char*)memTable[aArea].mtOriginalAddr);
reloc.targetSegment = (unsigned)memTable[aArea].mtIndex;
reloc.relKind = code;
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
}
// Request to the main thread to save data.
class SaveRequest: public MainThreadRequest
{
public:
SaveRequest(const TCHAR *name, unsigned h): MainThreadRequest(MTP_SAVESTATE),
fileName(name), newHierarchy(h),
errorMessage(0), errCode(0) {}
virtual void Perform();
const TCHAR *fileName;
unsigned newHierarchy;
const char *errorMessage;
int errCode;
};
// This class is used to update references to objects that have moved. If
// we have copied an object into the area to be exported we may still have references
// to it from the stack or from RTS data structures. We have to ensure that these
// are updated.
// This is very similar to ProcessFixupAddress in sharedata.cpp
class SaveFixupAddress: public ScanAddress
{
protected:
virtual POLYUNSIGNED ScanAddressAt(PolyWord *pt);
virtual POLYUNSIGNED ScanCodeAddressAt(PolyObject **pt) { *pt = ScanObjectAddress(*pt); return 0; }
virtual PolyObject *ScanObjectAddress(PolyObject *base);
public:
void ScanCodeSpace(CodeSpace *space);
};
POLYUNSIGNED SaveFixupAddress::ScanAddressAt(PolyWord *pt)
{
PolyWord val = *pt;
if (val.IsDataPtr() && val != PolyWord::FromUnsigned(0))
*pt = ScanObjectAddress(val.AsObjPtr());
return 0;
}
// Returns the new address if the argument is the address of an object that
// has moved, otherwise returns the original.
PolyObject *SaveFixupAddress::ScanObjectAddress(PolyObject *obj)
{
if (obj->ContainsForwardingPtr()) // tombstone is a pointer to a moved object
{
#ifdef POLYML32IN64
MemSpace *space = gMem.SpaceForAddress((PolyWord*)obj - 1);
PolyObject *newp;
if (space->isCode)
newp = (PolyObject*)(globalCodeBase + ((obj->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1));
else newp = obj->GetForwardingPtr();
#else
PolyObject *newp = obj->GetForwardingPtr();
#endif
ASSERT (newp->ContainsNormalLengthWord());
return newp;
}
ASSERT (obj->ContainsNormalLengthWord()); // object is not moved
return obj;
}
// Fix up addresses in the code area. Unlike ScanAddressesInRegion this updates
// cells that have been moved. We need to do that because we may still have
// return addresses into those cells and we don't move return addresses. We
// do want the code to see updated constant addresses.
void SaveFixupAddress::ScanCodeSpace(CodeSpace *space)
{
for (PolyWord *pt = space->bottom; pt < space->top; )
{
pt++;
PolyObject *obj = (PolyObject*)pt;
#ifdef POLYML32IN64
PolyObject *dest = obj;
while (dest->ContainsForwardingPtr())
{
MemSpace *space = gMem.SpaceForAddress((PolyWord*)dest - 1);
if (space->isCode)
dest = (PolyObject*)(globalCodeBase + ((dest->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1));
else dest = dest->GetForwardingPtr();
}
#else
PolyObject *dest = obj->FollowForwardingChain();
#endif
POLYUNSIGNED length = dest->Length();
if (length != 0)
ScanAddressesInObject(obj, dest->LengthWord());
pt += length;
}
}
// Called by the root thread to actually save the state and write the file.
void SaveRequest::Perform()
{
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Beginning saving state.\n");
// Check that we aren't overwriting our own parent.
for (unsigned q = 0; q < newHierarchy-1; q++) {
if (sameFile(hierarchyTable[q]->fileName, fileName))
{
errorMessage = "File being saved is used as a parent of this file";
errCode = 0;
if (debugOptions & DEBUG_SAVING)
Log("SAVE: File being saved is used as a parent of this file.\n");
return;
}
}
SaveStateExport exports;
// Open the file. This could quite reasonably fail if the path is wrong.
exports.exportFile = _tfopen(fileName, _T("wb"));
if (exports.exportFile == NULL)
{
errorMessage = "Cannot open save file";
errCode = ERRORNUMBER;
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Cannot open save file.\n");
return;
}
// Scan over the permanent mutable area copying all reachable data that is
// not in a lower hierarchy into new permanent segments.
CopyScan copyScan(newHierarchy);
copyScan.initialise(false);
bool success = true;
try {
for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++)
{
PermanentMemSpace *space = *i;
if (space->isMutable && !space->noOverwrite && !space->byteOnly)
{
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Scanning permanent mutable area %p allocated at %p size %lu\n",
space, space->bottom, space->spaceSize());
copyScan.ScanAddressesInRegion(space->bottom, space->top);
}
}
}
catch (MemoryException &)
{
success = false;
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Scan of permanent mutable area raised memory exception.\n");
}
// Copy the areas into the export object. Make sufficient space for
// the largest possible number of entries.
exports.memTable = new memoryTableEntry[gMem.eSpaces.size()+gMem.pSpaces.size()+1];
unsigned memTableCount = 0;
// Permanent spaces at higher level. These have to have entries although
// only the mutable entries will be written.
for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++)
{
PermanentMemSpace *space = *i;
if (space->hierarchy < newHierarchy)
{
memoryTableEntry *entry = &exports.memTable[memTableCount++];
entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom;
entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord);
entry->mtIndex = space->index;
entry->mtFlags = 0;
if (space->isMutable)
{
entry->mtFlags |= MTF_WRITEABLE;
if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE;
if (space->byteOnly) entry->mtFlags |= MTF_BYTES;
}
if (space->isCode)
entry->mtFlags |= MTF_EXECUTABLE;
}
}
unsigned permanentEntries = memTableCount; // Remember where new entries start.
// Newly created spaces.
for (std::vector::iterator i = gMem.eSpaces.begin(); i < gMem.eSpaces.end(); i++)
{
memoryTableEntry *entry = &exports.memTable[memTableCount++];
PermanentMemSpace *space = *i;
entry->mtOriginalAddr = entry->mtCurrentAddr = space->bottom;
entry->mtLength = (space->topPointer-space->bottom)*sizeof(PolyWord);
entry->mtIndex = space->index;
entry->mtFlags = 0;
if (space->isMutable)
{
entry->mtFlags |= MTF_WRITEABLE;
if (space->noOverwrite) entry->mtFlags |= MTF_NO_OVERWRITE;
if (space->byteOnly) entry->mtFlags |= MTF_BYTES;
}
if (space->isCode)
entry->mtFlags |= MTF_EXECUTABLE;
}
exports.memTableEntries = memTableCount;
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Updating references to moved objects.\n");
// Update references to moved objects.
SaveFixupAddress fixup;
for (std::vector::iterator i = gMem.lSpaces.begin(); i < gMem.lSpaces.end(); i++)
{
LocalMemSpace *space = *i;
fixup.ScanAddressesInRegion(space->bottom, space->lowerAllocPtr);
fixup.ScanAddressesInRegion(space->upperAllocPtr, space->top);
}
for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++)
fixup.ScanCodeSpace(*i);
GCModules(&fixup);
// Restore the length words in the code areas.
// Although we've updated any pointers to the start of the code we could have return addresses
// pointing to the original code. GCModules updates the stack but doesn't update return addresses.
for (std::vector::iterator i = gMem.cSpaces.begin(); i < gMem.cSpaces.end(); i++)
{
CodeSpace *space = *i;
for (PolyWord *pt = space->bottom; pt < space->top; )
{
pt++;
PolyObject *obj = (PolyObject*)pt;
if (obj->ContainsForwardingPtr())
{
#ifdef POLYML32IN64
PolyObject *forwardedTo = obj;
while (forwardedTo->ContainsForwardingPtr())
forwardedTo = (PolyObject*)(globalCodeBase + ((forwardedTo->LengthWord() & ~_OBJ_TOMBSTONE_BIT) << 1));
#else
PolyObject *forwardedTo = obj->FollowForwardingChain();
#endif
POLYUNSIGNED lengthWord = forwardedTo->LengthWord();
obj->SetLengthWord(lengthWord);
}
pt += obj->Length();
}
}
// Update the global memory space table. Old segments at the same level
// or lower are removed. The new segments become permanent.
// Try to promote the spaces even if we've had a failure because export
// spaces are deleted in ~CopyScan and we may have already copied
// some objects there.
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Promoting export spaces to permanent spaces.\n");
if (! gMem.PromoteExportSpaces(newHierarchy) || ! success)
{
errorMessage = "Out of Memory";
errCode = NOMEMORY;
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Unable to promote export spaces.\n");
return;
}
// Remove any deeper entries from the hierarchy table.
while (hierarchyDepth > newHierarchy-1)
{
hierarchyDepth--;
delete(hierarchyTable[hierarchyDepth]);
hierarchyTable[hierarchyDepth] = 0;
}
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Writing out data.\n");
// Write out the file header.
SavedStateHeader saveHeader;
memset(&saveHeader, 0, sizeof(saveHeader));
saveHeader.headerLength = sizeof(saveHeader);
strncpy(saveHeader.headerSignature,
SAVEDSTATESIGNATURE, sizeof(saveHeader.headerSignature));
saveHeader.headerVersion = SAVEDSTATEVERSION;
saveHeader.segmentDescrLength = sizeof(SavedStateSegmentDescr);
if (newHierarchy == 1)
saveHeader.parentTimeStamp = exportTimeStamp;
else
{
saveHeader.parentTimeStamp = hierarchyTable[newHierarchy-2]->timeStamp;
saveHeader.parentNameEntry = sizeof(TCHAR); // Always the first entry.
}
saveHeader.timeStamp = getBuildTime();
saveHeader.segmentDescrCount = exports.memTableEntries; // One segment for each space.
#ifdef POLYML32IN64
saveHeader.originalBaseAddr = globalHeapBase;
#endif
// Write out the header.
fwrite(&saveHeader, sizeof(saveHeader), 1, exports.exportFile);
// We need a segment header for each permanent area whether it is
// actually in this file or not.
SavedStateSegmentDescr *descrs = new SavedStateSegmentDescr [exports.memTableEntries];
for (unsigned j = 0; j < exports.memTableEntries; j++)
{
memoryTableEntry *entry = &exports.memTable[j];
memset(&descrs[j], 0, sizeof(SavedStateSegmentDescr));
descrs[j].relocationSize = sizeof(RelocationEntry);
descrs[j].segmentIndex = (unsigned)entry->mtIndex;
descrs[j].segmentSize = entry->mtLength; // Set this even if we don't write it.
descrs[j].originalAddress = entry->mtOriginalAddr;
if (entry->mtFlags & MTF_WRITEABLE)
{
descrs[j].segmentFlags |= SSF_WRITABLE;
if (entry->mtFlags & MTF_NO_OVERWRITE)
descrs[j].segmentFlags |= SSF_NOOVERWRITE;
if (j < permanentEntries && (entry->mtFlags & MTF_NO_OVERWRITE) == 0)
descrs[j].segmentFlags |= SSF_OVERWRITE;
if (entry->mtFlags & MTF_BYTES)
descrs[j].segmentFlags |= SSF_BYTES;
}
if (entry->mtFlags & MTF_EXECUTABLE)
descrs[j].segmentFlags |= SSF_CODE;
}
// Write out temporarily. Will be overwritten at the end.
saveHeader.segmentDescr = ftell(exports.exportFile);
fwrite(descrs, sizeof(SavedStateSegmentDescr), exports.memTableEntries, exports.exportFile);
// Write out the relocations and the data.
for (unsigned k = 1 /* Not IO area */; k < exports.memTableEntries; k++)
{
memoryTableEntry *entry = &exports.memTable[k];
// Write out the contents if this is new or if it is a normal, overwritable
// mutable area.
if (k >= permanentEntries ||
(entry->mtFlags & (MTF_WRITEABLE|MTF_NO_OVERWRITE)) == MTF_WRITEABLE)
{
descrs[k].relocations = ftell(exports.exportFile);
// Have to write this out.
exports.relocationCount = 0;
// Create the relocation table.
char *start = (char*)entry->mtOriginalAddr;
char *end = start + entry->mtLength;
for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; )
{
p++;
PolyObject *obj = (PolyObject*)p;
POLYUNSIGNED length = obj->Length();
// Most relocations can be computed when the saved state is
// loaded so we only write out the difficult ones: those that
// occur within compiled code.
// exports.relocateObject(obj);
if (length != 0 && obj->IsCodeObject())
machineDependent->ScanConstantsWithinCode(obj, &exports);
p += length;
}
descrs[k].relocationCount = exports.relocationCount;
// Write out the data.
descrs[k].segmentData = ftell(exports.exportFile);
fwrite(entry->mtOriginalAddr, entry->mtLength, 1, exports.exportFile);
}
}
// If this is a child we need to write a string table containing the parent name.
if (newHierarchy > 1)
{
saveHeader.stringTable = ftell(exports.exportFile);
_fputtc(0, exports.exportFile); // First byte of string table is zero
_fputts(hierarchyTable[newHierarchy-2]->fileName, exports.exportFile);
_fputtc(0, exports.exportFile); // A terminating null.
saveHeader.stringTableSize = (_tcslen(hierarchyTable[newHierarchy-2]->fileName) + 2)*sizeof(TCHAR);
}
// Rewrite the header and the segment tables now they're complete.
fseek(exports.exportFile, 0, SEEK_SET);
fwrite(&saveHeader, sizeof(saveHeader), 1, exports.exportFile);
fwrite(descrs, sizeof(SavedStateSegmentDescr), exports.memTableEntries, exports.exportFile);
if (debugOptions & DEBUG_SAVING)
Log("SAVE: Writing complete.\n");
// Add an entry to the hierarchy table for this file.
(void)AddHierarchyEntry(fileName, saveHeader.timeStamp);
delete[](descrs);
CheckMemory();
}
// Write a saved state file.
POLYUNSIGNED PolySaveState(PolyObject *threadId, PolyWord fileName, PolyWord depth)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
TempString fileNameBuff(Poly_string_to_T_alloc(fileName));
// The value of depth is zero for top-level save so we need to add one for hierarchy.
unsigned newHierarchy = get_C_unsigned(taskData, depth) + 1;
if (newHierarchy > hierarchyDepth + 1)
raise_fail(taskData, "Depth must be no more than the current hierarchy plus one");
// Request a full GC first. The main reason is to avoid running out of memory as a
// result of repeated saves. Old export spaces are turned into local spaces and
// the GC will delete them if they are completely empty
FullGC(taskData);
SaveRequest request(fileNameBuff, newHierarchy);
processes->MakeRootRequest(taskData, &request);
if (request.errorMessage)
raise_syscall(taskData, request.errorMessage, request.errCode);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
/*
* Loading saved state files.
*/
class StateLoader: public MainThreadRequest
{
public:
StateLoader(bool isH, Handle files): MainThreadRequest(MTP_LOADSTATE),
isHierarchy(isH), fileNameList(files), errorResult(0), errNumber(0) { }
virtual void Perform(void);
bool LoadFile(bool isInitial, time_t requiredStamp, PolyWord tail);
bool isHierarchy;
Handle fileNameList;
const char *errorResult;
// The fileName here is the last file loaded. As well as using it
// to load the name can also be printed out at the end to identify the
// particular file in the hierarchy that failed.
AutoFree fileName;
int errNumber;
};
// Called by the main thread once all the ML threads have stopped.
void StateLoader::Perform(void)
{
// Copy the first file name into the buffer.
if (isHierarchy)
{
if (ML_Cons_Cell::IsNull(fileNameList->Word()))
{
errorResult = "Hierarchy list is empty";
return;
}
ML_Cons_Cell *p = DEREFLISTHANDLE(fileNameList);
fileName = Poly_string_to_T_alloc(p->h);
if (fileName == NULL)
{
errorResult = "Insufficient memory";
errNumber = NOMEMORY;
return;
}
(void)LoadFile(true, 0, p->t);
}
else
{
fileName = Poly_string_to_T_alloc(fileNameList->Word());
if (fileName == NULL)
{
errorResult = "Insufficient memory";
errNumber = NOMEMORY;
return;
}
(void)LoadFile(true, 0, TAGGED(0));
}
}
class ClearWeakByteRef: public ScanAddress
{
public:
ClearWeakByteRef() {}
virtual PolyObject *ScanObjectAddress(PolyObject *base) { return base; }
virtual void ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord);
};
// Set the values of external references and clear the values of other weak byte refs.
void ClearWeakByteRef::ScanAddressesInObject(PolyObject *base, POLYUNSIGNED lengthWord)
{
if (OBJ_IS_MUTABLE_OBJECT(lengthWord) && OBJ_IS_BYTE_OBJECT(lengthWord) && OBJ_IS_WEAKREF_OBJECT(lengthWord))
{
POLYUNSIGNED len = OBJ_OBJECT_LENGTH(lengthWord);
if (len > 0) base->Set(0, PolyWord::FromSigned(0));
setEntryPoint(base);
}
}
// This is copied from the B-tree in MemMgr. It probably should be
// merged but will do for the moment. It's intended to reduce the
// cost of finding the segment for relocation.
class SpaceBTree
{
public:
SpaceBTree(bool is, unsigned i = 0) : isLeaf(is), index(i) { }
virtual ~SpaceBTree() {}
bool isLeaf;
unsigned index; // The index if this is a leaf
};
// A non-leaf node in the B-tree
class SpaceBTreeTree : public SpaceBTree
{
public:
SpaceBTreeTree();
virtual ~SpaceBTreeTree();
SpaceBTree *tree[256];
};
SpaceBTreeTree::SpaceBTreeTree() : SpaceBTree(false)
{
for (unsigned i = 0; i < 256; i++)
tree[i] = 0;
}
SpaceBTreeTree::~SpaceBTreeTree()
{
for (unsigned i = 0; i < 256; i++)
delete(tree[i]);
}
// This class is used to relocate addresses in areas that have been loaded.
class LoadRelocate: public ScanAddress
{
public:
LoadRelocate(bool pcc = false): processCodeConstants(pcc), originalBaseAddr(0), descrs(0),
targetAddresses(0), nDescrs(0), spaceTree(0) {}
~LoadRelocate();
void RelocateObject(PolyObject *p);
virtual PolyObject *ScanObjectAddress(PolyObject *base) { ASSERT(0); return base; } // Not used
virtual void ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code);
void RelocateAddressAt(PolyWord *pt);
PolyObject *RelocateAddress(PolyObject *obj);
void AddTreeRange(SpaceBTree **t, unsigned index, uintptr_t startS, uintptr_t endS);
bool processCodeConstants;
PolyWord *originalBaseAddr;
SavedStateSegmentDescr *descrs;
PolyWord **targetAddresses;
unsigned nDescrs;
SpaceBTree *spaceTree;
intptr_t relativeOffset;
};
LoadRelocate::~LoadRelocate()
{
if (descrs) delete[](descrs);
if (targetAddresses) delete[](targetAddresses);
delete(spaceTree);
}
// Add an entry to the space B-tree.
void LoadRelocate::AddTreeRange(SpaceBTree **tt, unsigned index, uintptr_t startS, uintptr_t endS)
{
if (*tt == 0)
*tt = new SpaceBTreeTree;
ASSERT(!(*tt)->isLeaf);
SpaceBTreeTree *t = (SpaceBTreeTree*)*tt;
const unsigned shift = (sizeof(void*) - 1) * 8; // Takes the high-order byte
uintptr_t r = startS >> shift;
ASSERT(r < 256);
const uintptr_t s = endS == 0 ? 256 : endS >> shift;
ASSERT(s >= r && s <= 256);
if (r == s) // Wholly within this entry
AddTreeRange(&(t->tree[r]), index, startS << 8, endS << 8);
else
{
// Deal with any remainder at the start.
if ((r << shift) != startS)
{
AddTreeRange(&(t->tree[r]), index, startS << 8, 0 /*End of range*/);
r++;
}
// Whole entries.
while (r < s)
{
ASSERT(t->tree[r] == 0);
t->tree[r] = new SpaceBTree(true, index);
r++;
}
// Remainder at the end.
if ((s << shift) != endS)
AddTreeRange(&(t->tree[r]), index, 0, endS << 8);
}
}
// Update the addresses in a group of words.
void LoadRelocate::RelocateAddressAt(PolyWord *pt)
{
PolyWord val = *pt;
if (! val.IsTagged())
*pt = RelocateAddress(val.AsObjPtr(originalBaseAddr));
}
PolyObject *LoadRelocate::RelocateAddress(PolyObject *obj)
{
// Which segment is this address in?
// N.B. As with SpaceForAddress we need to subtract 1 to point to the length word.
uintptr_t t = (uintptr_t)((PolyWord*)obj - 1);
SpaceBTree *tr = spaceTree;
// Each level of the tree is either a leaf or a vector of trees.
unsigned j = sizeof(void *) * 8;
for (;;)
{
if (tr == 0) break;
if (tr->isLeaf) {
// It's in this segment: relocate it to the current position.
unsigned i = tr->index;
SavedStateSegmentDescr *descr = &descrs[i];
PolyWord *newAddress = targetAddresses[descr->segmentIndex];
ASSERT((char*)obj > descr->originalAddress &&
(char*)obj <= (char*)descr->originalAddress + descr->segmentSize);
ASSERT(newAddress != 0);
byte *setAddress = (byte*)newAddress + ((char*)obj - (char*)descr->originalAddress);
return (PolyObject*)setAddress;
}
j -= 8;
tr = ((SpaceBTreeTree*)tr)->tree[(t >> j) & 0xff];
}
// This should never happen.
ASSERT(0);
return 0;
}
// This is based on Exporter::relocateObject but does the reverse.
// It attempts to adjust all the addresses in the object when it has
// been read in.
void LoadRelocate::RelocateObject(PolyObject *p)
{
if (p->IsByteObject())
{
}
else if (p->IsCodeObject())
{
POLYUNSIGNED constCount;
PolyWord *cp;
ASSERT(! p->IsMutable() );
p->GetConstSegmentForCode(cp, constCount);
/* Now the constant area. */
for (POLYUNSIGNED i = 0; i < constCount; i++) RelocateAddressAt(&(cp[i]));
// Saved states and modules have relocation entries for constants in the code.
// We can't use them when loading object files in 32-in-64 so have to process the
// constants here.
if (processCodeConstants)
{
POLYUNSIGNED length = p->Length();
machineDependent->ScanConstantsWithinCode(p, p, length, this);
}
}
else if (p->IsClosureObject())
{
// The first word is the address of the code.
POLYUNSIGNED length = p->Length();
*(PolyObject**)p = RelocateAddress(*(PolyObject**)p);
for (POLYUNSIGNED i = sizeof(PolyObject*)/sizeof(PolyWord); i < length; i++)
RelocateAddressAt(p->Offset(i));
}
else /* Ordinary objects, essentially tuples. */
{
POLYUNSIGNED length = p->Length();
for (POLYUNSIGNED i = 0; i < length; i++) RelocateAddressAt(p->Offset(i));
}
}
// Update addresses as constants within the code.
void LoadRelocate::ScanConstant(PolyObject *base, byte *addressOfConstant, ScanRelocationKind code)
{
PolyObject *p = GetConstantValue(addressOfConstant, code, originalBaseAddr);
if (p != 0)
{
// Relative addresses are computed by adding the CURRENT address.
// We have to convert them into addresses in original space before we
// can relocate them.
if (code == PROCESS_RELOC_I386RELATIVE)
p = (PolyObject*)((PolyWord*)p + relativeOffset);
PolyObject *newValue = RelocateAddress(p);
SetConstantValue(addressOfConstant, newValue, code);
}
}
// Load a saved state file. Calls itself to handle parent files.
bool StateLoader::LoadFile(bool isInitial, time_t requiredStamp, PolyWord tail)
{
LoadRelocate relocate;
AutoFree thisFile(_tcsdup(fileName));
AutoClose loadFile(_tfopen(fileName, _T("rb")));
if ((FILE*)loadFile == NULL)
{
errorResult = "Cannot open load file";
errNumber = ERRORNUMBER;
return false;
}
SavedStateHeader header;
// Read the header and check the signature.
if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1)
{
errorResult = "Unable to load header";
return false;
}
if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0)
{
errorResult = "File is not a saved state";
return false;
}
if (header.headerVersion != SAVEDSTATEVERSION ||
header.headerLength != sizeof(SavedStateHeader) ||
header.segmentDescrLength != sizeof(SavedStateSegmentDescr))
{
errorResult = "Unsupported version of saved state file";
return false;
}
// Check that we have the required stamp before loading any children.
// If a parent has been overwritten we could get a loop.
if (! isInitial && header.timeStamp != requiredStamp)
{
// Time-stamps don't match.
errorResult = "The parent for this saved state does not match or has been changed";
return false;
}
// Have verified that this is a reasonable saved state file. If it isn't a
// top-level file we have to load the parents first.
if (header.parentNameEntry != 0)
{
if (isHierarchy)
{
// Take the file name from the list
if (ML_Cons_Cell::IsNull(tail))
{
errorResult = "Missing parent name in argument list";
return false;
}
ML_Cons_Cell *p = (ML_Cons_Cell *)tail.AsObjPtr();
fileName = Poly_string_to_T_alloc(p->h);
if (fileName == NULL)
{
errorResult = "Insufficient memory";
errNumber = NOMEMORY;
return false;
}
if (! LoadFile(false, header.parentTimeStamp, p->t))
return false;
}
else
{
size_t toRead = header.stringTableSize-header.parentNameEntry;
size_t elems = ((toRead + sizeof(TCHAR) - 1) / sizeof(TCHAR));
// Always allow space for null terminator
size_t roundedBytes = (elems + 1) * sizeof(TCHAR);
TCHAR *newFileName = (TCHAR *)realloc(fileName, roundedBytes);
if (newFileName == NULL)
{
errorResult = "Insufficient memory";
errNumber = NOMEMORY;
return false;
}
fileName = newFileName;
if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ ||
fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 ||
fread(fileName, 1, toRead, loadFile) != toRead)
{
errorResult = "Unable to read parent file name";
return false;
}
fileName[elems] = 0; // Should already be null-terminated, but just in case.
if (! LoadFile(false, header.parentTimeStamp, TAGGED(0)))
return false;
}
ASSERT(hierarchyDepth > 0 && hierarchyTable[hierarchyDepth-1] != 0);
}
else // Top-level file
{
if (isHierarchy && ! ML_Cons_Cell::IsNull(tail))
{
// There should be no further file names if this is really the top.
errorResult = "Too many file names in the list";
return false;
}
if (header.parentTimeStamp != exportTimeStamp)
{
// Time-stamp does not match executable.
errorResult =
"Saved state was exported from a different executable or the executable has changed";
return false;
}
// Any existing spaces at this level or greater must be turned
// into local spaces. We may have references from the stack to objects that
// have previously been imported but otherwise these spaces are no longer
// needed.
gMem.DemoteImportSpaces();
// Clean out the hierarchy table.
for (unsigned h = 0; h < hierarchyDepth; h++)
{
delete(hierarchyTable[h]);
hierarchyTable[h] = 0;
}
hierarchyDepth = 0;
}
// Now have a valid, matching saved state.
// Load the segment descriptors.
relocate.nDescrs = header.segmentDescrCount;
relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs];
relocate.originalBaseAddr = (PolyWord*)header.originalBaseAddr;
if (fseek(loadFile, header.segmentDescr, SEEK_SET) != 0 ||
fread(relocate.descrs, sizeof(SavedStateSegmentDescr), relocate.nDescrs, loadFile) != relocate.nDescrs)
{
errorResult = "Unable to read segment descriptors";
return false;
}
{
unsigned maxIndex = 0;
for (unsigned i = 0; i < relocate.nDescrs; i++)
{
if (relocate.descrs[i].segmentIndex > maxIndex)
maxIndex = relocate.descrs[i].segmentIndex;
relocate.AddTreeRange(&relocate.spaceTree, i, (uintptr_t)relocate.descrs[i].originalAddress,
(uintptr_t)((char*)relocate.descrs[i].originalAddress + relocate.descrs[i].segmentSize-1));
}
relocate.targetAddresses = new PolyWord*[maxIndex+1];
for (unsigned i = 0; i <= maxIndex; i++) relocate.targetAddresses[i] = 0;
}
// Read in and create the new segments first. If we have problems,
// in particular if we have run out of memory, then it's easier to recover.
for (unsigned i = 0; i < relocate.nDescrs; i++)
{
SavedStateSegmentDescr *descr = &relocate.descrs[i];
MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex);
if (space != NULL) relocate.targetAddresses[descr->segmentIndex] = space->bottom;
if (descr->segmentData == 0)
{ // No data - just an entry in the index.
if (space == NULL/* ||
descr->segmentSize != (size_t)((char*)space->top - (char*)space->bottom)*/)
{
errorResult = "Mismatch for existing memory space";
return false;
}
}
else if ((descr->segmentFlags & SSF_OVERWRITE) == 0)
{ // New segment.
if (space != NULL)
{
errorResult = "Segment already exists";
return false;
}
// Allocate memory for the new segment.
unsigned mFlags =
(descr->segmentFlags & SSF_WRITABLE ? MTF_WRITEABLE : 0) |
(descr->segmentFlags & SSF_NOOVERWRITE ? MTF_NO_OVERWRITE : 0) |
(descr->segmentFlags & SSF_BYTES ? MTF_BYTES : 0) |
(descr->segmentFlags & SSF_CODE ? MTF_EXECUTABLE : 0);
PermanentMemSpace *newSpace =
gMem.AllocateNewPermanentSpace(descr->segmentSize, mFlags, descr->segmentIndex, hierarchyDepth + 1);
if (newSpace == 0)
{
errorResult = "Unable to allocate memory";
return false;
}
PolyWord *mem = newSpace->bottom;
if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0 ||
fread(mem, descr->segmentSize, 1, loadFile) != 1)
{
errorResult = "Unable to read segment";
return false;
}
// Fill unused space to the top of the area.
gMem.FillUnusedSpace(mem+descr->segmentSize/sizeof(PolyWord),
newSpace->spaceSize() - descr->segmentSize/sizeof(PolyWord));
// Leave it writable until we've done the relocations.
relocate.targetAddresses[descr->segmentIndex] = mem;
if (newSpace->isMutable && newSpace->byteOnly)
{
ClearWeakByteRef cwbr;
cwbr.ScanAddressesInRegion(newSpace->bottom, newSpace->topPointer);
}
}
}
// Now read in the mutable overwrites and relocate.
for (unsigned j = 0; j < relocate.nDescrs; j++)
{
SavedStateSegmentDescr *descr = &relocate.descrs[j];
MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex);
ASSERT(space != NULL); // We should have created it.
if (descr->segmentFlags & SSF_OVERWRITE)
{
if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0 ||
fread(space->bottom, descr->segmentSize, 1, loadFile) != 1)
{
errorResult = "Unable to read segment";
return false;
}
}
// Relocation.
if (descr->segmentData != 0)
{
// Adjust the addresses in the loaded segment.
for (PolyWord *p = space->bottom; p < space->top; )
{
p++;
PolyObject *obj = (PolyObject*)p;
POLYUNSIGNED length = obj->Length();
relocate.RelocateObject(obj);
p += length;
}
}
// Process explicit relocations.
// If we get errors just skip the error and continue rather than leave
// everything in an unstable state.
if (descr->relocations)
{
if (fseek(loadFile, descr->relocations, SEEK_SET) != 0)
{
errorResult = "Unable to read relocation segment";
return false;
}
for (unsigned k = 0; k < descr->relocationCount; k++)
{
RelocationEntry reloc;
if (fread(&reloc, sizeof(reloc), 1, loadFile) != 1)
{
errorResult = "Unable to read relocation segment";
return false;
}
MemSpace *toSpace = gMem.SpaceForIndex(reloc.targetSegment);
if (toSpace == NULL)
{
errorResult = "Unknown space reference in relocation";
continue;
}
byte *setAddress = (byte*)space->bottom + reloc.relocAddress;
byte *targetAddress = (byte*)toSpace->bottom + reloc.targetAddress;
if (setAddress >= (byte*)space->top || targetAddress >= (byte*)toSpace->top)
{
errorResult = "Bad relocation";
continue;
}
ScanAddress::SetConstantValue(setAddress, (PolyObject*)(targetAddress), reloc.relKind);
}
}
}
// Set the final permissions.
for (unsigned j = 0; j < relocate.nDescrs; j++)
{
SavedStateSegmentDescr *descr = &relocate.descrs[j];
PermanentMemSpace *space = gMem.SpaceForIndex(descr->segmentIndex);
gMem.CompletePermanentSpaceAllocation(space);
}
// Add an entry to the hierarchy table for this file.
if (! AddHierarchyEntry(thisFile, header.timeStamp))
return false;
return true; // Succeeded
}
static void LoadState(TaskData *taskData, bool isHierarchy, Handle hFileList)
// Load a saved state or a hierarchy.
// hFileList is a list if this is a hierarchy and a single name if it is not.
{
StateLoader loader(isHierarchy, hFileList);
// Request the main thread to do the load. This may set the error string if it failed.
processes->MakeRootRequest(taskData, &loader);
if (loader.errorResult != 0)
{
if (loader.errNumber == 0)
raise_fail(taskData, loader.errorResult);
else
{
AutoFree buff((char *)malloc(strlen(loader.errorResult) + 2 + _tcslen(loader.fileName) * sizeof(TCHAR) + 1));
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "%s: %S", loader.errorResult, (TCHAR *)loader.fileName);
#else
sprintf(buff, "%s: %s", loader.errorResult, (TCHAR *)loader.fileName);
#endif
raise_syscall(taskData, buff, loader.errNumber);
}
}
}
// Load a saved state file and any ancestors.
POLYUNSIGNED PolyLoadState(PolyObject *threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
try {
LoadState(taskData, false, pushedArg);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
// Load hierarchy. This provides a complete list of children and parents.
POLYUNSIGNED PolyLoadHierarchy(PolyObject *threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
try {
LoadState(taskData, true, pushedArg);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
/*
* Additional functions to provide information or change saved-state files.
*/
// These functions do not affect the global state so can be executed by
// the ML threads directly.
static Handle ShowHierarchy(TaskData *taskData)
// Return the list of files in the hierarchy.
{
Handle saved = taskData->saveVec.mark();
Handle list = SAVE(ListNull);
// Process this in reverse order.
for (unsigned i = hierarchyDepth; i > 0; i--)
{
Handle value = SAVE(C_string_to_Poly(taskData, hierarchyTable[i-1]->fileName));
Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell)/sizeof(PolyWord));
DEREFLISTHANDLE(next)->h = value->Word();
DEREFLISTHANDLE(next)->t = list->Word();
taskData->saveVec.reset(saved);
list = SAVE(next->Word());
}
return list;
}
// Show the hierarchy.
POLYUNSIGNED PolyShowHierarchy(PolyObject *threadId)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = ShowHierarchy(taskData);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
static void RenameParent(TaskData *taskData, PolyWord childName, PolyWord parentName)
// Change the name of the immediate parent stored in a child
{
// The name of the file to modify.
AutoFree fileNameBuff(Poly_string_to_T_alloc(childName));
if (fileNameBuff == NULL)
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
// The new parent name to insert.
AutoFree parentNameBuff(Poly_string_to_T_alloc(parentName));
if (parentNameBuff == NULL)
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
AutoClose loadFile(_tfopen(fileNameBuff, _T("r+b"))); // Open for reading and writing
if ((FILE*)loadFile == NULL)
{
AutoFree buff((char *)malloc(23 + _tcslen(fileNameBuff) * sizeof(TCHAR) + 1));
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "Cannot open load file: %S", (TCHAR *)fileNameBuff);
#else
sprintf(buff, "Cannot open load file: %s", (TCHAR *)fileNameBuff);
#endif
raise_syscall(taskData, buff, ERRORNUMBER);
}
SavedStateHeader header;
// Read the header and check the signature.
if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1)
raise_fail(taskData, "Unable to load header");
if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0)
raise_fail(taskData, "File is not a saved state");
if (header.headerVersion != SAVEDSTATEVERSION ||
header.headerLength != sizeof(SavedStateHeader) ||
header.segmentDescrLength != sizeof(SavedStateSegmentDescr))
{
raise_fail(taskData, "Unsupported version of saved state file");
}
// Does this actually have a parent?
if (header.parentNameEntry == 0)
raise_fail(taskData, "File does not have a parent");
// At the moment the only entry in the string table is the parent
// name so we can simply write a new one on the end of the file.
// This makes the file grow slightly each time but it shouldn't be
// significant.
fseek(loadFile, 0, SEEK_END);
header.stringTable = ftell(loadFile); // Remember where this is
_fputtc(0, loadFile); // First byte of string table is zero
_fputts(parentNameBuff, loadFile);
_fputtc(0, loadFile); // A terminating null.
header.stringTableSize = (_tcslen(parentNameBuff) + 2)*sizeof(TCHAR);
// Now rewind and write the header with the revised string table.
fseek(loadFile, 0, SEEK_SET);
fwrite(&header, sizeof(header), 1, loadFile);
}
POLYUNSIGNED PolyRenameParent(PolyObject *threadId, PolyWord childName, PolyWord parentName)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
try {
RenameParent(taskData, childName, parentName);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
static Handle ShowParent(TaskData *taskData, Handle hFileName)
// Return the name of the immediate parent stored in a child
{
AutoFree fileNameBuff(Poly_string_to_T_alloc(hFileName->Word()));
if (fileNameBuff == NULL)
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
AutoClose loadFile(_tfopen(fileNameBuff, _T("rb")));
if ((FILE*)loadFile == NULL)
{
AutoFree buff((char *)malloc(23 + _tcslen(fileNameBuff) * sizeof(TCHAR) + 1));
if (buff == NULL)
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "Cannot open load file: %S", (TCHAR *)fileNameBuff);
#else
sprintf(buff, "Cannot open load file: %s", (TCHAR *)fileNameBuff);
#endif
raise_syscall(taskData, buff, ERRORNUMBER);
}
SavedStateHeader header;
// Read the header and check the signature.
if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1)
raise_fail(taskData, "Unable to load header");
if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0)
raise_fail(taskData, "File is not a saved state");
if (header.headerVersion != SAVEDSTATEVERSION ||
header.headerLength != sizeof(SavedStateHeader) ||
header.segmentDescrLength != sizeof(SavedStateSegmentDescr))
{
raise_fail(taskData, "Unsupported version of saved state file");
}
// Does this have a parent?
if (header.parentNameEntry != 0)
{
size_t toRead = header.stringTableSize-header.parentNameEntry;
size_t elems = ((toRead + sizeof(TCHAR) - 1) / sizeof(TCHAR));
// Always allow space for null terminator
size_t roundedBytes = (elems + 1) * sizeof(TCHAR);
AutoFree parentFileName((TCHAR *)malloc(roundedBytes));
if (parentFileName == NULL)
raise_syscall(taskData, "Insufficient memory", NOMEMORY);
if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ ||
fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 ||
fread(parentFileName, 1, toRead, loadFile) != toRead)
{
raise_fail(taskData, "Unable to read parent file name");
}
parentFileName[elems] = 0; // Should already be null-terminated, but just in case.
// Convert the name into a Poly string and then build a "Some" value.
// It's possible, although silly, to have the empty string as a parent name.
Handle resVal = SAVE(C_string_to_Poly(taskData, parentFileName));
Handle result = alloc_and_save(taskData, 1);
DEREFHANDLE(result)->Set(0, resVal->Word());
return result;
}
else return SAVE(NONE_VALUE);
}
// Return the name of the immediate parent stored in a child
POLYUNSIGNED PolyShowParent(PolyObject *threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = ShowParent(taskData, pushedArg);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Module system
#define MODULESIGNATURE "POLYMODU"
#define MODULEVERSION 2
typedef struct _moduleHeader
{
// These entries are primarily to check that we have a valid
// saved state file before we try to interpret anything else.
char headerSignature[8]; // Should contain MODULESIGNATURE
unsigned headerVersion; // Should contain MODULEVERSION
unsigned headerLength; // Number of bytes in the header
unsigned segmentDescrLength; // Number of bytes in a descriptor
// These entries contain the real data.
off_t segmentDescr; // Position of segment descriptor table
unsigned segmentDescrCount; // Number of segment descriptors in the table
time_t timeStamp; // The time stamp for this file.
time_t executableTimeStamp; // The time stamp for the parent executable.
// Root
uintptr_t rootSegment;
POLYUNSIGNED rootOffset;
} ModuleHeader;
// Store a module
class ModuleStorer: public MainThreadRequest
{
public:
ModuleStorer(const TCHAR *file, Handle r):
MainThreadRequest(MTP_STOREMODULE), fileName(file), root(r), errorMessage(0), errCode(0) {}
virtual void Perform();
const TCHAR *fileName;
Handle root;
const char *errorMessage;
int errCode;
};
class ModuleExport: public SaveStateExport
{
public:
ModuleExport(): SaveStateExport(1/* Everything EXCEPT the executable. */) {}
virtual void exportStore(void); // Write the data out.
};
void ModuleStorer::Perform()
{
ModuleExport exporter;
#if (defined(_WIN32) && defined(UNICODE))
exporter.exportFile = _wfopen(fileName, L"wb");
#else
exporter.exportFile = fopen(fileName, "wb");
#endif
if (exporter.exportFile == NULL)
{
errorMessage = "Cannot open export file";
errCode = ERRORNUMBER;
return;
}
// RunExport copies everything reachable from the root, except data from
// the executable because we've set the hierarchy to 1, using CopyScan.
// It builds the tables in the export data structure then calls exportStore
// to actually write the data.
if (! root->Word().IsDataPtr())
{
// If we have a completely empty module the list may be null.
// This needs to be dealt with at a higher level.
errorMessage = "Module root is not an address";
return;
}
exporter.RunExport(root->WordP());
errorMessage = exporter.errorMessage; // This will be null unless there's been an error.
}
void ModuleExport::exportStore(void)
{
// What we need to do here is implement the export in a similar way to e.g. PECOFFExport::exportStore
// This is copied from SaveRequest::Perform and should be common code.
ModuleHeader modHeader;
memset(&modHeader, 0, sizeof(modHeader));
modHeader.headerLength = sizeof(modHeader);
strncpy(modHeader.headerSignature,
MODULESIGNATURE, sizeof(modHeader.headerSignature));
modHeader.headerVersion = MODULEVERSION;
modHeader.segmentDescrLength = sizeof(SavedStateSegmentDescr);
modHeader.executableTimeStamp = exportTimeStamp;
{
unsigned rootArea = findArea(this->rootFunction);
struct _memTableEntry *mt = &memTable[rootArea];
modHeader.rootSegment = mt->mtIndex;
modHeader.rootOffset = (POLYUNSIGNED)((char*)this->rootFunction - (char*)mt->mtOriginalAddr);
}
modHeader.timeStamp = getBuildTime();
modHeader.segmentDescrCount = this->memTableEntries; // One segment for each space.
// Write out the header.
fwrite(&modHeader, sizeof(modHeader), 1, this->exportFile);
SavedStateSegmentDescr *descrs = new SavedStateSegmentDescr [this->memTableEntries];
// We need an entry in the descriptor tables for each segment in the executable because
// we may have relocations that refer to addresses in it.
for (unsigned j = 0; j < this->memTableEntries; j++)
{
SavedStateSegmentDescr *thisDescr = &descrs[j];
memoryTableEntry *entry = &this->memTable[j];
memset(thisDescr, 0, sizeof(SavedStateSegmentDescr));
thisDescr->relocationSize = sizeof(RelocationEntry);
thisDescr->segmentIndex = (unsigned)entry->mtIndex;
thisDescr->segmentSize = entry->mtLength; // Set this even if we don't write it.
thisDescr->originalAddress = entry->mtOriginalAddr;
if (entry->mtFlags & MTF_WRITEABLE)
{
thisDescr->segmentFlags |= SSF_WRITABLE;
if (entry->mtFlags & MTF_NO_OVERWRITE)
thisDescr->segmentFlags |= SSF_NOOVERWRITE;
if ((entry->mtFlags & MTF_NO_OVERWRITE) == 0)
thisDescr->segmentFlags |= SSF_OVERWRITE;
if (entry->mtFlags & MTF_BYTES)
thisDescr->segmentFlags |= SSF_BYTES;
}
if (entry->mtFlags & MTF_EXECUTABLE)
thisDescr->segmentFlags |= SSF_CODE;
}
// Write out temporarily. Will be overwritten at the end.
modHeader.segmentDescr = ftell(this->exportFile);
fwrite(descrs, sizeof(SavedStateSegmentDescr), this->memTableEntries, this->exportFile);
// Write out the relocations and the data.
for (unsigned k = 0; k < this->memTableEntries; k++)
{
SavedStateSegmentDescr *thisDescr = &descrs[k];
memoryTableEntry *entry = &this->memTable[k];
if (k >= newAreas) // Not permanent areas
{
thisDescr->relocations = ftell(this->exportFile);
// Have to write this out.
this->relocationCount = 0;
// Create the relocation table.
char *start = (char*)entry->mtOriginalAddr;
char *end = start + entry->mtLength;
for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; )
{
p++;
PolyObject *obj = (PolyObject*)p;
POLYUNSIGNED length = obj->Length();
// For saved states we don't include explicit relocations except
// in code but it's easier if we do for modules.
if (length != 0 && obj->IsCodeObject())
machineDependent->ScanConstantsWithinCode(obj, this);
relocateObject(obj);
p += length;
}
thisDescr->relocationCount = this->relocationCount;
// Write out the data.
thisDescr->segmentData = ftell(exportFile);
fwrite(entry->mtOriginalAddr, entry->mtLength, 1, exportFile);
}
}
// Rewrite the header and the segment tables now they're complete.
fseek(exportFile, 0, SEEK_SET);
fwrite(&modHeader, sizeof(modHeader), 1, exportFile);
fwrite(descrs, sizeof(SavedStateSegmentDescr), this->memTableEntries, exportFile);
delete[](descrs);
fclose(exportFile); exportFile = NULL;
}
// Store a module
POLYUNSIGNED PolyStoreModule(PolyObject *threadId, PolyWord name, PolyWord contents)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedContents = taskData->saveVec.push(contents);
try {
TempString fileName(name);
ModuleStorer storer(fileName, pushedContents);
processes->MakeRootRequest(taskData, &storer);
if (storer.errorMessage)
raise_syscall(taskData, storer.errorMessage, storer.errCode);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
return TAGGED(0).AsUnsigned();
}
// Load a module.
class ModuleLoader: public MainThreadRequest
{
public:
ModuleLoader(TaskData *taskData, const TCHAR *file):
MainThreadRequest(MTP_LOADMODULE), callerTaskData(taskData), fileName(file),
errorResult(NULL), errNumber(0), rootHandle(0) {}
virtual void Perform();
TaskData *callerTaskData;
const TCHAR *fileName;
const char *errorResult;
int errNumber;
Handle rootHandle;
};
void ModuleLoader::Perform()
{
AutoClose loadFile(_tfopen(fileName, _T("rb")));
if ((FILE*)loadFile == NULL)
{
errorResult = "Cannot open load file";
errNumber = ERRORNUMBER;
return;
}
ModuleHeader header;
// Read the header and check the signature.
if (fread(&header, sizeof(ModuleHeader), 1, loadFile) != 1)
{
errorResult = "Unable to load header";
return;
}
if (strncmp(header.headerSignature, MODULESIGNATURE, sizeof(header.headerSignature)) != 0)
{
errorResult = "File is not a Poly/ML module";
return;
}
if (header.headerVersion != MODULEVERSION ||
header.headerLength != sizeof(ModuleHeader) ||
header.segmentDescrLength != sizeof(SavedStateSegmentDescr))
{
errorResult = "Unsupported version of module file";
return;
}
if (header.executableTimeStamp != exportTimeStamp)
{
// Time-stamp does not match executable.
errorResult =
"Module was exported from a different executable or the executable has changed";
return;
}
LoadRelocate relocate;
relocate.nDescrs = header.segmentDescrCount;
relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs];
if (fseek(loadFile, header.segmentDescr, SEEK_SET) != 0 ||
fread(relocate.descrs, sizeof(SavedStateSegmentDescr), relocate.nDescrs, loadFile) != relocate.nDescrs)
{
errorResult = "Unable to read segment descriptors";
return;
}
{
unsigned maxIndex = 0;
for (unsigned i = 0; i < relocate.nDescrs; i++)
if (relocate.descrs[i].segmentIndex > maxIndex)
maxIndex = relocate.descrs[i].segmentIndex;
relocate.targetAddresses = new PolyWord*[maxIndex+1];
for (unsigned i = 0; i <= maxIndex; i++) relocate.targetAddresses[i] = 0;
}
// Read in and create the new segments first. If we have problems,
// in particular if we have run out of memory, then it's easier to recover.
for (unsigned i = 0; i < relocate.nDescrs; i++)
{
SavedStateSegmentDescr *descr = &relocate.descrs[i];
MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex);
if (descr->segmentData == 0)
{ // No data - just an entry in the index.
if (space == NULL/* ||
descr->segmentSize != (size_t)((char*)space->top - (char*)space->bottom)*/)
{
errorResult = "Mismatch for existing memory space";
return;
}
else relocate.targetAddresses[descr->segmentIndex] = space->bottom;
}
else
{ // New segment.
if (space != NULL)
{
errorResult = "Segment already exists";
return;
}
// Allocate memory for the new segment.
size_t actualSize = descr->segmentSize;
MemSpace *space;
if (descr->segmentFlags & SSF_CODE)
{
CodeSpace *cSpace = gMem.NewCodeSpace(actualSize);
if (cSpace == 0)
{
errorResult = "Unable to allocate memory";
return;
}
space = cSpace;
cSpace->firstFree = (PolyWord*)((byte*)space->bottom + descr->segmentSize);
if (cSpace->firstFree != cSpace->top)
gMem.FillUnusedSpace(cSpace->firstFree, cSpace->top - cSpace->firstFree);
}
else
{
LocalMemSpace *lSpace = gMem.NewLocalSpace(actualSize, descr->segmentFlags & SSF_WRITABLE);
if (lSpace == 0)
{
errorResult = "Unable to allocate memory";
return;
}
space = lSpace;
lSpace->lowerAllocPtr = (PolyWord*)((byte*)lSpace->bottom + descr->segmentSize);
}
if (fseek(loadFile, descr->segmentData, SEEK_SET) != 0 ||
fread(space->bottom, descr->segmentSize, 1, loadFile) != 1)
{
errorResult = "Unable to read segment";
return;
}
relocate.targetAddresses[descr->segmentIndex] = space->bottom;
if (space->isMutable && (descr->segmentFlags & SSF_BYTES) != 0)
{
ClearWeakByteRef cwbr;
cwbr.ScanAddressesInRegion(space->bottom, (PolyWord*)((byte*)space->bottom + descr->segmentSize));
}
}
}
// Now deal with relocation.
for (unsigned j = 0; j < relocate.nDescrs; j++)
{
SavedStateSegmentDescr *descr = &relocate.descrs[j];
PolyWord *baseAddr = relocate.targetAddresses[descr->segmentIndex];
ASSERT(baseAddr != NULL); // We should have created it.
// Process explicit relocations.
// If we get errors just skip the error and continue rather than leave
// everything in an unstable state.
if (descr->relocations)
{
if (fseek(loadFile, descr->relocations, SEEK_SET) != 0)
errorResult = "Unable to read relocation segment";
for (unsigned k = 0; k < descr->relocationCount; k++)
{
RelocationEntry reloc;
if (fread(&reloc, sizeof(reloc), 1, loadFile) != 1)
errorResult = "Unable to read relocation segment";
byte *setAddress = (byte*)baseAddr + reloc.relocAddress;
byte *targetAddress = (byte*)relocate.targetAddresses[reloc.targetSegment] + reloc.targetAddress;
ScanAddress::SetConstantValue(setAddress, (PolyObject*)(targetAddress), reloc.relKind);
}
}
}
// Get the root address. Push this to the caller's save vec. If we put the
// newly created areas into local memory we could get a GC as soon as we
// complete this root request.
{
PolyWord *baseAddr = relocate.targetAddresses[header.rootSegment];
rootHandle = callerTaskData->saveVec.push((PolyObject*)((byte*)baseAddr + header.rootOffset));
}
}
static Handle LoadModule(TaskData *taskData, Handle args)
{
TempString fileName(args->Word());
ModuleLoader loader(taskData, fileName);
processes->MakeRootRequest(taskData, &loader);
if (loader.errorResult != 0)
{
if (loader.errNumber == 0)
raise_fail(taskData, loader.errorResult);
else
{
AutoFree buff((char *)malloc(strlen(loader.errorResult) + 2 + _tcslen(loader.fileName) * sizeof(TCHAR) + 1));
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "%s: %S", loader.errorResult, loader.fileName);
#else
sprintf(buff, "%s: %s", loader.errorResult, loader.fileName);
#endif
raise_syscall(taskData, buff, loader.errNumber);
}
}
return loader.rootHandle;
}
// Load a module
POLYUNSIGNED PolyLoadModule(PolyObject *threadId, PolyWord arg)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedArg = taskData->saveVec.push(arg);
Handle result = 0;
try {
result = LoadModule(taskData, pushedArg);
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
PolyObject *InitHeaderFromExport(struct _exportDescription *exports)
{
// Check the structure sizes stored in the export structure match the versions
// used in this library.
if (exports->structLength != sizeof(exportDescription) ||
exports->memTableSize != sizeof(memoryTableEntry) ||
exports->rtsVersion < FIRST_supported_version ||
exports->rtsVersion > LAST_supported_version)
{
#if (FIRST_supported_version == LAST_supported_version)
Exit("The exported object file has version %0.2f but this library supports %0.2f",
((float)exports->rtsVersion) / 100.0,
((float)FIRST_supported_version) / 100.0);
#else
Exit("The exported object file has version %0.2f but this library supports %0.2f-%0.2f",
((float)exports->rtsVersion) / 100.0,
((float)FIRST_supported_version) / 100.0,
((float)LAST_supported_version) / 100.0);
#endif
}
// We could also check the RTS version and the architecture.
exportTimeStamp = exports->timeStamp; // Needed for load and save.
memoryTableEntry *memTable = exports->memTable;
#ifdef POLYML32IN64
// We need to copy this into the heap before beginning execution.
// This is very like loading a saved state and the code should probably
// be merged.
LoadRelocate relocate(true);
relocate.nDescrs = exports->memTableEntries;
relocate.descrs = new SavedStateSegmentDescr[relocate.nDescrs];
relocate.targetAddresses = new PolyWord*[exports->memTableEntries];
relocate.originalBaseAddr = (PolyWord*)exports->originalBaseAddr;
PolyObject *root = 0;
for (unsigned i = 0; i < exports->memTableEntries; i++)
{
relocate.descrs[i].segmentIndex = memTable[i].mtIndex;
relocate.descrs[i].originalAddress = memTable[i].mtOriginalAddr;
relocate.descrs[i].segmentSize = memTable[i].mtLength;
PermanentMemSpace *newSpace =
gMem.AllocateNewPermanentSpace(memTable[i].mtLength, (unsigned)memTable[i].mtFlags, (unsigned)memTable[i].mtIndex);
if (newSpace == 0)
Exit("Unable to initialise a permanent memory space");
PolyWord *mem = newSpace->bottom;
memcpy(mem, memTable[i].mtCurrentAddr, memTable[i].mtLength);
gMem.FillUnusedSpace(mem + memTable[i].mtLength / sizeof(PolyWord),
newSpace->spaceSize() - memTable[i].mtLength / sizeof(PolyWord));
if (newSpace == 0)
Exit("Unable to initialise a permanent memory space");
relocate.targetAddresses[i] = mem;
relocate.AddTreeRange(&relocate.spaceTree, i, (uintptr_t)relocate.descrs[i].originalAddress,
(uintptr_t)((char*)relocate.descrs[i].originalAddress + relocate.descrs[i].segmentSize - 1));
// Relocate the root function.
if (exports->rootFunction >= memTable[i].mtCurrentAddr && exports->rootFunction < (char*)memTable[i].mtCurrentAddr + memTable[i].mtLength)
{
root = (PolyObject*)((char*)mem + ((char*)exports->rootFunction - (char*)memTable[i].mtCurrentAddr));
}
}
// Now relocate the addresses
for (unsigned j = 0; j < exports->memTableEntries; j++)
{
SavedStateSegmentDescr *descr = &relocate.descrs[j];
MemSpace *space = gMem.SpaceForIndex(descr->segmentIndex);
// Any relative addresses have to be corrected by adding this.
relocate.relativeOffset = (PolyWord*)descr->originalAddress - space->bottom;
for (PolyWord *p = space->bottom; p < space->top; )
{
#ifdef POLYML32IN64
if ((((uintptr_t)p) & 4) == 0)
{
// Skip any padding. The length word should be on an odd-word boundary.
p++;
continue;
}
#endif
p++;
PolyObject *obj = (PolyObject*)p;
POLYUNSIGNED length = obj->Length();
relocate.RelocateObject(obj);
p += length;
}
}
// Set the final permissions.
for (unsigned j = 0; j < exports->memTableEntries; j++)
{
PermanentMemSpace *space = gMem.SpaceForIndex(memTable[j].mtIndex);
gMem.CompletePermanentSpaceAllocation(space);
}
return root;
#else
for (unsigned i = 0; i < exports->memTableEntries; i++)
{
// Construct a new space for each of the entries.
if (gMem.NewPermanentSpace(
(PolyWord*)memTable[i].mtCurrentAddr,
memTable[i].mtLength / sizeof(PolyWord), (unsigned)memTable[i].mtFlags,
(unsigned)memTable[i].mtIndex) == 0)
Exit("Unable to initialise a permanent memory space");
}
return (PolyObject *)exports->rootFunction;
#endif
}
// Return the system directory for modules. This is configured differently
// in Unix and in Windows.
POLYUNSIGNED PolyGetModuleDirectory(PolyObject *threadId)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
#if (defined(MODULEDIR))
result = SAVE(C_string_to_Poly(taskData, MODULEDIR));
-#elif (defined(_WIN32) && ! defined(__CYGWIN__))
+#elif (defined(_WIN32))
{
// 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)
{
// The registry entry should end with a backslash.
_tcscat(buff, MODULEDIR);
result = SAVE(C_string_to_Poly(taskData, buff));
}
}
RegCloseKey(hk);
}
result = SAVE(C_string_to_Poly(taskData, ""));
}
#else
result = SAVE(C_string_to_Poly(taskData, ""));
#endif
}
catch (...) {} // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
struct _entrypts savestateEPT[] =
{
{ "PolySaveState", (polyRTSFunction)&PolySaveState },
{ "PolyLoadState", (polyRTSFunction)&PolyLoadState },
{ "PolyShowHierarchy", (polyRTSFunction)&PolyShowHierarchy },
{ "PolyRenameParent", (polyRTSFunction)&PolyRenameParent },
{ "PolyShowParent", (polyRTSFunction)&PolyShowParent },
{ "PolyStoreModule", (polyRTSFunction)&PolyStoreModule },
{ "PolyLoadModule", (polyRTSFunction)&PolyLoadModule },
{ "PolyLoadHierarchy", (polyRTSFunction)&PolyLoadHierarchy },
{ "PolyGetModuleDirectory", (polyRTSFunction)&PolyGetModuleDirectory },
{ NULL, NULL } // End of list.
};
diff --git a/libpolyml/sighandler.cpp b/libpolyml/sighandler.cpp
index f9264223..cdd22262 100644
--- a/libpolyml/sighandler.cpp
+++ b/libpolyml/sighandler.cpp
@@ -1,586 +1,579 @@
/*
Title: Signal handling
Author: David C.J. Matthews
- Copyright (c) 2000-8, 2016 David C.J. Matthews
+ Copyright (c) 2000-8, 2016, 2019 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_SYS_TYPES_H
#include
#endif
#ifdef HAVE_SIGNAL_H
#include
#endif
#ifdef HAVE_ERRNO_H
#include
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x) 0
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_IO_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include // For malloc
#endif
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_SEMAPHORE_H))
+#if (defined(HAVE_SEMAPHORE_H) && !defined(_WIN32))
// Don't include semaphore.h on Mingw. It's provided but doesn't compile.
#include
#endif
-#if ((!defined(_WIN32) || defined(__CYGWIN__)) && defined(HAVE_LIBPTHREAD) && defined(HAVE_PTHREAD_H) && defined(HAVE_SEMAPHORE_H))
-// If we have the pthread library and header and we have semaphores we can use the pthread
-// signalling mechanism. But if this is a native Windows build we don't use semaphores or
-// pthread even if they're provided.
-#define USE_PTHREAD_SIGNALS 1
-#endif
-
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#define INVALIDSIGNAL ERROR_INVALID_PARAMETER
#else
#define INVALIDSIGNAL EINVAL
#endif
/*
Signal handling is complicated in a multi-threaded environment.
The pthread mutex and condition variables are not safe to use in a
signal handler so we need to use POSIX semaphores since sem_post is safe.
*/
#if (defined(HAVE_STACK_T) && defined(HAVE_SIGALTSTACK))
extern "C" {
// This is missing in older versions of Mac OS X
int sigaltstack(const stack_t *, stack_t *);
}
#endif
#include "globals.h"
#include "arb.h"
#include "run_time.h"
#include "sighandler.h"
#include "processes.h"
#include "machine_dep.h"
#include "sys.h"
#include "save_vec.h"
#include "rts_module.h"
#include "gc.h" // For convertedWeak
#include "scanaddrs.h"
#include "locking.h"
#include "rtsentry.h"
extern "C" {
POLYEXTERNALSYMBOL POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord action);
POLYEXTERNALSYMBOL POLYUNSIGNED PolyWaitForSignal(FirstArgument threadId);
}
#define SAVE(x) taskData->saveVec.push(x)
#define SIZEOF(x) (sizeof(x)/sizeof(word))
#define DEFAULT_SIG 0
#define IGNORE_SIG 1
#define HANDLE_SIG 2 // This is only used in SignalRequest
static struct _sigData
{
bool nonMaskable; // True if this sig is used within the RTS. Must not be ignored or replaced
PolyWord handler; // User-installed handler, TAGGED(DEFAULT_SIG) or TAGGED(IGNORE_SIG)
int signalCount;
} sigData[NSIG];
unsigned receivedSignalCount = 0; // Incremented each time we get a signal
// sigLock protects access to the signalCount values in sigData but
// not the "handler" field.
static PLock sigLock;
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
static PSemaphore *waitSema;
static int lastSignals[NSIG];
static bool terminate = false;
#endif
// This must not be called from an asynchronous signal handler.
static void signalArrived(int sig)
{
sigLock.Lock();
receivedSignalCount++;
sigData[sig].signalCount++;
sigLock.Unlock();
// To avoid deadlock we must release sigLock first.
processes->SignalArrived();
}
// Called whenever a signal handler is installed other than in this
// module. Because modules are initialised in an unspecified order
// we may have already masked off this signal.
void markSignalInuse(int sig)
{
sigData[sig].nonMaskable = true;
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
// Enable this signal.
sigset_t sigset;
sigemptyset(&sigset);
sigaddset(&sigset, sig);
pthread_sigmask(SIG_UNBLOCK, &sigset, NULL);
#endif
}
/* Find the existing handler for this signal. */
static PolyWord findHandler(int sig)
{
if ((unsigned)sig >= NSIG) // Check it's in range.
return TAGGED(DEFAULT_SIG); /* Not there - default action. */
else return sigData[sig].handler;
}
#if (defined(_WIN32) && ! defined(__CYGWIN__))
// This is called to simulate a SIGINT in Windows.
void RequestConsoleInterrupt(void)
{
// The default action for SIGINT is to exit.
if (findHandler(SIGINT) == TAGGED(DEFAULT_SIG))
processes->RequestProcessExit(2); // Exit with the signal value.
else signalArrived(SIGINT);
}
#endif
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
// Request the main thread to change the blocking state of a signal.
class SignalRequest: public MainThreadRequest
{
public:
SignalRequest(int s, int r): MainThreadRequest(MTP_SIGHANDLER), signl(s), state(r) {}
virtual void Perform();
int signl, state;
};
// Called whenever a signal is received.
static void handle_signal(SIG_HANDLER_ARGS(s, c))
{
if (waitSema != 0)
{
lastSignals[s]++; // Assume this is atomic with respect to reading.
// Wake the signal detection thread.
waitSema->Signal();
}
}
void SignalRequest::Perform()
{
struct sigaction action;
memset(&action, 0, sizeof(action));
switch (state)
{
case DEFAULT_SIG:
action.sa_handler = SIG_DFL;
sigaction(signl, &action, 0);
break;
case IGNORE_SIG:
action.sa_handler = SIG_IGN;
sigaction(signl, &action, 0);
break;
case HANDLE_SIG:
setSignalHandler(signl, handle_signal);
break;
}
}
#endif
static Handle waitForSignal(TaskData *taskData)
{
while (true)
{
processes->ProcessAsynchRequests(taskData); // Check for kill.
sigLock.Lock();
// Any pending signals?
for (int sig = 0; sig < NSIG; sig++)
{
if (sigData[sig].signalCount > 0)
{
sigData[sig].signalCount--;
if (!IS_INT(findHandler(sig))) /* If it's not DEFAULT or IGNORE. */
{
// Create a pair of the handler and signal and pass
// them back to be run.
Handle pair = alloc_and_save(taskData, 2);
// Have to call findHandler again here because that
// allocation could have garbage collected.
DEREFHANDLE(pair)->Set(0, findHandler(sig));
DEREFHANDLE(pair)->Set(1, TAGGED(sig));
sigLock.Unlock();
return pair;
}
}
}
if (convertedWeak)
{
// Last GC converted a weak SOME into NONE. This isn't
// anything to do with signals but the signal thread can
// deal with this.
sigLock.Unlock();
convertedWeak = false;
return SAVE(TAGGED(0));
}
// No pending signal. Wait until we're woken up.
// This releases sigLock after acquiring schedLock.
if (! processes->WaitForSignal(taskData, &sigLock))
raise_exception_string(taskData, EXC_Fail, "Only one thread may wait for signals");
}
}
POLYUNSIGNED PolySetSignalHandler(FirstArgument threadId, PolyWord signalNo, PolyWord action)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle pushedAction = taskData->saveVec.push(action);
Handle oldaction = 0;
try {
{
int sign;
int action;
{
// Lock while we look at the signal vector but release
// it before making a root request.
PLocker locker(&sigLock);
// We have to pass this to the main thread to
// set up the signal handler.
sign = get_C_int(taskData, signalNo);
/* Decode the action if it is Ignore or Default. */
if (pushedAction->Word().IsTagged())
action = (int)pushedAction->Word().UnTagged();
else action = HANDLE_SIG; /* Set the handler. */
if (sign <= 0 || sign >= NSIG)
raise_syscall(taskData, "Invalid signal value", INVALIDSIGNAL);
/* Get the old action before updating the vector. */
oldaction = SAVE(findHandler(sign));
// Now update it.
sigData[sign].handler = pushedAction->Word();
}
// Request a change in the masking by the root thread.
// This doesn't do anything in Windows so the only "signal"
// we affect is SIGINT and that is handled by RequestConsoleInterrupt.
if (! sigData[sign].nonMaskable)
{
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
SignalRequest request(sign, action);
processes->MakeRootRequest(taskData, &request);
#endif
}
}
} catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (oldaction == 0) return TAGGED(0).AsUnsigned();
else return oldaction->Word().AsUnsigned();
}
// Called by the signal handler thread. Blocks until a signal is available.
POLYUNSIGNED PolyWaitForSignal(FirstArgument threadId)
{
TaskData *taskData = TaskData::FindTaskForId(threadId);
ASSERT(taskData != 0);
taskData->PreRTSCall();
Handle reset = taskData->saveVec.mark();
Handle result = 0;
try {
result = waitForSignal(taskData);
}
catch (KillException &) {
processes->ThreadExit(taskData); // May test for kill
}
catch (...) { } // If an ML exception is raised
taskData->saveVec.reset(reset);
taskData->PostRTSCall();
if (result == 0) return TAGGED(0).AsUnsigned();
else return result->Word().AsUnsigned();
}
// Set up per-thread signal data: basically signal stack.
// This is really only needed for profiling timer signals.
void initThreadSignals(TaskData *taskData)
{
#if (!(defined(_WIN32)||defined(MACOSX)))
// On the i386, at least, we need to set up a signal stack for
// each thread if it might receive a signal. ML code checks for
// stack overflow but a signal could result in C code being
// executed on the ML stack. The signal stack avoids this.
// On some architectures the C stack pointer is left unused
// when executing ML code so this isn't a problem.
// In Linux each thread can receive a SIGVTALRM signal when
// profiling.
// This is currently disabled in Mac OS X. In 10.4 and before
// setting a signal stack in a thread seemed to set it for the
// whole process and crash with an illegal instruction on the
// second signal. This isn't currently a problem since only the
// main thread receives signals in Mac OS X.
#if (defined(SA_ONSTACK) && defined(HAVE_SIGALTSTACK))
taskData->signalStack = malloc(SIGSTKSZ);
#ifdef HAVE_STACK_T
stack_t ex_stack;
#else
// This used to be used in FreeBSD and Mac OS X
struct sigaltstack ex_stack;
#endif
memset(&ex_stack, 0, sizeof(ex_stack));
// Cast to char* because ss_sp is char* in FreeBSD.
// Linux simply casts it back to void*.
ex_stack.ss_sp = (char*)taskData->signalStack;
ex_stack.ss_size = SIGSTKSZ;
ex_stack.ss_flags = 0; /* not SS_DISABLE */
int sigaltstack_result = sigaltstack(&ex_stack, NULL);
ASSERT(sigaltstack_result == 0);
#endif
#endif /* not the PC */
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
// Block all signals except those marked as in use by the RTS so
// that they will only be picked up by the signal detection thread.
// Since the signal mask is inherited we really don't need to do
// this for every thread, just the initial one.
sigset_t sigset;
sigfillset(&sigset);
for (int i = 0; i < NSIG; i++)
{
if (sigData[i].nonMaskable)
sigdelset(&sigset, i);
}
pthread_sigmask(SIG_SETMASK, &sigset, NULL);
#endif
}
/* General purpose function to set up a signal handler. */
-#if (!defined(_WIN32) || defined(__CYGWIN__))
+#if (!defined(_WIN32))
bool setSignalHandler(int sig, signal_handler_type func)
{
struct sigaction sigcatch;
memset(&sigcatch, 0, sizeof(sigcatch));
sigcatch.sa_sigaction = func;
/*
Both Linux and FreeBSD now use SA_SIGINFO in a similar way. If SA_SIGINFO is set the
handler is supposed to be in sa_sigaction rather than sa_handler (actually this is a union
so they're in the same place).
*/
init_asyncmask(&sigcatch.sa_mask);
sigcatch.sa_flags = 0;
#if defined(SA_ONSTACK) && defined(HAVE_SIGALTSTACK)
sigcatch.sa_flags |= SA_ONSTACK;
#endif
#ifdef SA_RESTART
sigcatch.sa_flags |= SA_RESTART;
#endif
#ifdef SA_SIGINFO
sigcatch.sa_flags |= SA_SIGINFO;
#endif
#ifdef SV_SAVE_REGS
sigcatch.sa_flags |= SV_SAVE_REGS;
#endif
return sigaction(sig, &sigcatch,NULL) >= 0;
}
// Signals to mask off when handling a signal. The signal being handled
// is always masked off. This really only applied when emulation traps
// and requests to GC involved signals. That no longer applies except
// on the Sparc.
void init_asyncmask(sigset_t *mask)
{
/* disable asynchronous interrupts while servicing interrupt */
sigemptyset(mask);
sigaddset(mask,SIGVTALRM);
sigaddset(mask,SIGINT);
sigaddset(mask,SIGUSR2);
sigaddset(mask,SIGWINCH);
// This next used to be needed when emulation traps resulted in
// signals. This no longer applies except on the Sparc.
#ifdef SPARC
sigaddset(mask,SIGILL);
sigaddset(mask,SIGFPE);
/* Mask off SIGSEGV. This is definitely needed when we are
installing a handler for SIGINT under Linux and may also
be needed in other cases as well e.g. SIGVTALRM. Without
it typing control-C to a program which is taking lots
of emulation traps can cause a crash because the signals
are delivered in the "wrong" order and the pc value given
to catchSEGV can point at the handler for SIGINT.
DCJM 7/2/01. */
sigaddset(mask,SIGSEGV);
/* And, just to be sure, include SIGBUS. DCJM 22/5/02. */
sigaddset(mask,SIGBUS);
#endif
}
#endif
struct _entrypts sigHandlerEPT[] =
{
{ "PolySetSignalHandler", (polyRTSFunction)&PolySetSignalHandler},
{ "PolyWaitForSignal", (polyRTSFunction)&PolyWaitForSignal},
{ NULL, NULL} // End of list.
};
class SigHandler: public RtsModule
{
public:
virtual void Init(void);
virtual void Stop(void);
virtual void GarbageCollect(ScanAddress * /*process*/);
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
SigHandler() { threadRunning = false; }
pthread_t detectionThreadId;
bool threadRunning;
#endif
};
// Declare this. It will be automatically added to the table.
static SigHandler sighandlerModule;
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
// This thread is really only to convert between POSIX semaphores and
// pthread condition variables. It waits for a semphore to be released by the
// signal handler running on the main thread and then wakes up the ML handler
// thread. The ML thread must not wait directly on a POSIX semaphore because it
// may also be woken by other events, particularly a kill request when the program
// exits.
static void *SignalDetectionThread(void *)
{
// Block all signals so they will be delivered to the main thread.
sigset_t active_signals;
sigfillset(&active_signals);
pthread_sigmask(SIG_SETMASK, &active_signals, NULL);
int readSignals[NSIG] = {0};
while (true)
{
if (waitSema == 0)
return 0;
// Wait until we are woken up by an arriving signal.
// waitSema will be incremented for each signal so we should
// not block until we have processed them all.
if (! waitSema->Wait() || terminate) return 0;
for (int j = 1; j < NSIG; j++)
{
if (readSignals[j] < lastSignals[j])
{
readSignals[j]++;
signalArrived(j);
}
}
}
}
#endif
void SigHandler::Init(void)
{
// Mark certain signals as non-maskable since they really
// indicate a fatal error.
#ifdef SIGSEGV
sigData[SIGSEGV].nonMaskable = true;
#endif
#ifdef SIGBUS
sigData[SIGBUS].nonMaskable = true;
#endif
#ifdef SIGILL
sigData[SIGILL].nonMaskable = true;
#endif
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
static PSemaphore waitSemaphore;
// Initialise the "wait" semaphore so that it blocks immediately.
if (! waitSemaphore.Init(0, NSIG)) return;
waitSema = &waitSemaphore;
// Create a new thread to handle signals synchronously.
// for it to finish.
pthread_attr_t attrs;
pthread_attr_init(&attrs);
#ifdef PTHREAD_STACK_MIN
#if (PTHREAD_STACK_MIN < 4096)
pthread_attr_setstacksize(&attrs, 4096); // But not too small: FreeBSD makes it 2k
#else
pthread_attr_setstacksize(&attrs, PTHREAD_STACK_MIN); // Only small stack.
#endif
#endif
threadRunning = pthread_create(&detectionThreadId, &attrs, SignalDetectionThread, 0) == 0;
pthread_attr_destroy(&attrs);
#endif
}
// Wait for the signal thread to finish before the semaphore is deleted in the
// final clean-up. Failing to do this causes a hang in Mac OS X.
void SigHandler::Stop(void)
{
-#ifdef USE_PTHREAD_SIGNALS
+#if (!defined(_WIN32))
terminate = true;
waitSema->Signal();
pthread_join(detectionThreadId, NULL);
#endif
}
void SigHandler::GarbageCollect(ScanAddress *process)
{
for (unsigned i = 0; i < NSIG; i++)
{
if (sigData[i].handler != PolyWord::FromUnsigned(0))
process->ScanRuntimeWord(&sigData[i].handler);
}
}
diff --git a/libpolyml/sighandler.h b/libpolyml/sighandler.h
index c5a611c1..933d9767 100644
--- a/libpolyml/sighandler.h
+++ b/libpolyml/sighandler.h
@@ -1,52 +1,52 @@
/*
Title: sighandler.h
- Copyright (c) 2000-7, 2016 David C.J. Matthews
+ Copyright (c) 2000-7, 2016, 2019 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifndef _SIGHANDLER_H
#define _SIGHANDLER_H 1
class TaskData;
extern void markSignalInuse(int sig);
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
extern void RequestConsoleInterrupt(void);
#else
#ifdef HAVE_SIGNAL_H
#include
#endif
extern void init_asyncmask(sigset_t *mask);
#define SIG_HANDLER_ARGS(_sig,_contxt) int _sig, siginfo_t *, void *_contxt
typedef void (*signal_handler_type)(SIG_HANDLER_ARGS(s, c));
extern bool setSignalHandler(int sig, signal_handler_type func);
// Set up per-thread signal data: basically signal stack.
extern void initThreadSignals(TaskData *taskData);
#endif /* ! _WIN32 */
extern unsigned receivedSignalCount; // Incremented each time we get a signal
extern struct _entrypts sigHandlerEPT[];
#endif
diff --git a/libpolyml/statistics.cpp b/libpolyml/statistics.cpp
index 3db86e12..50f8cff6 100644
--- a/libpolyml/statistics.cpp
+++ b/libpolyml/statistics.cpp
@@ -1,835 +1,838 @@
/*
Title: statics.cpp - Profiling statistics
Copyright (c) 2011, 2013, 2015, 2019 David C.J. Matthews
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library 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
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#elif defined(_WIN32)
#include "winconfig.h"
#else
#error "No configuration file"
#endif
#ifdef HAVE_WINDOWS_H
#include
#endif
#ifdef HAVE_STDIO_H
#include
#endif
#ifdef HAVE_SYS_TYPES_H
#include
#endif
#ifdef HAVE_SYS_MMAN_H
#include
#endif
#ifdef HAVE_SYS_STAT_H
#include
#endif
#ifdef HAVE_FCNTL_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_UNISTD_H
#include
#endif
#ifdef HAVE_SYS_PARAM_H
#include
#endif
#ifdef HAVE_STRING_H
#include
#endif
#ifdef HAVE_TIME_H
#include
#endif
#ifdef HAVE_SYS_TIMES_H
#include
#endif
#ifdef HAVE_SYS_TIME_H
#include
#endif
#ifdef HAVE_SYS_RESOURCE_H
#include
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#if defined(HAVE_MMAP)
// How do we get the page size?
#ifndef HAVE_GETPAGESIZE
#ifdef _SC_PAGESIZE
#define getpagesize() sysconf(_SC_PAGESIZE)
#else
// If this fails we're stuck
#define getpagesize() PAGESIZE
#endif
#endif
#endif
#ifdef HAVE_ASSERT_H
#include
#define ASSERT(x) assert(x)
#else
#define ASSERT(x)
#endif
-#if (defined(_WIN32) && ! defined(__CYGWIN__))
+#if (defined(_WIN32))
#include