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 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 IntDebug Win32 IntDebug x64 IntRelease Win32 IntRelease x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {1BA3E7A2-D64F-4CE3-9FE5-7846B855C19F} PolyImport - 10.0.15063.0 + 10.0 Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 Disabled true MultiThreadedDebug true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false Level3 MaxSpeed true true true MultiThreaded true true true true Windows 6.0 false {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 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 IntDebug Win32 IntDebug x64 IntRelease Win32 IntRelease x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {0326c47a-00af-42cb-b87d-0369a241b570} {0ba5d5b5-f85b-4c49-8a27-67186fa68922} {1ba3e7a2-d64f-4ce3-9fe5-7846b855c19f} true true true true true true true true copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt true true true true true true false false true true false false true true true true true true true true copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt true true true true true true true true true true false true true true false true copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml cd .. $(OutDir)PolyImport.exe -H 32 "%(FullPath)" -o PolyML\$(IntDir)polyexport.obj < exportPoly.sml $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj $(IntDir)polyexport.obj copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt true true true true true true true true false true true true false true true true copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt ..\polytemp.txt true true true true true true true true true true false true true true true false copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt copy "%(FullPath)" ..\polytemp.txt ..\polytemp.txt {DF3B373E-67DF-4AB4-8B1E-F54C5810E2CF} Win32Proj PolyML - 10.0.15063.0 + 10.0 Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode true true true true true true true true false false false false false false false false NotUsing Level3 Disabled WIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false NotUsing Level3 Disabled WIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false NotUsing Level3 Disabled WIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false NotUsing Level3 Disabled WIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false NotUsing Level3 Disabled _DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false NotUsing Level3 Disabled _DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false NotUsing Level3 Disabled _DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false NotUsing Level3 Disabled _DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true libcmtd.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) true 6.0 false Level3 NotUsing MaxSpeed true true WIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false Level3 NotUsing MaxSpeed true true WIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false Level3 NotUsing MaxSpeed true true WIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false Level3 NotUsing MaxSpeed true true WIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false Level3 NotUsing MaxSpeed true true NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false Level3 NotUsing MaxSpeed true true NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false Level3 NotUsing MaxSpeed true true NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false Level3 NotUsing MaxSpeed true true NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true libcmt.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) true 6.0 false \ 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 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {D9F58E8D-5FCD-4401-8D88-0C28732BD77B} PolyPerf - 10.0.15063.0 + 10.0 DynamicLibrary true - v141 + v142 MultiByte DynamicLibrary true - v141 + v142 MultiByte DynamicLibrary true - v141 + v142 MultiByte DynamicLibrary false - v141 + v142 true MultiByte DynamicLibrary false - v141 + v142 true MultiByte DynamicLibrary false - v141 + v142 true MultiByte DynamicLibrary true - v141 + v142 MultiByte DynamicLibrary true - v141 + v142 MultiByte DynamicLibrary true - v141 + v142 MultiByte DynamicLibrary false - v141 + v142 true MultiByte DynamicLibrary false - v141 + v142 true MultiByte DynamicLibrary false - v141 + v142 true MultiByte Level3 Disabled true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true psapi.lib;%(AdditionalDependencies) Windows Level3 Disabled true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true psapi.lib;%(AdditionalDependencies) Windows Level3 Disabled true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true psapi.lib;%(AdditionalDependencies) Windows Level3 Disabled true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true psapi.lib;%(AdditionalDependencies) Windows Level3 Disabled true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true psapi.lib;%(AdditionalDependencies) Windows Level3 Disabled true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true psapi.lib;%(AdditionalDependencies) Windows Level3 MaxSpeed true true true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true true true psapi.lib;%(AdditionalDependencies) Windows Level3 MaxSpeed true true true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true true true psapi.lib;%(AdditionalDependencies) Windows Level3 MaxSpeed true true true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true true true psapi.lib;%(AdditionalDependencies) Windows Level3 MaxSpeed true true true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true true true psapi.lib;%(AdditionalDependencies) Windows Level3 MaxSpeed true true true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true true true psapi.lib;%(AdditionalDependencies) Windows Level3 MaxSpeed true true true _CRT_SECURE_NO_WARNINGS;POLYPERF_EXPORTS;%(PreprocessorDefinitions) true true true psapi.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 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 IntDebug Win32 IntDebug x64 IntRelease Win32 IntRelease x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {0326C47A-00AF-42CB-B87D-0369A241B570} PolyMainLib + 10.0 StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 Disabled true ..;%(AdditionalIncludeDirectories) MultiThreadedDebug true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true Level3 MaxSpeed true true true ..;%(AdditionalIncludeDirectories) MultiThreaded true true true \ 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 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 IntDebug Win32 IntDebug x64 IntRelease Win32 IntRelease x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {0BA5D5B5-F85B-4C49-8A27-67186FA68922} PolyLib - 10.0.15063.0 + 10.0 DynamicLibrary true - v141 + v142 Unicode DynamicLibrary true - v141 + v142 Unicode DynamicLibrary true - v141 + v142 Unicode DynamicLibrary true - v141 + v142 Unicode DynamicLibrary false - v141 + v142 true Unicode DynamicLibrary false - v141 + v142 true Unicode DynamicLibrary false - v141 + v142 true Unicode DynamicLibrary false - v141 + v142 true Unicode DynamicLibrary true - v141 + v142 Unicode DynamicLibrary true - v141 + v142 Unicode DynamicLibrary true - v141 + v142 Unicode DynamicLibrary true - v141 + v142 Unicode DynamicLibrary false - v141 + v142 true Unicode DynamicLibrary false - v141 + v142 true Unicode DynamicLibrary false - v141 + v142 true Unicode DynamicLibrary false - v141 + v142 true Unicode .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll .dll Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 Disabled true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreadedDebug true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) _CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false Level3 MaxSpeed true true true ..;libffi\include;libffi\msvc32include;libffi\src\x86;%(AdditionalIncludeDirectories) POLYML32IN64;_CRT_SECURE_NO_WARNINGS;POLYLIB_EXPORTS;HOSTARCHITECTURE_X86_64;LONG_LONG_MAX=_I64_MAX;%(PreprocessorDefinitions) MultiThreaded true true true ws2_32.lib;%(AdditionalDependencies) Windows 6.0 false true true true true true true true true true true true true true true true true true true false false true true false false true true false false true true false false true true true true true true true true true true true true true true true true true true true true true true true true true true true true false false true true false false true true true true true true Document cl /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).obj cl /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).obj cl /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).obj cl /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).obj cl /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).obj cl /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).obj cl /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).obj cl /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).obj true true true true true true true true true true true true Document cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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 cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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 cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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 cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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 cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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 cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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).obj cl /nologo /EP /I. /D_MSC_VER "%(FullPath)" > $(IntDir)%(Filename).asm ml64 /nologo /Fo $(IntDir)%(Filename).obj /c $(IntDir)%(Filename).asm cl /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 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 IntDebug Win32 IntDebug x64 IntRelease Win32 IntRelease x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {6D86BC6F-E74E-40C5-9881-F8BB606BCA78} Win32Proj libffi - 10.0.15063.0 + 10.0 StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary true - v141 + v142 Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode StaticLibrary false - v141 + v142 true Unicode true true true true true true true true false false false false false false false false Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 Disabled _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreadedDebug Windows true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true Level3 MaxSpeed true true _LIB;LONG_LONG_MAX=_I64_MAX msvc32include;src\x86;include MultiThreaded Windows true true true true true true true true true true true Document cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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 cl /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) true true true true true true true true Document 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) 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 #else #define _T(x) x #endif #include #ifdef max #undef max #endif #include "run_time.h" #include "sys.h" #include "save_vec.h" #include "rts_module.h" #include "timing.h" #include "polystring.h" #include "processes.h" #include "statistics.h" #include "../polystatistics.h" #include "rtsentry.h" #include "arb.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetUserStatsCount(); POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(PolyObject *threadId, PolyWord index, PolyWord value); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(PolyObject *threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(PolyObject *threadId, PolyWord procId); // POLYEXTERNALSYMBOL POLYUNSIGNED PolySpecificGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); } #define STATS_SPACE 4096 // Enough for all the statistics #define ASN1_U_BOOL 1 #define ASN1_U_INT 2 #define ASN1_U_STRING 4 #define ASN1_U_NULL 5 #define ASN1_U_ENUM 10 #define ASN1_U_SEQUENCE 16 // For the moment we don't bother to interlock access to the statistics memory. // Other processes only read the memory and at worst they may get a glitch in // the values. Statistics::Statistics(): accessLock("Statistics") { statMemory = 0; memSize = 0; newPtr = 0; for (unsigned i = 0; i < N_PS_INTS; i++) counterAddrs[i] = 0; for (unsigned j = 0; j < N_PS_TIMES; j++) timeAddrs[j].secAddr = timeAddrs[j].usecAddr = 0; for (unsigned k = 0; k < N_PS_USER; k++) userAddrs[k] = 0; memset(&gcUserTime, 0, sizeof(gcUserTime)); memset(&gcSystemTime, 0, sizeof(gcSystemTime)); memset(&gcRealTime, 0, sizeof(gcRealTime)); #ifdef HAVE_WINDOWS_H // File mapping handle hFileMap = NULL; exportStats = true; // Actually unused #else mapFd = -1; mapFileName = 0; exportStats = false; // Don't export by default #endif memSize = 0; statMemory = 0; newPtr = 0; } void Statistics::Init() { +#if (defined(_WIN32)) + // Record an initial time of day to use as the basis of real timing + GetSystemTimeAsFileTime(&startTime); +#else + gettimeofday(&startTime, NULL); +#endif #ifdef HAVE_WINDOWS_H // Get the process ID to use in the shared memory name DWORD pid = ::GetCurrentProcessId(); TCHAR shmName[MAX_PATH]; wsprintf(shmName, _T(POLY_STATS_NAME) _T("%lu"), pid); // Create a piece of shared memory hFileMap = CreateFileMapping(INVALID_HANDLE_VALUE, NULL, PAGE_READWRITE, 0, STATS_SPACE, shmName); if (hFileMap == NULL) return; // If it already exists it's the wrong one. if (GetLastError() == ERROR_ALREADY_EXISTS) { CloseHandle(hFileMap); hFileMap = NULL; return; } statMemory = (unsigned char*)MapViewOfFile(hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, STATS_SPACE); if (statMemory == NULL) { CloseHandle(hFileMap); hFileMap = NULL; return; } memSize = STATS_SPACE; - // Record an initial time of day to use as the basis of real timing - GetSystemTimeAsFileTime(&startTime); #else - gettimeofday(&startTime, NULL); #if HAVE_MMAP if (exportStats) { // Create the shared memory in the user's .polyml directory int pageSize = getpagesize(); memSize = (STATS_SPACE + pageSize-1) & ~(pageSize-1); char *homeDir = getenv("HOME"); if (homeDir == NULL) return; mapFileName = (char*)malloc(strlen(homeDir) + 100); strcpy(mapFileName, homeDir); strcat(mapFileName, "/.polyml"); mkdir(mapFileName, 0777); // Make the directory to ensure it exists sprintf(mapFileName + strlen(mapFileName), "/" POLY_STATS_NAME "%d", getpid()); // Open the file. Truncates it if it already exists. That should only happen // if a previous run with the same process id crashed. mapFd = open(mapFileName, O_RDWR|O_CREAT, 0444); if (mapFd == -1) return; // Write enough of the file to fill the space. char ch = 0; for (size_t i = 0; i < memSize; i++) write(mapFd, &ch, 1); statMemory = (unsigned char*)mmap(0, memSize, PROT_READ|PROT_WRITE, MAP_SHARED, mapFd, 0); if (statMemory == MAP_FAILED) { statMemory = 0; return; } } else #endif { // If we just want the statistics locally. statMemory = (unsigned char*)calloc(STATS_SPACE, sizeof(unsigned char)); if (statMemory == 0) return; } #endif // Set up the ASN1 structure in the statistics area. newPtr = statMemory; *newPtr++ = POLY_STATS_C_STATISTICS; // Context tag for statistics *newPtr++ = 0x82; // Extended length, 2 bytes *newPtr++ = 0x00; // Length is initially zero *newPtr++ = 0x00; addCounter(PSC_THREADS, POLY_STATS_ID_THREADS, "ThreadCount"); addCounter(PSC_THREADS_IN_ML, POLY_STATS_ID_THREADS_IN_ML, "ThreadsInML"); addCounter(PSC_THREADS_WAIT_IO, POLY_STATS_ID_THREADS_WAIT_IO, "ThreadsInIOWait"); addCounter(PSC_THREADS_WAIT_MUTEX, POLY_STATS_ID_THREADS_WAIT_MUTEX, "ThreadsInMutexWait"); addCounter(PSC_THREADS_WAIT_CONDVAR, POLY_STATS_ID_THREADS_WAIT_CONDVAR, "ThreadsInCondVarWait"); addCounter(PSC_THREADS_WAIT_SIGNAL, POLY_STATS_ID_THREADS_WAIT_SIGNAL, "ThreadsInSignalWait"); addCounter(PSC_GC_FULLGC, POLY_STATS_ID_GC_FULLGC, "FullGCCount"); addCounter(PSC_GC_PARTIALGC, POLY_STATS_ID_GC_PARTIALGC, "PartialGCCount"); addCounter(PSC_GC_SHARING, POLY_STATS_ID_GC_SHARING, "GCSharingCount"); addSize(PSS_TOTAL_HEAP, POLY_STATS_ID_TOTAL_HEAP, "TotalHeap"); addSize(PSS_AFTER_LAST_GC, POLY_STATS_ID_AFTER_LAST_GC, "HeapAfterLastGC"); addSize(PSS_AFTER_LAST_FULLGC, POLY_STATS_ID_AFTER_LAST_FULLGC, "HeapAfterLastFullGC"); addSize(PSS_ALLOCATION, POLY_STATS_ID_ALLOCATION, "AllocationSpace"); addSize(PSS_ALLOCATION_FREE, POLY_STATS_ID_ALLOCATION_FREE, "AllocationSpaceFree"); addSize(PSS_CODE_SPACE, POLY_STATS_ID_CODE_SPACE, "CodeSpace"); addSize(PSS_STACK_SPACE, POLY_STATS_ID_STACK_SPACE, "StackSpace"); addTime(PST_NONGC_UTIME, POLY_STATS_ID_NONGC_UTIME, "NonGCUserTime"); addTime(PST_NONGC_STIME, POLY_STATS_ID_NONGC_STIME, "NonGCSystemTime"); addTime(PST_GC_UTIME, POLY_STATS_ID_GC_UTIME, "GCUserTime"); addTime(PST_GC_STIME, POLY_STATS_ID_GC_STIME, "GCSystemTime"); addTime(PST_NONGC_RTIME, POLY_STATS_ID_NONGC_RTIME, "NonGCRealTime"); addTime(PST_GC_RTIME, POLY_STATS_ID_GC_RTIME, "GCRealTime"); addUser(0, POLY_STATS_ID_USER0, "UserCounter0"); addUser(1, POLY_STATS_ID_USER1, "UserCounter1"); addUser(2, POLY_STATS_ID_USER2, "UserCounter2"); addUser(3, POLY_STATS_ID_USER3, "UserCounter3"); addUser(4, POLY_STATS_ID_USER4, "UserCounter4"); addUser(5, POLY_STATS_ID_USER5, "UserCounter5"); addUser(6, POLY_STATS_ID_USER6, "UserCounter6"); addUser(7, POLY_STATS_ID_USER7, "UserCounter7"); } void Statistics::addCounter(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_COUNTERSTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the counter itself. // This, along with the other counters, is technically incorrect // for an ASN1 integer because it should not contain more than // one zero byte. *newPtr++ = POLY_STATS_C_COUNTER_VALUE; *newPtr++ = sizeof(POLYUNSIGNED); counterAddrs[cEnum] = newPtr; // This is the address for (unsigned j = 0; j < sizeof(POLYUNSIGNED); j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addSize(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_SIZESTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the size value itself. We have to allow one // byte extra to ensure that the value we encode is unsigned. unsigned bytes = sizeof(size_t) + 1; *newPtr++ = POLY_STATS_C_BYTE_COUNT; *newPtr++ = bytes; counterAddrs[cEnum] = newPtr; // This is the address for (unsigned j = 0; j < bytes; j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addTime(int cEnum, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_TIMESTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the time. Two four byte values. *newPtr++ = POLY_STATS_C_TIME; *newPtr++ = 12; *newPtr++ = POLY_STATS_C_SECONDS; *newPtr++ = 4; timeAddrs[cEnum].secAddr = newPtr; // This is the address for (unsigned j = 0; j < 4; j++) *newPtr++ = 0; *newPtr++ = POLY_STATS_C_MICROSECS; *newPtr++ = 4; timeAddrs[cEnum].usecAddr = newPtr; // This is the address for (unsigned k = 0; k < 4; k++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } void Statistics::addUser(int n, unsigned statId, const char *name) { // Tag header *newPtr++ = POLY_STATS_C_USERSTAT; *newPtr++ = 0x00; // Initial length - overwritten at the end unsigned char *tagStart = newPtr; // First item - Id of this statistic - Implicit int *newPtr++ = POLY_STATS_C_IDENTIFIER; *newPtr++ = 0x01; ASSERT(statId < 128); *newPtr++ = statId; // Second item - The name size_t nameLength = strlen(name); ASSERT(nameLength < 125); *newPtr++ = POLY_STATS_C_NAME; *newPtr++ = (unsigned char)nameLength; for (unsigned i = 0; i < nameLength; i++) *newPtr++ = name[i]; // Third item - the counter itself. For a user counter the value is a POLYSIGNED. *newPtr++ = POLY_STATS_C_COUNTER_VALUE; *newPtr++ = sizeof(POLYSIGNED); userAddrs[n] = newPtr; // This is the address for (unsigned j = 0; j < sizeof(POLYSIGNED); j++) *newPtr++ = 0; // Finally set the tag length and the overall size. size_t length = newPtr - tagStart; ASSERT(length < 128); tagStart[-1] = (unsigned char)length; // Set the overall size. length = newPtr-statMemory - 4; statMemory[2] = (length >> 8) & 0xff; statMemory[3] = length & 0xff; } Statistics::~Statistics() { #ifdef HAVE_WINDOWS_H if (statMemory != NULL) ::UnmapViewOfFile(statMemory); if (hFileMap != NULL) ::CloseHandle(hFileMap); #else #if HAVE_MMAP if (mapFileName != 0) { if (statMemory != 0 && statMemory != MAP_FAILED) munmap(statMemory, memSize); if (mapFd != -1) close(mapFd); if (mapFileName != 0) unlink(mapFileName); free(mapFileName); } else #endif { free(statMemory); } #endif } // Counters. These are used for thread state so need interlocks void Statistics::incCount(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); unsigned length = counterAddrs[which][-1]; while (length--) { if ((++counterAddrs[which][length]) != 0) break; } } } void Statistics::decCount(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); unsigned length = counterAddrs[which][-1]; while (length--) { if ((counterAddrs[which][length]--) != 0) break; } } } // Sizes. Some of these are only set during GC so may not need interlocks size_t Statistics::getSizeWithLock(int which) { unsigned length = counterAddrs[which][-1]; size_t result = 0; for (unsigned i = 0; i < length; i++) result = (result << 8) | counterAddrs[which][i]; return result; } void Statistics::setSizeWithLock(int which, size_t s) { unsigned length = counterAddrs[which][-1]; while (length--) { counterAddrs[which][length] = (unsigned char)(s & 0xff); s = s >> 8; } } void Statistics::setSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, s); } } void Statistics::incSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, getSizeWithLock(which) + s); } } void Statistics::decSize(int which, size_t s) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); setSizeWithLock(which, getSizeWithLock(which) - s); } } size_t Statistics::getSize(int which) { if (statMemory && counterAddrs[which]) { PLocker lock(&accessLock); return getSizeWithLock(which); } else return 0; } void Statistics::setTimeValue(int which, unsigned long secs, unsigned long usecs) { if (statMemory && timeAddrs[which].secAddr && timeAddrs[which].usecAddr) { PLocker lock(&accessLock); // Necessary ??? unsigned sLength = timeAddrs[which].secAddr[-1]; while (sLength--) { timeAddrs[which].secAddr[sLength] = (unsigned char)(secs & 0xff); secs = secs >> 8; } unsigned usLength = timeAddrs[which].usecAddr[-1]; while (usLength--) { timeAddrs[which].usecAddr[usLength] = (unsigned char)(usecs & 0xff); usecs = usecs >> 8; } } } -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) // Native Windows void Statistics::copyGCTimes(const FILETIME &gcUtime, const FILETIME &gcStime, const FILETIME &gcRtime) { gcUserTime = gcUtime; gcSystemTime = gcStime; ULARGE_INTEGER li; li.LowPart = gcUtime.dwLowDateTime; li.HighPart = gcUtime.dwHighDateTime; setTimeValue(PST_GC_UTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = gcStime.dwLowDateTime; li.HighPart = gcStime.dwHighDateTime; setTimeValue(PST_GC_STIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = gcRtime.dwLowDateTime; li.HighPart = gcRtime.dwHighDateTime; setTimeValue(PST_GC_RTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); } #else // Unix void Statistics::copyGCTimes(const struct timeval &gcUtime, const struct timeval &gcStime, const struct timeval &gcRtime) { gcUserTime = gcUtime; gcSystemTime = gcStime; setTimeValue(PST_GC_UTIME, gcUtime.tv_sec, gcUtime.tv_usec); setTimeValue(PST_GC_STIME, gcStime.tv_sec, gcStime.tv_usec); setTimeValue(PST_GC_RTIME, gcRtime.tv_sec, gcRtime.tv_usec); } #endif // Update the statistics that are not otherwise copied. Called from the // root thread every second. void Statistics::updatePeriodicStats(size_t freeWords, unsigned threadsInML) { setSize(PSS_ALLOCATION_FREE, freeWords*sizeof(PolyWord)); -#if (defined(HAVE_WINDOWS_H) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) FILETIME ct, et, st, ut, rt; GetProcessTimes(GetCurrentProcess(), &ct, &et, &st, &ut); GetSystemTimeAsFileTime(&rt); subFiletimes(&st, &gcSystemTime); subFiletimes(&ut, &gcUserTime); subFiletimes(&rt, &startTime); subFiletimes(&rt, &gcRealTime); ULARGE_INTEGER li; li.LowPart = ut.dwLowDateTime; li.HighPart = ut.dwHighDateTime; setTimeValue(PST_NONGC_UTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = st.dwLowDateTime; li.HighPart = st.dwHighDateTime; setTimeValue(PST_NONGC_STIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); li.LowPart = rt.dwLowDateTime; li.HighPart = rt.dwHighDateTime; setTimeValue(PST_NONGC_RTIME, (unsigned long)(li.QuadPart / 10000000), (unsigned long)((li.QuadPart / 10) % 1000000)); #else struct rusage usage; struct timeval tv; getrusage(RUSAGE_SELF, &usage); gettimeofday(&tv, NULL); subTimevals(&usage.ru_stime, &gcSystemTime); subTimevals(&usage.ru_utime, &gcUserTime); subTimevals(&tv, &startTime); subTimevals(&tv, &gcRealTime); setTimeValue(PST_NONGC_UTIME, usage.ru_utime.tv_sec, usage.ru_utime.tv_usec); setTimeValue(PST_NONGC_STIME, usage.ru_stime.tv_sec, usage.ru_stime.tv_usec); setTimeValue(PST_NONGC_RTIME, tv.tv_sec, tv.tv_usec); #endif if (statMemory && counterAddrs[PSC_THREADS_IN_ML]) { PLocker lock(&accessLock); unsigned length = counterAddrs[PSC_THREADS_IN_ML][-1]; while (length--) { counterAddrs[PSC_THREADS_IN_ML][length] = (unsigned char)(threadsInML & 0xff); threadsInML = threadsInML >> 8; } } } void Statistics::setUserCounter(unsigned which, POLYSIGNED value) { if (statMemory && userAddrs[which]) { PLocker lock(&accessLock); // Not really needed // The ASN1 int is big-endian unsigned length = userAddrs[which][-1]; while (length--) { userAddrs[which][length] = (unsigned char)value; value = value >> 8; } } } Handle Statistics::returnStatistics(TaskData *taskData, unsigned char *stats) { // Parse the ASN1 tag and length. unsigned char *p = stats; if (*p == POLY_STATS_C_STATISTICS) // Check and skip the tag { p++; if ((*p & 0x80) == 0) p += *p + 1; else { int lengthOfLength = *p++ & 0x7f; if (lengthOfLength != 0) { unsigned l = 0; while (lengthOfLength--) l = (l << 8) | *p++; p += l; } } } return taskData->saveVec.push(C_string_to_Poly(taskData, (const char*)stats, p - stats)); } // Copy the local statistics into the buffer Handle Statistics::getLocalStatistics(TaskData *taskData) { if (statMemory == 0) raise_exception_string(taskData, EXC_Fail, "No statistics available"); return returnStatistics(taskData, statMemory); } // Get statistics for a remote instance. We don't do any locking Handle Statistics::getRemoteStatistics(TaskData *taskData, POLYUNSIGNED pid) { #ifdef HAVE_WINDOWS_H TCHAR shmName[MAX_PATH]; wsprintf(shmName, _T(POLY_STATS_NAME) _T("%") _T(POLYUFMT), pid); HANDLE hRemMemory = OpenFileMapping(FILE_MAP_READ, FALSE, shmName); if (hRemMemory == NULL) raise_exception_string(taskData, EXC_Fail, "No statistics available"); unsigned char *sMem = (unsigned char *)MapViewOfFile(hRemMemory, FILE_MAP_READ, 0, 0, 0); CloseHandle(hRemMemory); if (sMem == NULL) raise_exception_string(taskData, EXC_Fail, "No statistics available"); if (*sMem != POLY_STATS_C_STATISTICS) { UnmapViewOfFile(sMem); raise_exception_string(taskData, EXC_Fail, "Statistics data malformed"); } Handle result = returnStatistics(taskData, sMem); UnmapViewOfFile(sMem); return result; #elif HAVE_MMAP // Find the shared memory in the user's home directory char *homeDir = getenv("HOME"); if (homeDir == NULL) raise_exception_string(taskData, EXC_Fail, "No statistics available"); int remMapFd = -1; size_t remMapSize = 4096; TempCString remMapFileName((char *)malloc(remMapSize)); if (remMapFileName == NULL) raise_exception_string(taskData, EXC_Fail, "No statistics available"); while ((snprintf(remMapFileName, remMapSize, "%s/.polyml/" POLY_STATS_NAME "%" POLYUFMT, homeDir, pid), strlen(remMapFileName) >= remMapSize - 1)) { if (remMapSize > std::numeric_limits::max() / 2) raise_exception_string(taskData, EXC_Fail, "No statistics available"); remMapSize *= 2; char *newFileName = (char *)realloc(remMapFileName, remMapSize); if (newFileName == NULL) raise_exception_string(taskData, EXC_Fail, "No statistics available"); remMapFileName = newFileName; } remMapFd = open(remMapFileName, O_RDONLY); if (remMapFd == -1) raise_exception_string(taskData, EXC_Fail, "No statistics available"); unsigned char *sMem = (unsigned char*)mmap(0, memSize, PROT_READ, MAP_PRIVATE, remMapFd, 0); if (sMem == MAP_FAILED) { close(remMapFd); raise_exception_string(taskData, EXC_Fail, "No statistics available"); } // Check the tag. if (*sMem != POLY_STATS_C_STATISTICS) { munmap(sMem, memSize); close(remMapFd); raise_exception_string(taskData, EXC_Fail, "Statistics data malformed"); } Handle result = returnStatistics(taskData, sMem); munmap(sMem, memSize); close(remMapFd); return result; #else raise_exception_string(taskData, EXC_Fail, "No statistics available"); #endif } // Create the global statistics object. Statistics globalStats; POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetUserStatsCount() { return TAGGED(N_PS_USER).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolySetUserStat(PolyObject *threadId, PolyWord indexVal, PolyWord valueVal) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); try { unsigned index = get_C_unsigned(taskData, indexVal); if (index >= N_PS_USER) raise_exception0(taskData, EXC_subscript); POLYSIGNED value = getPolySigned(taskData, valueVal); globalStats.setUserCounter(index, value); } catch (...) {} // If an ML exception is raised taskData->saveVec.reset(reset); taskData->PostRTSCall(); return TAGGED(0).AsUnsigned(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetLocalStats(PolyObject *threadId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = globalStats.getLocalStatistics(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(); } POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetRemoteStats(PolyObject *threadId, PolyWord procId) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, procId)); } 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 statisticsEPT[] = { { "PolyGetUserStatsCount", (polyRTSFunction)&PolyGetUserStatsCount }, { "PolySetUserStat", (polyRTSFunction)&PolySetUserStat }, { "PolyGetLocalStats", (polyRTSFunction)&PolyGetLocalStats }, { "PolyGetRemoteStats", (polyRTSFunction)&PolyGetRemoteStats }, { NULL, NULL } // End of list. }; diff --git a/libpolyml/statistics.h b/libpolyml/statistics.h index b2553a5c..d1c8593d 100644 --- a/libpolyml/statistics.h +++ b/libpolyml/statistics.h @@ -1,140 +1,140 @@ /* Title: statics.h - Interface to profiling statistics Copyright (c) 2011, 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 */ #ifndef STATISTICS_INCLUDED #define STATISTICS_INCLUDED #ifdef HAVE_WINDOWS_H #include #endif #include "globals.h" #include "locking.h" #include "rts_module.h" #include "../polystatistics.h" enum { PSC_THREADS = 0, // Total number of threads PSC_THREADS_IN_ML, // Threads running ML code PSC_THREADS_WAIT_IO, // Threads waiting for IO PSC_THREADS_WAIT_MUTEX, // Threads waiting for a mutex PSC_THREADS_WAIT_CONDVAR, // Threads waiting for a condition var PSC_THREADS_WAIT_SIGNAL, // Special case - signal handling thread PSC_GC_FULLGC, // Number of full garbage collections PSC_GC_PARTIALGC, // Number of partial GCs PSC_GC_SHARING, // Number of sharing passes PSS_TOTAL_HEAP, // Total size of the local heap PSS_AFTER_LAST_GC, // Space free after last GC PSS_AFTER_LAST_FULLGC, // Space free after the last full GC PSS_ALLOCATION, // Size of allocation space PSS_ALLOCATION_FREE, // Space available in allocation area PSS_CODE_SPACE, // Space for code PSS_STACK_SPACE, // Space for stack N_PS_INTS }; enum { PST_NONGC_UTIME, PST_NONGC_STIME, PST_GC_UTIME, PST_GC_STIME, PST_NONGC_RTIME, PST_GC_RTIME, N_PS_TIMES }; // A few counters that can be used by the application #define N_PS_USER 8 class TaskData; class SaveVecEntry; typedef SaveVecEntry *Handle; class Statistics: RtsModule { public: Statistics(); ~Statistics(); virtual void Init(void); // Initialise after set-up Handle getLocalStatistics(TaskData *taskData); Handle getRemoteStatistics(TaskData *taskData, POLYUNSIGNED processId); void incCount(int which); void decCount(int which); void setSize(int which, size_t s); void incSize(int which, size_t s); void decSize(int which, size_t s); size_t getSize(int which); void setUserCounter(unsigned which, POLYSIGNED value); -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) // Native Windows void copyGCTimes(const FILETIME &gcUtime, const FILETIME &gcStime, const FILETIME &gcRtime); FILETIME gcUserTime, gcSystemTime, gcRealTime, startTime; #else // Unix and Cygwin void copyGCTimes(const struct timeval &gcUtime, const struct timeval &gcStime, const struct timeval &gcRtime); struct timeval gcUserTime, gcSystemTime, gcRealTime, startTime; #endif void updatePeriodicStats(size_t freeSpace, unsigned threadsInML); bool exportStats; private: PLock accessLock; #ifdef HAVE_WINDOWS_H // File mapping handle HANDLE hFileMap; #else char *mapFileName; int mapFd; #endif size_t memSize; unsigned char *statMemory; unsigned char *newPtr; unsigned char *counterAddrs[N_PS_INTS]; struct { unsigned char *secAddr; unsigned char *usecAddr; } timeAddrs[N_PS_TIMES]; unsigned char *userAddrs[N_PS_USER]; Handle returnStatistics(TaskData *taskData, unsigned char *stats); void addCounter(int cEnum, unsigned statId, const char *name); void addSize(int cEnum, unsigned statId, const char *name); void addTime(int cEnum, unsigned statId, const char *name); void addUser(int n, unsigned statId, const char *name); size_t getSizeWithLock(int which); void setSizeWithLock(int which, size_t s); void setTimeValue(int which, unsigned long secs, unsigned long usecs); }; extern Statistics globalStats; extern struct _entrypts statisticsEPT[]; #endif // STATISTICS_INCLUDED diff --git a/libpolyml/timing.cpp b/libpolyml/timing.cpp index 37b53b34..5af9210f 100644 --- a/libpolyml/timing.cpp +++ b/libpolyml/timing.cpp @@ -1,810 +1,811 @@ /* Title: Time functions. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright (c) 2000 Cambridge University Technical Services Limited Further development copyright David C.J. Matthews 2011,12,16,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_STDLIB_H #include #endif #ifdef HAVE_LOCALE_H #include #endif #ifdef HAVE_SYS_PARAM_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_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_SYS_SIGNAL_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_UNISTD_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) 0 #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_WINDOWS_H #include #endif #include // Windows headers define min/max macros, which messes up trying to use std::numeric_limits::min/max() #ifdef min #undef min #endif #ifdef max #undef max #endif #include "locking.h" #include "globals.h" #include "arb.h" #include "run_time.h" #include "sys.h" #include "timing.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "processes.h" #include "heapsizing.h" #include "rtsentry.h" #include "mpoly.h" // For polyStderr extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingTicksPerMicroSec(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetNow(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingBaseYear(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingYearOffset(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingLocalOffset(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingSummerApplies(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingConvertDateStuct(FirstArgument threadId, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetUser(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetSystem(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCUser(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetReal(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildUser(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetChildSystem(FirstArgument threadId); POLYEXTERNALSYMBOL POLYUNSIGNED PolyTimingGetGCSystem(FirstArgument threadId); } -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) /* Windows file times are 64-bit numbers representing times in tenths of a microsecond. */ #define TICKS_PER_MICROSECOND 10 #ifdef __GNUC__ #define SECSSINCE1601 11644473600LL #else #define SECSSINCE1601 11644473600 #endif #else /* For Unix return times in microseconds. */ #define TICKS_PER_MICROSECOND 1 #endif /* The original Poly timing functions used a variety of timing bases (e.g. seconds, tenths of a second). The old functions have been retained but the intention is to phase them out in favour of new functions. Most of these are handled through the timing_dispatch function. The intention behind the timing functions is to make use of the arbitrary precision arithmetic to allow for a wider range of dates than the usual mktime range of 1970 to 2036. We also want to handle more accurate timing than per second or per microsecond where the operating system provides it. */ -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) static FILETIME startTime; #define StrToLL _strtoi64 #else static struct timeval startTime; #define StrToLL strtoll #endif #if(!(defined(HAVE_GMTIME_R) && defined(HAVE_LOCALTIME_R))) // gmtime and localtime are not re-entrant so if we don't have the // re-entrant versions we need to use a lock. static PLock timeLock("Timing"); #endif #define XSTR(X) STR(X) #define STR(X) #X // Get ticks per microsecond. POLYUNSIGNED PolyTimingTicksPerMicroSec(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, TICKS_PER_MICROSECOND); } 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 time since the time base. */ POLYUNSIGNED PolyTimingGetNow(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) FILETIME ft; GetSystemTimeAsFileTime(&ft); result = Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); result = Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #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(); } /* Return the base year. This is the year which corresponds to zero in the timing sequence. */ POLYUNSIGNED PolyTimingBaseYear(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) result = Make_arbitrary_precision(taskData, 1601); + #else result = Make_arbitrary_precision(taskData, 1970); #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(); } /* In both Windows and Unix the time base is 1st of January in the base year. This function is provided just in case we are running on a system with a different base. It returns the number of seconds after 1st January of the base year that corresponds to zero of the time base. */ POLYUNSIGNED PolyTimingYearOffset(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, 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 time offset which applied/will apply at the specified time (in seconds). */ POLYUNSIGNED PolyTimingLocalOffset(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 { int localoff = 0; time_t theTime; int day = 0; #if (defined(HAVE_GMTIME_R) || defined(HAVE_LOCALTIME_R)) struct tm resultTime; #endif -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) /* Although the offset is in seconds it is since 1601. */ FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. getFileTimeFromArb(taskData, pushedArg, &ftSeconds); /* May raise exception. */ ULARGE_INTEGER liTime; liTime.HighPart = ftSeconds.dwHighDateTime; liTime.LowPart = ftSeconds.dwLowDateTime; theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else theTime = get_C_long(taskData, DEREFWORD(pushedArg)); /* May raise exception. */ #endif { #ifdef HAVE_GMTIME_R struct tm* loctime = gmtime_r(&theTime, &resultTime); #else PLocker lock(&timeLock); struct tm* loctime = gmtime(&theTime); #endif if (loctime == NULL) raise_exception0(taskData, EXC_size); localoff = (loctime->tm_hour * 60 + loctime->tm_min) * 60 + loctime->tm_sec; day = loctime->tm_yday; } { #ifdef HAVE_LOCALTIME_R struct tm* loctime = localtime_r(&theTime, &resultTime); #else PLocker lock(&timeLock); struct tm* loctime = localtime(&theTime); #endif if (loctime == NULL) raise_exception0(taskData, EXC_size); localoff -= (loctime->tm_hour * 60 + loctime->tm_min) * 60 + loctime->tm_sec; if (loctime->tm_yday != day) { // Different day - have to correct it. We can assume that there // is at most one day to correct. if (day == loctime->tm_yday + 1 || (day == 0 && loctime->tm_yday >= 364)) localoff += 24 * 60 * 60; else localoff -= 24 * 60 * 60; } } result = Make_arbitrary_precision(taskData, localoff); } 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 Summer Time (daylight saving) was/will be in effect. */ POLYUNSIGNED PolyTimingSummerApplies(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 { time_t theTime; -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) FILETIME ftSeconds; // Not really a file-time because it's a number of seconds. getFileTimeFromArb(taskData, pushedArg, &ftSeconds); /* May raise exception. */ ULARGE_INTEGER liTime; liTime.HighPart = ftSeconds.dwHighDateTime; liTime.LowPart = ftSeconds.dwLowDateTime; theTime = (long)(liTime.QuadPart - SECSSINCE1601); #else theTime = get_C_long(taskData, DEREFWORD(pushedArg)); /* May raise exception. */ #endif int isDst = 0; #ifdef HAVE_LOCALTIME_R struct tm resultTime; struct tm* loctime = localtime_r(&theTime, &resultTime); isDst = loctime->tm_isdst; #else { PLocker lock(&timeLock); struct tm* loctime = localtime(&theTime); if (loctime == NULL) raise_exception0(taskData, EXC_size); isDst = loctime->tm_isdst; } #endif result = Make_arbitrary_precision(taskData, isDst); } 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(); } /* Call strftime. It would be possible to do much of this in ML except that it requires the current locale. */ POLYUNSIGNED PolyTimingConvertDateStuct(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 { struct tm time; char* format, buff[2048]; Handle resString; /* Get the format string. */ format = Poly_string_to_C_alloc(DEREFHANDLE(pushedArg)->Get(0)); /* Copy the time information. */ time.tm_year = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(1)) - 1900; time.tm_mon = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(2)); time.tm_mday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(3)); time.tm_hour = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(4)); time.tm_min = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(5)); time.tm_sec = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(6)); time.tm_wday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(7)); time.tm_yday = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(8)); time.tm_isdst = get_C_int(taskData, DEREFHANDLE(pushedArg)->Get(9)); -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) _tzset(); /* Make sure we set the current locale. */ #else setlocale(LC_TIME, ""); #endif /* It would be better to dynamically allocate the string rather than use a fixed size but Unix unlike Windows does not distinguish between an error in the input and the buffer being too small. */ if (strftime(buff, sizeof(buff), format, &time) <= 0) { /* Error */ free(format); raise_exception0(taskData, EXC_size); } resString = taskData->saveVec.push(C_string_to_Poly(taskData, buff)); free(format); result = resString; } 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 User CPU time since the start. */ POLYUNSIGNED PolyTimingGetUser(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) FILETIME ut, ct, et, kt; if (!GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); result = Make_arb_from_Filetime(taskData, ut); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #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(); } /* Return System CPU time since the start. */ POLYUNSIGNED PolyTimingGetSystem(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) FILETIME ct, et, kt, ut; if (!GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) raise_syscall(taskData, "GetProcessTimes failed", GetLastError()); result = Make_arb_from_Filetime(taskData, kt); #else struct rusage rusage; if (getrusage(RUSAGE_SELF, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #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(); } /* Return GC time since the start. */ POLYUNSIGNED PolyTimingGetGCUser(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = gHeapSizeParameters.getGCUtime(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(); } /* Return real time since the start. */ POLYUNSIGNED PolyTimingGetReal(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) FILETIME ft; GetSystemTimeAsFileTime(&ft); subFiletimes(&ft, &startTime); result = Make_arb_from_Filetime(taskData, ft); #else struct timeval tv; if (gettimeofday(&tv, NULL) != 0) raise_syscall(taskData, "gettimeofday failed", errno); subTimevals(&tv, &startTime); result = Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000); #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(); } /* Return User CPU time used by child processes. (Posix only) */ POLYUNSIGNED PolyTimingGetChildUser(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) result = Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec, rusage.ru_utime.tv_usec, 1000000); #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(); } /* Return System CPU time used by child processes. (Posix only) */ POLYUNSIGNED PolyTimingGetChildSystem(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) result = Make_arbitrary_precision(taskData, 0); #else struct rusage rusage; if (getrusage(RUSAGE_CHILDREN, &rusage) != 0) raise_syscall(taskData, "getrusage failed", errno); result = Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec, rusage.ru_stime.tv_usec, 1000000); #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(); } /* Return GC system time since the start. */ POLYUNSIGNED PolyTimingGetGCSystem(FirstArgument threadId) { TaskData* taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); Handle result = 0; try { result = gHeapSizeParameters.getGCStime(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(); } -#ifdef HAVE_WINDOWS_H +#ifdef _WIN32 void addFiletimes(FILETIME *result, const FILETIME *x) { ULARGE_INTEGER liA, liB; liA.LowPart = result->dwLowDateTime; liA.HighPart = result->dwHighDateTime; liB.LowPart = x->dwLowDateTime; liB.HighPart = x->dwHighDateTime; liA.QuadPart += liB.QuadPart; result->dwLowDateTime = liA.LowPart; result->dwHighDateTime = liA.HighPart; } void subFiletimes(FILETIME *result, const FILETIME *x) { ULARGE_INTEGER liA, liB; liA.LowPart = result->dwLowDateTime; liA.HighPart = result->dwHighDateTime; liB.LowPart = x->dwLowDateTime; liB.HighPart = x->dwHighDateTime; liA.QuadPart -= liB.QuadPart; result->dwLowDateTime = liA.LowPart; result->dwHighDateTime = liA.HighPart; } float filetimeToSeconds(const FILETIME *x) { ULARGE_INTEGER ul; ul.LowPart = x->dwLowDateTime; ul.HighPart = x->dwHighDateTime; return (float)ul.QuadPart / (float)1.0E7; } void FileTimeTime::fromSeconds(unsigned u) { ULARGE_INTEGER li; li.QuadPart = (ULONGLONG)u * TICKS_PER_MICROSECOND * 1000000; t.dwLowDateTime = li.LowPart; t.dwHighDateTime = li.HighPart; } void FileTimeTime::add(const FileTimeTime &f) { addFiletimes(&t, &f.t); } void FileTimeTime::sub(const FileTimeTime &f) { subFiletimes(&t, &f.t); } float FileTimeTime::toSeconds(void) { return filetimeToSeconds(&t); } #endif #ifdef HAVE_SYS_TIME_H void addTimevals(struct timeval *result, const struct timeval *x) { long uSecs = result->tv_usec + x->tv_usec; result->tv_sec += x->tv_sec; if (uSecs >= 1000000) { result->tv_sec++; uSecs -= 1000000; } result->tv_usec = uSecs; } void subTimevals(struct timeval *result, const struct timeval *x) { long uSecs = result->tv_usec - x->tv_usec; result->tv_sec -= x->tv_sec; if (uSecs < 0) { result->tv_sec--; uSecs += 1000000; } result->tv_usec = uSecs; } float timevalToSeconds(const struct timeval *x) { return (float)x->tv_sec + (float)x->tv_usec / 1.0E6; } void TimeValTime::add(const TimeValTime &f) { addTimevals(&t, &f.t); } void TimeValTime::sub(const TimeValTime &f) { subTimevals(&t, &f.t); } #endif struct _entrypts timingEPT[] = { { "PolyTimingTicksPerMicroSec", (polyRTSFunction)&PolyTimingTicksPerMicroSec}, { "PolyTimingGetNow", (polyRTSFunction)&PolyTimingGetNow}, { "PolyTimingBaseYear", (polyRTSFunction)&PolyTimingBaseYear}, { "PolyTimingYearOffset", (polyRTSFunction)&PolyTimingYearOffset}, { "PolyTimingLocalOffset", (polyRTSFunction)&PolyTimingLocalOffset}, { "PolyTimingSummerApplies", (polyRTSFunction)&PolyTimingSummerApplies}, { "PolyTimingConvertDateStuct", (polyRTSFunction)&PolyTimingConvertDateStuct}, { "PolyTimingGetUser", (polyRTSFunction)&PolyTimingGetUser}, { "PolyTimingGetSystem", (polyRTSFunction)&PolyTimingGetSystem}, { "PolyTimingGetGCUser", (polyRTSFunction)&PolyTimingGetGCUser}, { "PolyTimingGetReal", (polyRTSFunction)&PolyTimingGetReal}, { "PolyTimingGetChildUser", (polyRTSFunction)&PolyTimingGetChildUser}, { "PolyTimingGetChildSystem", (polyRTSFunction)&PolyTimingGetChildSystem}, { "PolyTimingGetGCSystem", (polyRTSFunction)&PolyTimingGetGCSystem}, { NULL, NULL} // End of list. }; class Timing: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static Timing timingModule; void Timing::Init(void) { -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) // Record an initial time of day to use as the basis of real timing GetSystemTimeAsFileTime(&startTime); #else gettimeofday(&startTime, NULL); #endif } time_t getBuildTime(void) { char *source_date_epoch = getenv("SOURCE_DATE_EPOCH"); if (source_date_epoch) { errno = 0; char *endptr; long long epoch = StrToLL(source_date_epoch, &endptr, 10); if ((errno == ERANGE && (epoch == LLONG_MIN || epoch == LLONG_MAX)) || (errno != 0 && epoch == 0)) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: " XSTR(StrToLL) ": %s\n", strerror(errno)); goto err; } if (endptr == source_date_epoch) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: No digits were found: %s\n", endptr); goto err; } if (*endptr != '\0') { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: Trailing garbage: %s\n", endptr); goto err; } if (epoch < (long long)std::numeric_limits::min()) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: value must be greater than or equal to: %lld but was found to be: %lld\n", (long long)std::numeric_limits::min(), epoch); goto err; } if (epoch > (long long)std::numeric_limits::max()) { fprintf(polyStderr, "Environment variable $SOURCE_DATE_EPOCH: value must be smaller than or equal to: %lld but was found to be: %lld\n", (long long)std::numeric_limits::max(), epoch); goto err; } return (time_t) epoch; } err: return time(NULL); } diff --git a/libpolyml/timing.h b/libpolyml/timing.h index 9bc743ce..3eaa12cd 100644 --- a/libpolyml/timing.h +++ b/libpolyml/timing.h @@ -1,109 +1,107 @@ /* Title: Header for time functions Copyright (c) 2000 Cambridge University Technical Services Limited - Further development Copyright David C.J. Matthews 2011-12, 16. + Further development Copyright David C.J. Matthews 2011-12, 16, 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 */ #ifndef _TIMING_H_DEFINED #define _TIMING_H_DEFINED 1 #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_WINDOWS_H #include #endif class SaveVecEntry; typedef SaveVecEntry *Handle; class TaskData; /* time functions etc */ // Define classes for operations on time values in Windows and Posix. -// N.B. In Cygwin we use both classes because in some cases we need -// Windows-style timing and in other places we use Unix-style. -#ifdef HAVE_WINDOWS_H +#ifdef _WIN32 class FileTimeTime { public: FileTimeTime() { t.dwLowDateTime = t.dwHighDateTime = 0; } FileTimeTime(const FILETIME f) { t = f; } void fromSeconds(unsigned u); void add(const FileTimeTime &); void sub(const FileTimeTime &); float toSeconds(void); operator FILETIME() const { return t; } protected: FILETIME t; }; #endif #ifdef HAVE_SYS_TIME_H class TimeValTime { public: TimeValTime() { t.tv_sec = 0; t.tv_usec = 0; } TimeValTime(const timeval f) { t = f; } void fromSeconds(unsigned u) { t.tv_sec = u; t.tv_usec = 0; } void add(const TimeValTime &); void sub(const TimeValTime &); float toSeconds(void) { return (float)t.tv_sec + (float)t.tv_usec / 1.0E6; } operator timeval() const { return t; } protected: struct timeval t; }; #endif -#if (defined(_WIN32) && ! defined(__CYGWIN__)) /* Native windows */ +#ifdef _WIN32 /* Native windows */ #define TIMEDATA FileTimeTime #else /* Unix and Cygwin. */ #define TIMEDATA TimeValTime #endif #ifdef HAVE_WINDOWS_H extern void addFiletimes(FILETIME *result, const FILETIME *x); extern void subFiletimes(FILETIME *result, const FILETIME *x); extern float filetimeToSeconds(const FILETIME *x); #endif #ifdef HAVE_SYS_TIME_H extern void addTimevals(struct timeval *result, const struct timeval *x); extern void subTimevals(struct timeval *result, const struct timeval *x); extern float timevalToSeconds(const struct timeval *x); #endif extern time_t getBuildTime(void); extern struct _entrypts timingEPT[]; #endif diff --git a/libpolyml/unix_specific.cpp b/libpolyml/unix_specific.cpp index 66ac58cd..57f3165d 100644 --- a/libpolyml/unix_specific.cpp +++ b/libpolyml/unix_specific.cpp @@ -1,2028 +1,2033 @@ /* Title: Operating Specific functions: Unix version. Copyright (c) 2000-8, 2016-17, 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 */ #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_UNISTD_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_LIMITS_H #include #endif #ifdef HAVE_FCNTL_H #include #endif #ifdef HAVE_PWD_H #include #endif #ifdef HAVE_GRP_H #include #endif #ifdef HAVE_SYS_TYPES_H #include #endif #ifdef HAVE_SYS_PARAM_H #include #endif #ifdef HAVE_SYS_WAIT_H #include #endif #ifdef HAVE_SYS_IOCTL_H #include #endif #ifdef HAVE_SYS_SIGNAL_H #include #endif #ifdef HAVE_SYS_TIME_H #include #endif #ifdef HAVE_SYS_TERMIOS_H #include #elif (defined(HAVE_TERMIOS_H)) #include #endif #ifdef HAVE_SYS_STAT_H #include #endif #ifdef HAVE_SYS_UTSNAME_H #include #endif #ifdef HAVE_SIGNAL_H #include #endif #include "globals.h" #include "arb.h" #include "run_time.h" #include "io_internal.h" #include "sys.h" #include "diagnostics.h" #include "machine_dep.h" #include "os_specific.h" #include "gc.h" #include "processes.h" #include "mpoly.h" #include "sighandler.h" #include "polystring.h" #include "save_vec.h" #include "rts_module.h" #include "rtsentry.h" extern "C" { POLYEXTERNALSYMBOL POLYUNSIGNED PolyOSSpecificGeneral(FirstArgument threadId, PolyWord code, PolyWord arg); POLYEXTERNALSYMBOL POLYUNSIGNED PolyGetOSType(); POLYEXTERNALSYMBOL POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxTime, PolyWord sigCount); } #define SAVE(x) taskData->saveVec.push(x) #define ALLOC(n) alloc_and_save(taskData, n) #define SIZEOF(x) (sizeof(x)/sizeof(PolyWord)) /* Table of constants returned by call 4. */ // This is currently unsigned because that's necessary on the PowerPC for // NOFLUSH. Perhaps there should be separate tables for different kinds // of constants. static unsigned unixConstVec[] = { /* Error codes. */ E2BIG, /* 0 */ EACCES, EAGAIN, EBADF, #ifdef EBADMSG /* This is not defined in FreeBSD. */ EBADMSG, #else 0, #endif EBUSY, #ifdef ECANCELED /* This is not defined in Linux. Perhaps someone knows how to spell "cancelled". */ ECANCELED, #else 0, /* Perhaps some other value. */ #endif ECHILD, EDEADLK, EDOM, EEXIST, EFAULT, EFBIG, EINPROGRESS, EINTR, EINVAL, EIO, EISDIR, ELOOP, EMFILE, EMLINK, /* 20 */ EMSGSIZE, ENAMETOOLONG, ENFILE, ENODEV, ENOENT, ENOEXEC, ENOLCK, ENOMEM, ENOSPC, ENOSYS, ENOTDIR, ENOTEMPTY, #ifdef ENOTSUP /* Not defined in Linux. */ ENOTSUP, #else 0, #endif ENOTTY, ENXIO, EPERM, EPIPE, ERANGE, EROFS, ESPIPE, ESRCH, EXDEV, /* 42 */ /* Signals. */ SIGABRT, /* 43 */ SIGALRM, SIGBUS, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, /* 62 */ /* Open flags. */ O_RDONLY, /* 63 */ O_WRONLY, O_RDWR, O_APPEND, O_EXCL, O_NOCTTY, O_NONBLOCK, #ifdef O_SYNC O_SYNC, /* Not defined in FreeBSD. */ #else 0, #endif O_TRUNC, /* 71 */ /* TTY: Special characters. */ VEOF, /* 72 */ VEOL, VERASE, VINTR, VKILL, VMIN, VQUIT, VSUSP, VTIME, VSTART, VSTOP, NCCS, /* 83 */ /* TTY: Input mode. */ BRKINT, /* 84 */ ICRNL, IGNBRK, IGNCR, IGNPAR, INLCR, INPCK, ISTRIP, IXOFF, IXON, PARMRK, /* 94 */ /* TTY: Output mode. */ OPOST, /* 95 */ /* TTY: Control modes. */ CLOCAL, /* 96 */ CREAD, CS5, CS6, CS7, CS8, CSIZE, CSTOPB, HUPCL, PARENB, PARODD, /* 106 */ /* TTY: Local modes. */ ECHO, /* 107 */ ECHOE, ECHOK, ECHONL, ICANON, IEXTEN, ISIG, (unsigned)NOFLSH, TOSTOP, /* 115 */ /* TTY: Speeds. */ B0, /* 116 */ B50, B75, B110, B134, B150, B200, B300, B600, B1200, B1800, B2400, B4800, B9600, B19200, B38400, /* 131 */ /* FD flags. */ FD_CLOEXEC, /* 132 */ /* Wait flags. */ WUNTRACED, /* 133 */ WNOHANG, /* 134 */ /* tcsetattr flags. */ TCSANOW, /* 135 */ TCSADRAIN, TCSAFLUSH, /* tcflow flags. */ TCOOFF, /* 138 */ TCOON, TCIOFF, TCION, /* tcflush flags. */ TCIFLUSH, /* 142 */ TCOFLUSH, TCIOFLUSH, /* File permissions. */ S_IRUSR, /* 145 */ S_IWUSR, S_IXUSR, S_IRGRP, S_IWGRP, S_IXGRP, S_IROTH, S_IWOTH, S_IXOTH, S_ISUID, S_ISGID, /* 155 */ /* Bits for access function. */ R_OK, /* 156 */ W_OK, X_OK, F_OK, /* 159 */ /* Values for lseek. */ SEEK_SET, /* 160 */ SEEK_CUR, SEEK_END, /* 162 */ /* Values for lock types. */ F_RDLCK, /* 163 */ F_WRLCK, F_UNLCK, /* 165 */ /* Mask for file access. */ O_ACCMODE, /* 166 */ }; /* Auxiliary functions which implement the more complex cases. */ static Handle waitForProcess(TaskData *taskData, Handle args); static Handle makePasswordEntry(TaskData *taskData, struct passwd *pw); static Handle makeGroupEntry(TaskData *taskData, struct group *grp); static Handle getUname(TaskData *taskData); static Handle getSysConf(TaskData *taskData, Handle args); static Handle getTTYattrs(TaskData *taskData, Handle args); static Handle setTTYattrs(TaskData *taskData, Handle args); static Handle getStatInfo(TaskData *taskData, struct stat *buf); static Handle lockCommand(TaskData *taskData, int cmd, Handle args); static int findPathVar(TaskData *taskData, PolyWord ps); // Unmask all signals just before exec. static void restoreSignals(void) { sigset_t sigset; sigemptyset(&sigset); sigprocmask(SIG_SETMASK, &sigset, NULL); } Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code) { int c = get_C_long(taskData, code->Word()); switch (c) { case 0: /* Return our OS type. Not in any structure. */ return Make_fixed_precision(taskData, 0); /* 0 for Unix. */ case 4: /* Return a constant. */ { unsigned i = get_C_unsigned(taskData, args->Word()); if (i >= sizeof(unixConstVec)/sizeof(unixConstVec[0])) raise_syscall(taskData, "Invalid index", 0); return Make_sysword(taskData, unixConstVec[i]); } case 5: /* fork. */ { pid_t pid = fork(); if (pid < 0) raise_syscall(taskData, "fork failed", errno); - if (pid == 0) processes->SetSingleThreaded(); + if (pid == 0) + { + // In the child process the only thread is this one. + processes->SetSingleThreaded(); + GCSetSingleThreadAfterFork(); + } return Make_fixed_precision(taskData, pid); } case 6: /* kill */ { int pid = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int sig = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (kill(pid, sig) < 0) raise_syscall(taskData, "kill failed", errno); return Make_fixed_precision(taskData, 0); } case 7: /* get process id */ { pid_t pid = getpid(); if (pid < 0) raise_syscall(taskData, "getpid failed", errno); return Make_fixed_precision(taskData, pid); } case 8: /* get process id of parent */ { pid_t pid = getppid(); if (pid < 0) raise_syscall(taskData, "getppid failed", errno); return Make_fixed_precision(taskData, pid); } case 9: /* get real user id */ { uid_t uid = getuid(); // This is defined always to succeed return Make_fixed_precision(taskData, uid); } case 10: /* get effective user id */ { uid_t uid = geteuid(); // This is defined always to succeed return Make_fixed_precision(taskData, uid); } case 11: /* get real group id */ { gid_t gid = getgid(); // This is defined always to succeed return Make_fixed_precision(taskData, gid); } case 12: /* get effective group id */ { gid_t gid = getegid(); // This is defined always to succeed return Make_fixed_precision(taskData, gid); } case 13: /* Return process group */ { pid_t pid = getpgrp(); if (pid < 0) raise_syscall(taskData, "getpgrp failed", errno); return Make_fixed_precision(taskData, pid); } case 14: /* Wait for child process to terminate. */ return waitForProcess(taskData, args); case 15: /* Unpack a process result. */ { int resType, resVal; Handle result, typeHandle, resHandle; int status = get_C_long(taskData, args->Word()); if (WIFEXITED(status)) { resType = 1; resVal = WEXITSTATUS(status); } else if (WIFSIGNALED(status)) { resType = 2; resVal = WTERMSIG(status); } else if (WIFSTOPPED(status)) { resType = 3; resVal = WSTOPSIG(status); } else { /* ?? */ resType = 0; resVal = 0; } typeHandle = Make_fixed_precision(taskData, resType); resHandle = Make_fixed_precision(taskData, resVal); result = ALLOC(2); DEREFHANDLE(result)->Set(0, typeHandle->Word()); DEREFHANDLE(result)->Set(1, resHandle->Word()); return result; } case 16: /* Pack up a process result. The inverse of the previous call. */ { int resType = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int resVal = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int result = 0; switch (resType) { case 1: /* Exited */ result = resVal << 8; break; case 2: /* Signalled */ result = resVal; break; case 3: /* Stopped */ result = (resVal << 8) | 0177; } return Make_fixed_precision(taskData, result); } case 17: /* Run a new executable. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); int err; restoreSignals(); execv(path, argl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); raise_syscall(taskData, "execv failed", err); } case 18: /* Run a new executable with given environment. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); char **envl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(2))); int err; restoreSignals(); execve(path, argl, envl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); freeStringVector(envl); raise_syscall(taskData, "execve failed", err); } case 19: /* Run a new executable using PATH environment variable. */ { char *path = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char **argl = stringListToVector(SAVE(DEREFHANDLE(args)->Get(1))); int err; restoreSignals(); execvp(path, argl); err = errno; /* We only get here if there's been an error. */ free(path); freeStringVector(argl); raise_syscall(taskData, "execvp failed", err); } case 20: /* Sets an alarm and returns the current alarm time. A value of zero for the time cancels the timer. */ { /* We have a value in microseconds. We need to split it into seconds and microseconds. */ Handle hTime = args; Handle hMillion = Make_arbitrary_precision(taskData, 1000000); struct itimerval newTimer, oldTimer; newTimer.it_interval.tv_sec = 0; newTimer.it_interval.tv_usec = 0; newTimer.it_value.tv_sec = get_C_long(taskData, div_longc(taskData, hMillion, hTime)->Word()); newTimer.it_value.tv_usec = get_C_long(taskData, rem_longc(taskData, hMillion, hTime)->Word()); if (setitimer(ITIMER_REAL, &newTimer, &oldTimer) != 0) raise_syscall(taskData, "setitimer failed", errno); Handle result = /* Return the previous setting. */ Make_arb_from_pair_scaled(taskData, oldTimer.it_value.tv_sec, oldTimer.it_value.tv_usec, 1000000); return result; } case 23: /* Set uid. */ { uid_t uid = get_C_long(taskData, args->Word()); if (setuid(uid) != 0) raise_syscall(taskData, "setuid failed", errno); return Make_fixed_precision(taskData, 0); } case 24: /* Set gid. */ { gid_t gid = get_C_long(taskData, args->Word()); if (setgid(gid) != 0) raise_syscall(taskData, "setgid failed", errno); return Make_fixed_precision(taskData, 0); } case 25: /* Get group list. */ { // This previously allocated gid_t[NGROUPS_MAX] on the stack but this // requires quite a bit of stack space. gid_t gid[1]; int ngroups = getgroups(0, gid); // Just get the number. if (ngroups < 0) raise_syscall(taskData, "getgroups failed", errno); if (ngroups == 0) return SAVE(ListNull); gid_t *groups = (gid_t*)calloc(sizeof(gid_t), ngroups); if (groups == 0) raise_syscall(taskData, "Unable to allocate memory", errno); if (getgroups(ngroups, groups) < 0) { int lasterr = errno; free(groups); raise_syscall(taskData, "getgroups failed", lasterr); } Handle saved = taskData->saveVec.mark(); Handle list = SAVE(ListNull); /* It's simplest to process the integers in reverse order */ while (--ngroups >= 0) { Handle value = Make_fixed_precision(taskData, groups[ngroups]); Handle next = ALLOC(SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = value->Word(); DEREFLISTHANDLE(next)->t = list->Word(); taskData->saveVec.reset(saved); list = SAVE(next->Word()); } free(groups); return list; } case 26: /* Get login name. */ { char *login = getlogin(); if (login == 0) raise_syscall(taskData, "getlogin failed", errno); return SAVE(C_string_to_Poly(taskData, login)); } case 27: /* Set sid */ { pid_t pid = setsid(); if (pid < 0) raise_syscall(taskData, "setsid failed", errno); return Make_fixed_precision(taskData, pid); } case 28: /* Set process group. */ { pid_t pid = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); pid_t pgid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (setpgid(pid, pgid) < 0 ) raise_syscall(taskData, "setpgid failed", errno); return Make_fixed_precision(taskData, 0); } case 29: /* uname */ return getUname(taskData); case 30: /* Get controlling terminal. */ #ifdef HAVE_CTERMID { char *term = ctermid(0); /* Can this generate an error? */ if (term == 0) raise_syscall(taskData, "ctermid failed", errno); return SAVE(C_string_to_Poly(taskData, term)); } #else raise_syscall(taskData, "ctermid is not implemented", 0); #endif case 31: /* Get terminal name for file descriptor. */ { char *term = ttyname(getStreamFileDescriptor(taskData, args->Word())); if (term == 0) raise_syscall(taskData, "ttyname failed", errno); return SAVE(C_string_to_Poly(taskData, term)); } case 32: /* Test if file descriptor is a terminal. Returns false if the stream is closed. */ { int descr = getStreamFileDescriptorWithoutCheck(args->Word()); if (descr != -1 && isatty(descr)) return Make_fixed_precision(taskData, 1); else return Make_fixed_precision(taskData, 0); } case 33: /* sysconf. */ return getSysConf(taskData, args); /* Filesys entries. */ case 50: /* Set the file creation mask and return the old one. */ { mode_t mode = get_C_ulong(taskData, args->Word()); return Make_fixed_precision(taskData, umask(mode)); } case 51: /* Create a hard link. */ { char *old = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char *newp = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(1)); int err, res; res = link(old, newp); err = errno; /* Save the error result in case free changes it. */ free(old); free(newp); if (res < 0) raise_syscall(taskData, "link failed", err); return Make_fixed_precision(taskData, 0); } case 52: /* Create a directory. There is an OS-independent version in basicio which uses a default creation mode. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = mkdir(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "mkdir failed", err); return Make_fixed_precision(taskData, 0); } case 53: /* Create a fifo. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = mkfifo(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "mkfifo failed", err); return Make_fixed_precision(taskData, 0); } case 54: /* Create a symbolic link. */ { char *old = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); char *newp = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(1)); int err, res; res = symlink(old, newp); err = errno; /* Save the error result in case free changes it. */ free(old); free(newp); if (res < 0) raise_syscall(taskData, "link failed", err); return Make_fixed_precision(taskData, 0); } case 55: /* Get information about a file. */ { struct stat buf; int res, err; char *name = Poly_string_to_C_alloc(DEREFWORD(args)); res = stat(name, &buf); err = errno; free(name); if (res < 0) raise_syscall(taskData, "stat failed", err); return getStatInfo(taskData, &buf); } case 56: /* Get information about a symbolic link. */ { struct stat buf; int res, err; char *name = Poly_string_to_C_alloc(DEREFWORD(args)); res = lstat(name, &buf); err = errno; free(name); if (res < 0) raise_syscall(taskData, "lstat failed", err); return getStatInfo(taskData, &buf); } case 57: /* Get information about an open file. */ { struct stat buf; if (fstat(getStreamFileDescriptor(taskData, args->Word()), &buf) < 0) raise_syscall(taskData, "fstat failed", errno); return getStatInfo(taskData, &buf); } case 58: /* Test access rights to a file. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); int amode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int res; res = access(name, amode); free(name); /* Return false if error, true if not. It's not clear that this is correct since there are several reasons why we might get -1 as the result. */ return Make_fixed_precision(taskData, res < 0 ? 0 : 1); } case 59: /* Change access rights. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int err, res; res = chmod(name, mode); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "chmod failed", err); return Make_fixed_precision(taskData, 0); } case 60: /* Change access rights on open file. */ { mode_t mode = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fchmod(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), mode) < 0) raise_syscall(taskData, "fchmod failed", errno); return Make_fixed_precision(taskData, 0); } case 61: /* Change owner and group. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); uid_t uid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); gid_t gid = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); int err, res; res = chown(name, uid, gid); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "chown failed", err); return Make_fixed_precision(taskData, 0); } case 62: /* Change owner and group on open file. */ { uid_t uid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); gid_t gid = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); if (fchown(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), uid, gid) < 0) raise_syscall(taskData, "fchown failed", errno); return Make_fixed_precision(taskData, 0); } case 63: /* Set access and modification times. We use utimes rather than utime since it allows us to be more accurate. There's a similar function in basicio which sets both the access and modification times to the same time. */ { char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); Handle hAccess = SAVE(DEREFHANDLE(args)->Get(1)); Handle hMod = SAVE(DEREFHANDLE(args)->Get(2)); struct timeval times[2]; /* We have a value in microseconds. We need to split it into seconds and microseconds. N.B. The arguments to div_longc and rem_longc are in reverse order. */ Handle hMillion = Make_arbitrary_precision(taskData, 1000000); unsigned secsAccess = get_C_ulong(taskData, div_longc(taskData, hMillion, hAccess)->Word()); unsigned usecsAccess = get_C_ulong(taskData, rem_longc(taskData, hMillion, hAccess)->Word()); unsigned secsMod = get_C_ulong(taskData, div_longc(taskData, hMillion, hMod)->Word()); unsigned usecsMod = get_C_ulong(taskData, rem_longc(taskData, hMillion, hMod)->Word()); int err, res; times[0].tv_sec = secsAccess; times[0].tv_usec = usecsAccess; times[1].tv_sec = secsMod; times[1].tv_usec = usecsMod; res = utimes(name, times); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "utimes failed", err); return Make_fixed_precision(taskData, 0); } case 64: /* Set access and modification times to the current time. This could be defined in terms of the previous call and Time.now but it could result in an error due to rounding. This is probably safer. */ { char *name = Poly_string_to_C_alloc(DEREFWORD(args)); int err, res; res = utimes(name, 0); err = errno; /* Save the error result in case free changes it. */ free(name); if (res < 0) raise_syscall(taskData, "utimes failed", err); return Make_fixed_precision(taskData, 0); } case 65: /* Truncate an open file. */ { int size = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (ftruncate(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), size) < 0) raise_syscall(taskData, "ftruncate failed", errno); return Make_fixed_precision(taskData, 0); } case 66: /* Get the configured limits for a file. */ { /* Look up the variable. May raise an exception. */ int nvar = findPathVar(taskData, DEREFHANDLE(args)->Get(1)); char *name = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0)); int err, res; /* Set errno to zero. If there is no limit pathconf returns -1 but does not change errno. */ errno = 0; res = pathconf(name, nvar); err = errno; /* Save the error result in case free changes it. */ free(name); /* We return -1 as a valid result indicating no limit. */ if (res < 0 && err != 0) raise_syscall(taskData, "pathconf failed", err); return Make_fixed_precision(taskData, res); } case 67: /* Get the configured limits for an open file. */ { /* Look up the variable. May raise an exception. */ int nvar = findPathVar(taskData, DEREFHANDLE(args)->Get(1)); errno = 0; /* Unchanged if there is no limit. */ int res = fpathconf(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), nvar); if (res < 0 && errno != 0) raise_syscall(taskData, "fpathconf failed", errno); return Make_fixed_precision(taskData, res); } /* Password and group entries. */ case 100: /* Get Password entry by name. */ { char pwName[200]; int length; struct passwd *pw; length = Poly_string_to_C(DEREFWORD(args), pwName, 200); if (length > 200) raise_syscall(taskData, "Password name too long", ENAMETOOLONG); pw = getpwnam(pwName); if (pw == NULL) raise_syscall(taskData, "Password entry not found", ENOENT); return makePasswordEntry(taskData, pw); } case 101: /* Get password entry by uid. */ { int uid = get_C_long(taskData, DEREFWORD(args)); struct passwd *pw = getpwuid(uid); if (pw == NULL) raise_syscall(taskData, "Password entry not found", ENOENT); return makePasswordEntry(taskData, pw); } case 102: /* Get group entry by name. */ { struct group *grp; char grpName[200]; int length; length = Poly_string_to_C(DEREFWORD(args), grpName, 200); if (length > 200) raise_syscall(taskData, "Group name too long", ENAMETOOLONG); grp = getgrnam(grpName); if (grp == NULL) raise_syscall(taskData, "Group entry not found", ENOENT); return makeGroupEntry(taskData, grp); } case 103: /* Get group entry by gid. */ { int gid = get_C_long(taskData, DEREFWORD(args)); struct group *grp = getgrgid(gid); if (grp == NULL) raise_syscall(taskData, "Group entry not found", ENOENT); return makeGroupEntry(taskData, grp); } /* IO Entries. */ case 110: /* Create a pipe. */ { int filedes[2]; if (pipe(filedes) < 0) raise_syscall(taskData, "pipe failed", errno); Handle strRead = wrapFileDescriptor(taskData, filedes[0]); Handle strWrite = wrapFileDescriptor(taskData, filedes[1]); Handle result = ALLOC(2); DEREFHANDLE(result)->Set(0, strRead->Word()); DEREFHANDLE(result)->Set(1, strWrite->Word()); return result; } case 111: /* Duplicate a file descriptor. */ { int srcFd = getStreamFileDescriptor(taskData, args->WordP()); int fd = dup(srcFd); if (fd < 0) raise_syscall(taskData, "dup failed", errno); return wrapFileDescriptor(taskData, fd); } case 112: /* Duplicate a file descriptor to a given entry. */ { int oldFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int newFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(1)); if (dup2(oldFd, newFd) < 0) raise_syscall(taskData, "dup2 failed", errno); return Make_fixed_precision(taskData, 0); } case 113: /* Duplicate a file descriptor to an entry equal to or greater than the given value. */ { int oldFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int baseFd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(1)); int newFd = fcntl(oldFd, F_DUPFD, baseFd); return wrapFileDescriptor(taskData, newFd); } case 114: /* Get the file descriptor flags. */ { int res = fcntl(getStreamFileDescriptor(taskData, args->Word()), F_GETFD); if (res < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, res); } case 115: /* Set the file descriptor flags. */ { int flags = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fcntl(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), F_SETFD, flags) < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, 0); } case 116: /* Get the file status and access flags. */ { int res = fcntl(getStreamFileDescriptor(taskData, args->Word()), F_GETFL); if (res < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, res); } case 117: /* Set the file status and access flags. */ { int flags = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (fcntl(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), F_SETFL, flags) < 0) raise_syscall(taskData, "fcntl failed", errno); return Make_fixed_precision(taskData, 0); } case 118: /* Seek to a position on the stream. */ { long position = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int whence = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); long newpos = lseek(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), position, whence); if (newpos < 0) raise_syscall(taskData, "lseek failed", errno); return Make_arbitrary_precision(taskData, (POLYSIGNED)newpos); // Position.int } case 119: /* Synchronise file contents. */ { if (fsync(getStreamFileDescriptor(taskData, args->Word())) < 0) raise_syscall(taskData, "fsync failed", errno); return Make_fixed_precision(taskData, 0); } case 120: /* get lock */ return lockCommand(taskData, F_GETLK, args); case 121: /* set lock */ return lockCommand(taskData, F_SETLK, args); case 122: /* wait for lock */ /* TODO: This may well block the whole process. We should look at the result and retry if need be. */ return lockCommand(taskData, F_SETLKW, args); /* TTY entries. */ case 150: /* Get attributes. */ return getTTYattrs(taskData, args); case 151: /* Set attributes. */ return setTTYattrs(taskData, args); case 152: /* Send a break. */ { int duration = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcsendbreak(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), duration) < 0) raise_syscall(taskData, "tcsendbreak failed", errno); return Make_fixed_precision(taskData, 0); } case 153: /* Wait for output to drain. */ { /* TODO: This will block the process. It really needs to check whether the stream has drained and run another process until it has. */ #ifdef HAVE_TCDRAIN if (tcdrain(getStreamFileDescriptor(taskData, args->Word())) < 0) raise_syscall(taskData, "tcdrain failed", errno); #else raise_syscall(taskData, "tcdrain is not implemented", 0); #endif return Make_fixed_precision(taskData, 0); } case 154: /* Flush terminal stream. */ { int qs = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcflush(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), qs) < 0) raise_syscall(taskData, "tcflush failed", errno); return Make_fixed_precision(taskData, 0); } case 155: /* Flow control. */ { int action = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcflow(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), action) < 0) raise_syscall(taskData, "tcflow failed", errno); return Make_fixed_precision(taskData, 0); } case 156: /* Get process group. */ { pid_t pid = tcgetpgrp(getStreamFileDescriptor(taskData, args->Word())); if (pid < 0) raise_syscall(taskData, "tcgetpgrp failed", errno); return Make_fixed_precision(taskData, pid); } case 157: /* Set process group. */ { pid_t pid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); if (tcsetpgrp(getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)), pid) < 0) raise_syscall(taskData, "tcsetpgrp failed", errno); return Make_fixed_precision(taskData, 0); } default: { char msg[100]; sprintf(msg, "Unknown unix-specific function: %d", c); raise_exception_string(taskData, EXC_Fail, msg); } } } // General interface to Unix OS-specific. Ideally the various cases will be made into // separate functions. POLYUNSIGNED PolyOSSpecificGeneral(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 = OS_spec_dispatch_c(taskData, pushedArg, pushedCode); } 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(); } POLYUNSIGNED PolyGetOSType() { return TAGGED(0).AsUnsigned(); // Return 0 for Unix } // Wait for the shorter of the times. // TODO: This should really wait for some event from the signal thread. class WaitUpto : public Waiter { public: WaitUpto(unsigned mSecs) : maxTime(mSecs), result(0), errcode(0) {} virtual void Wait(unsigned maxMillisecs) { useconds_t usec; if (maxTime < maxMillisecs) usec = maxTime * 1000; else usec = maxMillisecs * 1000; result = usleep(usec); if (result != 0) errcode = errno; } unsigned maxTime; int result; int errcode; }; // This waits for a period of up to a second. The actual time calculations are // done in ML. Takes the signal count as an argument and returns the last signal // count. This ensures that it does not miss any signals that arrive while in ML. POLYUNSIGNED PolyPosixSleep(FirstArgument threadId, PolyWord maxMillisecs, PolyWord sigCount) { TaskData *taskData = TaskData::FindTaskForId(threadId); ASSERT(taskData != 0); taskData->PreRTSCall(); Handle reset = taskData->saveVec.mark(); POLYUNSIGNED maxMilliseconds = maxMillisecs.UnTaggedUnsigned(); try { if (UNTAGGED_UNSIGNED(sigCount) == receivedSignalCount) { WaitUpto waiter(maxMilliseconds); processes->ThreadPauseForIO(taskData, &waiter); if (waiter.result != 0) { if (waiter.errcode != EINTR) raise_syscall(taskData, "sleep failed", waiter.errcode); } } } catch (...) { } // If an ML exception is raised taskData->saveVec.reset(reset); // Ensure the save vec is reset taskData->PostRTSCall(); return TAGGED(receivedSignalCount).AsUnsigned(); } Handle waitForProcess(TaskData *taskData, Handle args) /* Get result status of a child process. */ { TryAgain: // We should check for interrupts even if we're not going to block. processes->TestAnyEvents(taskData); int kind = get_C_long(taskData, DEREFHANDLE(args)->Get(0)); int pid = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); int callFlags = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); int flags = callFlags | WNOHANG; // Add in WNOHANG so we never block. pid_t pres = 0; int status = 0; switch (kind) { case 0: /* Wait for any child. */ pres = waitpid(-1, &status, flags); break; case 1: /* Wait for specific process. */ pres = waitpid(pid, &status, flags); break; case 2: /* Wait for any in current process group. */ pres = waitpid(0, &status, flags); break; case 3: /* Wait for child in given process group */ pres = waitpid(-pid, &status, flags); break; } if (pres < 0) { if (errno == EINTR) goto TryAgain; else raise_syscall(taskData, "wait failed", errno); } /* If the caller did not specify WNOHANG but there wasn't a child process waiting we have to block and come back here later. */ if (pres == 0 && !(callFlags & WNOHANG)) { processes->ThreadPause(taskData); goto TryAgain; } /* Construct the result tuple. */ { Handle result, pidHandle, resHandle; pidHandle = Make_fixed_precision(taskData, pres); // If the pid is zero status may not be a valid value and may overflow. resHandle = Make_fixed_precision(taskData, pres == 0 ? 0: status); result = ALLOC(2); DEREFHANDLE(result)->Set(0, DEREFWORD(pidHandle)); DEREFHANDLE(result)->Set(1, DEREFWORD(resHandle)); return result; } } static Handle makePasswordEntry(TaskData *taskData, struct passwd *pw) /* Return a password entry. */ { Handle nameHandle, uidHandle, gidHandle, homeHandle, shellHandle, result; nameHandle = SAVE(C_string_to_Poly(taskData, pw->pw_name)); uidHandle = Make_fixed_precision(taskData, pw->pw_uid); gidHandle = Make_fixed_precision(taskData, pw->pw_gid); homeHandle = SAVE(C_string_to_Poly(taskData, pw->pw_dir)); shellHandle = SAVE(C_string_to_Poly(taskData, pw->pw_shell)); result = ALLOC(5); DEREFHANDLE(result)->Set(0, nameHandle->Word()); DEREFHANDLE(result)->Set(1, uidHandle->Word()); DEREFHANDLE(result)->Set(2, gidHandle->Word()); DEREFHANDLE(result)->Set(3, homeHandle->Word()); DEREFHANDLE(result)->Set(4, shellHandle->Word()); return result; } static Handle makeGroupEntry(TaskData *taskData, struct group *grp) { Handle nameHandle, gidHandle, membersHandle, result; int i; char **p; nameHandle = SAVE(C_string_to_Poly(taskData, grp->gr_name)); gidHandle = Make_fixed_precision(taskData, grp->gr_gid); /* Group members. */ for (i=0, p = grp->gr_mem; *p != NULL; p++, i++); membersHandle = convert_string_list(taskData, i, grp->gr_mem); result = ALLOC(3); DEREFHANDLE(result)->Set(0, nameHandle->Word()); DEREFHANDLE(result)->Set(1, gidHandle->Word()); DEREFHANDLE(result)->Set(2, membersHandle->Word()); return result; } /* Make a cons cell for a pair of strings. */ // Doesn't currently reset the save vec so it's only safe for a small number // of cells. static void makeStringPairList(TaskData *taskData, Handle &list, const char *s1, const char *s2) { Handle nameHandle, valueHandle, pairHandle, next; /* This has to be done carefully to ensure we don't throw anything away if we garbage-collect and also to ensure that each object is fully initialised before the next object is created. */ /* Make the strings. */ nameHandle = SAVE(C_string_to_Poly(taskData, s1)); valueHandle = SAVE(C_string_to_Poly(taskData, s2)); /* Make the pair. */ pairHandle = ALLOC(2); DEREFHANDLE(pairHandle)->Set(0, nameHandle->Word()); DEREFHANDLE(pairHandle)->Set(1, valueHandle->Word()); /* Make the cons cell. */ next = ALLOC(SIZEOF(ML_Cons_Cell)); DEREFLISTHANDLE(next)->h = pairHandle->Word(); DEREFLISTHANDLE(next)->t = list->Word(); list = SAVE(next->Word()); } /* Return the uname information. */ static Handle getUname(TaskData *taskData) { #ifdef HAVE_SYS_UTSNAME_H struct utsname name; Handle list = SAVE(ListNull); if (uname(&name) < 0) raise_syscall(taskData, "uname failed", errno); makeStringPairList(taskData, list, "sysname", name.sysname); makeStringPairList(taskData, list, "nodename", name.nodename); makeStringPairList(taskData, list, "release", name.release); makeStringPairList(taskData, list, "version", name.version); makeStringPairList(taskData, list, "machine", name.machine); return list; #else raise_syscall(taskData, "uname not available on this machine", errno); #endif } /* Return the contents of a stat buffer. */ static Handle getStatInfo(TaskData *taskData, struct stat *buf) { int kind; /* Get the protection mode, masking off the file type info. */ Handle modeHandle = Make_fixed_precision(taskData, buf->st_mode & (S_IRWXU|S_IRWXG|S_IRWXO|S_ISUID|S_ISGID)); if (S_ISDIR(buf->st_mode)) kind = 1; else if (S_ISCHR(buf->st_mode)) kind = 2; else if (S_ISBLK(buf->st_mode)) kind = 3; else if (S_ISFIFO(buf->st_mode)) kind = 4; else if ((buf->st_mode & S_IFMT) == S_IFLNK) kind = 5; else if ((buf->st_mode & S_IFMT) == S_IFSOCK) kind = 6; else /* Regular. */ kind = 0; Handle kindHandle = Make_fixed_precision(taskData, kind); Handle inoHandle = Make_arbitrary_precision(taskData, buf->st_ino); Handle devHandle = Make_arbitrary_precision(taskData, buf->st_dev); Handle linkHandle = Make_fixed_precision(taskData, buf->st_nlink); Handle uidHandle = Make_fixed_precision(taskData, buf->st_uid); Handle gidHandle = Make_fixed_precision(taskData, buf->st_gid); Handle sizeHandle = Make_arbitrary_precision(taskData, buf->st_size); // Position.int Handle atimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,a), STAT_USECS(buf,a), 1000000); Handle mtimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,m), STAT_USECS(buf,m), 1000000); Handle ctimeHandle = Make_arb_from_pair_scaled(taskData, STAT_SECS(buf,c), STAT_USECS(buf,c), 1000000); Handle result = ALLOC(11); DEREFHANDLE(result)->Set(0, modeHandle->Word()); DEREFHANDLE(result)->Set(1, kindHandle->Word()); DEREFHANDLE(result)->Set(2, inoHandle->Word()); DEREFHANDLE(result)->Set(3, devHandle->Word()); DEREFHANDLE(result)->Set(4, linkHandle->Word()); DEREFHANDLE(result)->Set(5, uidHandle->Word()); DEREFHANDLE(result)->Set(6, gidHandle->Word()); DEREFHANDLE(result)->Set(7, sizeHandle->Word()); DEREFHANDLE(result)->Set(8, atimeHandle->Word()); DEREFHANDLE(result)->Set(9, mtimeHandle->Word()); DEREFHANDLE(result)->Set(10, ctimeHandle->Word()); return result; } static Handle getTTYattrs(TaskData *taskData, Handle args) { int fd = getStreamFileDescriptor(taskData, args->Word()); struct termios tios; speed_t ispeed, ospeed; Handle ifHandle, ofHandle, cfHandle, lfHandle, ccHandle; Handle isHandle, osHandle, result; if (tcgetattr(fd, &tios) < 0) raise_syscall(taskData, "tcgetattr failed", errno); /* Extract the speed entries. */ ospeed = cfgetospeed(&tios); ispeed = cfgetispeed(&tios); /* Set the speed entries to zero. In Solaris, at least, the speed is encoded in the flags and we don't want any confusion. The order of these functions is significant. */ cfsetospeed(&tios, B0); cfsetispeed(&tios, B0); /* Convert the values to ML representation. */ ifHandle = Make_fixed_precision(taskData, tios.c_iflag); ofHandle = Make_fixed_precision(taskData, tios.c_oflag); cfHandle = Make_fixed_precision(taskData, tios.c_cflag); lfHandle = Make_fixed_precision(taskData, tios.c_lflag); /* The cc vector is treated as a string. */ ccHandle = SAVE(C_string_to_Poly(taskData, (const char *)tios.c_cc, NCCS)); isHandle = Make_fixed_precision(taskData, ispeed); osHandle = Make_fixed_precision(taskData, ospeed); /* We can now create the result tuple. */ result = ALLOC(7); DEREFHANDLE(result)->Set(0, ifHandle->Word()); DEREFHANDLE(result)->Set(1, ofHandle->Word()); DEREFHANDLE(result)->Set(2, cfHandle->Word()); DEREFHANDLE(result)->Set(3, lfHandle->Word()); DEREFHANDLE(result)->Set(4, ccHandle->Word()); DEREFHANDLE(result)->Set(5, isHandle->Word()); DEREFHANDLE(result)->Set(6, osHandle->Word()); return result; } /* Assemble the tios structure from the arguments and set the TTY attributes. */ static Handle setTTYattrs(TaskData *taskData, Handle args) { int fd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); int actions = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); struct termios tios; speed_t ispeed, ospeed; /* Make sure anything unset is zero. It might be better to call tcgetattr instead. */ memset(&tios, 0, sizeof(tios)); tios.c_iflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(2)); tios.c_oflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(3)); tios.c_cflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(4)); tios.c_lflag = get_C_ulong(taskData, DEREFHANDLE(args)->Get(5)); /* The cc vector should be a string of exactly NCCS characters. It may well contain nulls so we can't use Poly_string_to_C to copy it. */ PolyWord ccv = DEREFHANDLE(args)->Get(6); if (ccv.IsTagged()) // Just to check. raise_syscall(taskData, "Incorrect cc vector", EINVAL); PolyStringObject * ccvs = (PolyStringObject *)ccv.AsObjPtr(); if (ccvs->length != NCCS) // Just to check. */ raise_syscall(taskData, "Incorrect cc vector", EINVAL); memcpy(tios.c_cc, ccvs->chars, NCCS); ispeed = get_C_ulong(taskData, DEREFHANDLE(args)->Get(7)); ospeed = get_C_ulong(taskData, DEREFHANDLE(args)->Get(8)); if (cfsetispeed(&tios, ispeed) < 0) raise_syscall(taskData, "cfsetispeed failed", errno); if (cfsetospeed(&tios, ospeed) < 0) raise_syscall(taskData, "cfsetospeed failed", errno); /* Now it's all set we can call tcsetattr to do the work. */ if (tcsetattr(fd, actions, &tios) < 0) raise_syscall(taskData, "tcsetattr failed", errno); return Make_fixed_precision(taskData, 0); } /* Lock/unlock/test file locks. Returns the, possibly modified, argument structure. */ static Handle lockCommand(TaskData *taskData, int cmd, Handle args) { int fd = getStreamFileDescriptor(taskData, DEREFHANDLE(args)->Get(0)); struct flock lock; memset(&lock, 0, sizeof(lock)); /* Make sure unused fields are zero. */ lock.l_type = get_C_long(taskData, DEREFHANDLE(args)->Get(1)); lock.l_whence = get_C_long(taskData, DEREFHANDLE(args)->Get(2)); lock.l_start = get_C_long(taskData, DEREFHANDLE(args)->Get(3)); lock.l_len = get_C_long(taskData, DEREFHANDLE(args)->Get(4)); lock.l_pid = get_C_long(taskData, DEREFHANDLE(args)->Get(5)); if (fcntl(fd, cmd, &lock) < 0) raise_syscall(taskData, "fcntl failed", errno); /* Construct the result. */ Handle typeHandle = Make_fixed_precision(taskData, lock.l_type); Handle whenceHandle = Make_fixed_precision(taskData, lock.l_whence); Handle startHandle = Make_arbitrary_precision(taskData, (POLYUNSIGNED)lock.l_start); // Position.int Handle lenHandle = Make_arbitrary_precision(taskData, (POLYUNSIGNED)lock.l_len); // Position.int Handle pidHandle = Make_fixed_precision(taskData, lock.l_pid); Handle result = ALLOC(5); DEREFHANDLE(result)->Set(0, typeHandle->Word()); DEREFHANDLE(result)->Set(1, whenceHandle->Word()); DEREFHANDLE(result)->Set(2, startHandle->Word()); DEREFHANDLE(result)->Set(3, lenHandle->Word()); DEREFHANDLE(result)->Set(4, pidHandle->Word()); return result; } /* This table maps string arguments for sysconf into the corresponding constants. */ /* These are highly OS dependent. It has been configured on Solaris 2.8, Linux Redhat 5.2 and FreeBSD 3.4. */ static struct { const char *saName; int saVal; } sysArgTable[] = { { "_SC_ARG_MAX", _SC_ARG_MAX }, { "_SC_CHILD_MAX", _SC_CHILD_MAX }, { "_SC_CLK_TCK", _SC_CLK_TCK }, { "_SC_NGROUPS_MAX", _SC_NGROUPS_MAX }, { "_SC_OPEN_MAX", _SC_OPEN_MAX }, { "_SC_JOB_CONTROL", _SC_JOB_CONTROL }, { "_SC_SAVED_IDS", _SC_SAVED_IDS }, { "_SC_VERSION", _SC_VERSION }, #ifdef _SC_PASS_MAX { "_SC_PASS_MAX", _SC_PASS_MAX }, #endif #ifdef _SC_LOGNAME_MAX { "_SC_LOGNAME_MAX", _SC_LOGNAME_MAX }, #endif #ifdef _SC_PAGESIZE { "_SC_PAGESIZE", _SC_PAGESIZE }, #endif #ifdef _SC_XOPEN_VERSION { "_SC_XOPEN_VERSION", _SC_XOPEN_VERSION }, #endif #ifdef _SC_NPROCESSORS_CONF { "_SC_NPROCESSORS_CONF", _SC_NPROCESSORS_CONF }, #endif #ifdef _SC_NPROCESSORS_ONLN { "_SC_NPROCESSORS_ONLN", _SC_NPROCESSORS_ONLN }, #endif #ifdef _SC_STREAM_MAX { "_SC_STREAM_MAX", _SC_STREAM_MAX }, #endif #ifdef _SC_TZNAME_MAX { "_SC_TZNAME_MAX", _SC_TZNAME_MAX }, #endif #ifdef _SC_AIO_LISTIO_MAX { "_SC_AIO_LISTIO_MAX", _SC_AIO_LISTIO_MAX }, #endif #ifdef _SC_AIO_MAX { "_SC_AIO_MAX", _SC_AIO_MAX }, #endif #ifdef _SC_AIO_PRIO_DELTA_MAX { "_SC_AIO_PRIO_DELTA_MAX", _SC_AIO_PRIO_DELTA_MAX }, #endif #ifdef _SC_ASYNCHRONOUS_IO { "_SC_ASYNCHRONOUS_IO", _SC_ASYNCHRONOUS_IO }, #endif #ifdef _SC_DELAYTIMER_MAX { "_SC_DELAYTIMER_MAX", _SC_DELAYTIMER_MAX }, #endif #ifdef _SC_FSYNC { "_SC_FSYNC", _SC_FSYNC }, #endif #ifdef _SC_MAPPED_FILES { "_SC_MAPPED_FILES", _SC_MAPPED_FILES }, #endif #ifdef _SC_MEMLOCK { "_SC_MEMLOCK", _SC_MEMLOCK }, #endif #ifdef _SC_MEMLOCK_RANGE { "_SC_MEMLOCK_RANGE", _SC_MEMLOCK_RANGE }, #endif #ifdef _SC_MEMORY_PROTECTION { "_SC_MEMORY_PROTECTION", _SC_MEMORY_PROTECTION }, #endif #ifdef _SC_MESSAGE_PASSING { "_SC_MESSAGE_PASSING", _SC_MESSAGE_PASSING }, #endif #ifdef _SC_MQ_OPEN_MAX { "_SC_MQ_OPEN_MAX", _SC_MQ_OPEN_MAX }, #endif #ifdef _SC_MQ_PRIO_MAX { "_SC_MQ_PRIO_MAX", _SC_MQ_PRIO_MAX }, #endif #ifdef _SC_PRIORITIZED_IO { "_SC_PRIORITIZED_IO", _SC_PRIORITIZED_IO }, #endif #ifdef _SC_PRIORITY_SCHEDULING { "_SC_PRIORITY_SCHEDULING", _SC_PRIORITY_SCHEDULING }, #endif #ifdef _SC_REALTIME_SIGNALS { "_SC_REALTIME_SIGNALS", _SC_REALTIME_SIGNALS }, #endif #ifdef _SC_RTSIG_MAX { "_SC_RTSIG_MAX", _SC_RTSIG_MAX }, #endif #ifdef _SC_SEMAPHORES { "_SC_SEMAPHORES", _SC_SEMAPHORES }, #endif #ifdef _SC_SEM_NSEMS_MAX { "_SC_SEM_NSEMS_MAX", _SC_SEM_NSEMS_MAX }, #endif #ifdef _SC_SEM_VALUE_MAX { "_SC_SEM_VALUE_MAX", _SC_SEM_VALUE_MAX }, #endif #ifdef _SC_SHARED_MEMORY_OBJECTS { "_SC_SHARED_MEMORY_OBJECTS", _SC_SHARED_MEMORY_OBJECTS }, #endif #ifdef _SC_SIGQUEUE_MAX { "_SC_SIGQUEUE_MAX", _SC_SIGQUEUE_MAX }, #endif #ifdef _SC_SIGRT_MIN { "_SC_SIGRT_MIN", _SC_SIGRT_MIN }, #endif #ifdef _SC_SIGRT_MAX { "_SC_SIGRT_MAX", _SC_SIGRT_MAX }, #endif #ifdef _SC_SYNCHRONIZED_IO { "_SC_SYNCHRONIZED_IO", _SC_SYNCHRONIZED_IO }, #endif #ifdef _SC_TIMERS { "_SC_TIMERS", _SC_TIMERS }, #endif #ifdef _SC_TIMER_MAX { "_SC_TIMER_MAX", _SC_TIMER_MAX }, #endif #ifdef _SC_2_C_BIND { "_SC_2_C_BIND", _SC_2_C_BIND }, #endif #ifdef _SC_2_C_DEV { "_SC_2_C_DEV", _SC_2_C_DEV }, #endif #ifdef _SC_2_C_VERSION { "_SC_2_C_VERSION", _SC_2_C_VERSION }, #endif #ifdef _SC_2_FORT_DEV { "_SC_2_FORT_DEV", _SC_2_FORT_DEV }, #endif #ifdef _SC_2_FORT_RUN { "_SC_2_FORT_RUN", _SC_2_FORT_RUN }, #endif #ifdef _SC_2_LOCALEDEF { "_SC_2_LOCALEDEF", _SC_2_LOCALEDEF }, #endif #ifdef _SC_2_SW_DEV { "_SC_2_SW_DEV", _SC_2_SW_DEV }, #endif #ifdef _SC_2_UPE { "_SC_2_UPE", _SC_2_UPE }, #endif #ifdef _SC_2_VERSION { "_SC_2_VERSION", _SC_2_VERSION }, #endif #ifdef _SC_BC_BASE_MAX { "_SC_BC_BASE_MAX", _SC_BC_BASE_MAX }, #endif #ifdef _SC_BC_DIM_MAX { "_SC_BC_DIM_MAX", _SC_BC_DIM_MAX }, #endif #ifdef _SC_BC_SCALE_MAX { "_SC_BC_SCALE_MAX", _SC_BC_SCALE_MAX }, #endif #ifdef _SC_BC_STRING_MAX { "_SC_BC_STRING_MAX", _SC_BC_STRING_MAX }, #endif #ifdef _SC_COLL_WEIGHTS_MAX { "_SC_COLL_WEIGHTS_MAX", _SC_COLL_WEIGHTS_MAX }, #endif #ifdef _SC_EXPR_NEST_MAX { "_SC_EXPR_NEST_MAX", _SC_EXPR_NEST_MAX }, #endif #ifdef _SC_LINE_MAX { "_SC_LINE_MAX", _SC_LINE_MAX }, #endif #ifdef _SC_RE_DUP_MAX { "_SC_RE_DUP_MAX", _SC_RE_DUP_MAX }, #endif #ifdef _SC_XOPEN_CRYPT { "_SC_XOPEN_CRYPT", _SC_XOPEN_CRYPT }, #endif #ifdef _SC_XOPEN_ENH_I18N { "_SC_XOPEN_ENH_I18N", _SC_XOPEN_ENH_I18N }, #endif #ifdef _SC_XOPEN_SHM { "_SC_XOPEN_SHM", _SC_XOPEN_SHM }, #endif #ifdef _SC_2_CHAR_TERM { "_SC_2_CHAR_TERM", _SC_2_CHAR_TERM }, #endif #ifdef _SC_XOPEN_XCU_VERSION { "_SC_XOPEN_XCU_VERSION", _SC_XOPEN_XCU_VERSION }, #endif #ifdef _SC_ATEXIT_MAX { "_SC_ATEXIT_MAX", _SC_ATEXIT_MAX }, #endif #ifdef _SC_IOV_MAX { "_SC_IOV_MAX", _SC_IOV_MAX }, #endif #ifdef _SC_XOPEN_UNIX { "_SC_XOPEN_UNIX", _SC_XOPEN_UNIX }, #endif #ifdef _SC_PAGE_SIZE { "_SC_PAGE_SIZE", _SC_PAGE_SIZE }, #endif #ifdef _SC_T_IOV_MAX { "_SC_T_IOV_MAX", _SC_T_IOV_MAX }, #endif #ifdef _SC_PHYS_PAGES { "_SC_PHYS_PAGES", _SC_PHYS_PAGES }, #endif #ifdef _SC_AVPHYS_PAGES { "_SC_AVPHYS_PAGES", _SC_AVPHYS_PAGES }, #endif #ifdef _SC_COHER_BLKSZ { "_SC_COHER_BLKSZ", _SC_COHER_BLKSZ }, #endif #ifdef _SC_SPLIT_CACHE { "_SC_SPLIT_CACHE", _SC_SPLIT_CACHE }, #endif #ifdef _SC_ICACHE_SZ { "_SC_ICACHE_SZ", _SC_ICACHE_SZ }, #endif #ifdef _SC_DCACHE_SZ { "_SC_DCACHE_SZ", _SC_DCACHE_SZ }, #endif #ifdef _SC_ICACHE_LINESZ { "_SC_ICACHE_LINESZ", _SC_ICACHE_LINESZ }, #endif #ifdef _SC_DCACHE_LINESZ { "_SC_DCACHE_LINESZ", _SC_DCACHE_LINESZ }, #endif #ifdef _SC_ICACHE_BLKSZ { "_SC_ICACHE_BLKSZ", _SC_ICACHE_BLKSZ }, #endif #ifdef _SC_DCACHE_BLKSZ { "_SC_DCACHE_BLKSZ", _SC_DCACHE_BLKSZ }, #endif #ifdef _SC_DCACHE_TBLKSZ { "_SC_DCACHE_TBLKSZ", _SC_DCACHE_TBLKSZ }, #endif #ifdef _SC_ICACHE_ASSOC { "_SC_ICACHE_ASSOC", _SC_ICACHE_ASSOC }, #endif #ifdef _SC_DCACHE_ASSOC { "_SC_DCACHE_ASSOC", _SC_DCACHE_ASSOC }, #endif #ifdef _SC_MAXPID { "_SC_MAXPID", _SC_MAXPID }, #endif #ifdef _SC_STACK_PROT { "_SC_STACK_PROT", _SC_STACK_PROT }, #endif #ifdef _SC_THREAD_DESTRUCTOR_ITERATIONS { "_SC_THREAD_DESTRUCTOR_ITERATIONS", _SC_THREAD_DESTRUCTOR_ITERATIONS }, #endif #ifdef _SC_GETGR_R_SIZE_MAX { "_SC_GETGR_R_SIZE_MAX", _SC_GETGR_R_SIZE_MAX }, #endif #ifdef _SC_GETPW_R_SIZE_MAX { "_SC_GETPW_R_SIZE_MAX", _SC_GETPW_R_SIZE_MAX }, #endif #ifdef _SC_LOGIN_NAME_MAX { "_SC_LOGIN_NAME_MAX", _SC_LOGIN_NAME_MAX }, #endif #ifdef _SC_THREAD_KEYS_MAX { "_SC_THREAD_KEYS_MAX", _SC_THREAD_KEYS_MAX }, #endif #ifdef _SC_THREAD_STACK_MI { "_SC_THREAD_STACK_MIN", _SC_THREAD_STACK_MIN }, #endif #ifdef _SC_THREAD_THREADS_MAX { "_SC_THREAD_THREADS_MAX", _SC_THREAD_THREADS_MAX }, #endif #ifdef _SC_THREAD_ATTR_STACKADDR { "_SC_THREAD_ATTR_STACKADDR", _SC_THREAD_ATTR_STACKADDR }, #endif #ifdef _SC_THREAD_ATTR_STACKSIZE { "_SC_THREAD_ATTR_STACKSIZE", _SC_THREAD_ATTR_STACKSIZE }, #endif #ifdef _SC_THREAD_PRIORITY_SCHEDULING { "_SC_THREAD_PRIORITY_SCHEDULING", _SC_THREAD_PRIORITY_SCHEDULING }, #endif #ifdef _SC_THREAD_PRIO_INHERIT { "_SC_THREAD_PRIO_INHERIT", _SC_THREAD_PRIO_INHERIT }, #endif #ifdef _SC_THREAD_PRIO_PROTECT { "_SC_THREAD_PRIO_PROTECT", _SC_THREAD_PRIO_PROTECT }, #endif #ifdef _SC_THREAD_PROCESS_SHARED { "_SC_THREAD_PROCESS_SHARED", _SC_THREAD_PROCESS_SHARED }, #endif #ifdef _SC_XOPEN_LEGACY { "_SC_XOPEN_LEGACY", _SC_XOPEN_LEGACY }, #endif #ifdef _SC_XOPEN_REALTIME { "_SC_XOPEN_REALTIME", _SC_XOPEN_REALTIME }, #endif #ifdef _SC_XOPEN_REALTIME_THREADS { "_SC_XOPEN_REALTIME_THREADS", _SC_XOPEN_REALTIME_THREADS }, #endif #ifdef _SC_XBS5_ILP32_OFF32 { "_SC_XBS5_ILP32_OFF32", _SC_XBS5_ILP32_OFF32 }, #endif #ifdef _SC_XBS5_ILP32_OFFBIG { "_SC_XBS5_ILP32_OFFBIG", _SC_XBS5_ILP32_OFFBIG }, #endif #ifdef _SC_XBS5_LP64_OFF64 { "_SC_XBS5_LP64_OFF64", _SC_XBS5_LP64_OFF64 }, #endif #ifdef _SC_XBS5_LPBIG_OFFBIG { "_SC_XBS5_LPBIG_OFFBIG", _SC_XBS5_LPBIG_OFFBIG }, #endif #ifdef _SC_EQUIV_CLASS_MAX { "_SC_EQUIV_CLASS_MAX", _SC_EQUIV_CLASS_MAX }, #endif #ifdef _SC_CHARCLASS_NAME_MAX { "_SC_CHARCLASS_NAME_MAX", _SC_CHARCLASS_NAME_MAX }, #endif #ifdef _SC_PII { "_SC_PII", _SC_PII }, #endif #ifdef _SC_PII_XTI { "_SC_PII_XTI", _SC_PII_XTI }, #endif #ifdef _SC_PII_SOCKET { "_SC_PII_SOCKET", _SC_PII_SOCKET }, #endif #ifdef _SC_PII_INTERNET { "_SC_PII_INTERNET", _SC_PII_INTERNET }, #endif #ifdef _SC_PII_OSI { "_SC_PII_OSI", _SC_PII_OSI }, #endif #ifdef _SC_POLL { "_SC_POLL", _SC_POLL }, #endif #ifdef _SC_SELECT { "_SC_SELECT", _SC_SELECT }, #endif #ifdef _SC_UIO_MAXIOV { "_SC_UIO_MAXIOV", _SC_UIO_MAXIOV }, #endif #ifdef _SC_PII_INTERNET_STREAM { "_SC_PII_INTERNET_STREAM", _SC_PII_INTERNET_STREAM }, #endif #ifdef _SC_PII_INTERNET_DGRAM { "_SC_PII_INTERNET_DGRAM", _SC_PII_INTERNET_DGRAM }, #endif #ifdef _SC_PII_OSI_COTS { "_SC_PII_OSI_COTS", _SC_PII_OSI_COTS }, #endif #ifdef _SC_PII_OSI_CLTS { "_SC_PII_OSI_CLTS", _SC_PII_OSI_CLTS }, #endif #ifdef _SC_PII_OSI_M { "_SC_PII_OSI_M", _SC_PII_OSI_M }, #endif #ifdef _SC_T_IOV_MAX { "_SC_T_IOV_MAX", _SC_T_IOV_MAX }, #endif #ifdef _SC_THREADS { "_SC_THREADS", _SC_THREADS }, #endif #ifdef _SC_THREAD_SAFE_FUNCTIONS { "_SC_THREAD_SAFE_FUNCTIONS", _SC_THREAD_SAFE_FUNCTIONS }, #endif #ifdef _SC_TTY_NAME_MAX { "_SC_TTY_NAME_MAX", _SC_TTY_NAME_MAX }, #endif #ifdef _SC_XOPEN_XPG2 { "_SC_XOPEN_XPG2", _SC_XOPEN_XPG2 }, #endif #ifdef _SC_XOPEN_XPG3 { "_SC_XOPEN_XPG3", _SC_XOPEN_XPG3 }, #endif #ifdef _SC_XOPEN_XPG4 { "_SC_XOPEN_XPG4", _SC_XOPEN_XPG4 }, #endif #ifdef _SC_CHAR_BIT { "_SC_CHAR_BIT", _SC_CHAR_BIT }, #endif #ifdef _SC_CHAR_MAX { "_SC_CHAR_MAX", _SC_CHAR_MAX }, #endif #ifdef _SC_CHAR_MIN { "_SC_CHAR_MIN", _SC_CHAR_MIN }, #endif #ifdef _SC_INT_MAX { "_SC_INT_MAX", _SC_INT_MAX }, #endif #ifdef _SC_INT_MIN { "_SC_INT_MIN", _SC_INT_MIN }, #endif #ifdef _SC_LONG_BIT { "_SC_LONG_BIT", _SC_LONG_BIT }, #endif #ifdef _SC_WORD_BIT { "_SC_WORD_BIT", _SC_WORD_BIT }, #endif #ifdef _SC_MB_LEN_MAX { "_SC_MB_LEN_MAX", _SC_MB_LEN_MAX }, #endif #ifdef _SC_NZERO { "_SC_NZERO", _SC_NZERO }, #endif #ifdef _SC_SSIZE_MAX { "_SC_SSIZE_MAX", _SC_SSIZE_MAX }, #endif #ifdef _SC_SCHAR_MAX { "_SC_SCHAR_MAX", _SC_SCHAR_MAX }, #endif #ifdef _SC_SCHAR_MIN { "_SC_SCHAR_MIN", _SC_SCHAR_MIN }, #endif #ifdef _SC_SHRT_MAX { "_SC_SHRT_MAX", _SC_SHRT_MAX }, #endif #ifdef _SC_SHRT_MIN { "_SC_SHRT_MIN", _SC_SHRT_MIN }, #endif #ifdef _SC_UCHAR_MAX { "_SC_UCHAR_MAX", _SC_UCHAR_MAX }, #endif #ifdef _SC_UINT_MAX { "_SC_UINT_MAX", _SC_UINT_MAX }, #endif #ifdef _SC_ULONG_MAX { "_SC_ULONG_MAX", _SC_ULONG_MAX }, #endif #ifdef _SC_USHRT_MAX { "_SC_USHRT_MAX", _SC_USHRT_MAX }, #endif #ifdef _SC_NL_ARGMAX { "_SC_NL_ARGMAX", _SC_NL_ARGMAX }, #endif #ifdef _SC_NL_LANGMAX { "_SC_NL_LANGMAX", _SC_NL_LANGMAX }, #endif #ifdef _SC_NL_MSGMAX { "_SC_NL_MSGMAX", _SC_NL_MSGMAX }, #endif #ifdef _SC_NL_NMAX { "_SC_NL_NMAX", _SC_NL_NMAX }, #endif #ifdef _SC_NL_SETMAX { "_SC_NL_SETMAX", _SC_NL_SETMAX }, #endif }; static Handle getSysConf(TaskData *taskData, Handle args) { char argName[200]; int length; unsigned i; long res; length = Poly_string_to_C(DEREFWORD(args), argName, 200); if (length > 200) raise_syscall(taskData, "Argument name too long", ENAMETOOLONG); for (i = 0; i < sizeof(sysArgTable)/sizeof(sysArgTable[0]); i++) { if (strcmp(argName, sysArgTable[i].saName) == 0) break; /* See if it matches without the _SC_ at the beginning. */ if (strcmp(argName, sysArgTable[i].saName+4) == 0) break; } if (i == sizeof(sysArgTable)/sizeof(sysArgTable[0])) raise_syscall(taskData, "sysconf argument not found", EINVAL); errno = 0; /* Sysconf may return -1 without updating errno. */ res = sysconf(sysArgTable[i].saVal); if (res < 0) raise_syscall(taskData, "sysconf failed", errno); return Make_fixed_precision(taskData, (POLYUNSIGNED)res); } static struct { const char *pcName; int pcVal; } pathConfTable[] = { { "_PC_LINK_MAX", _PC_LINK_MAX }, { "_PC_MAX_CANON", _PC_MAX_CANON }, { "_PC_MAX_INPUT", _PC_MAX_INPUT }, { "_PC_NAME_MAX", _PC_NAME_MAX }, { "_PC_PATH_MAX", _PC_PATH_MAX }, { "_PC_PIPE_BUF", _PC_PIPE_BUF }, { "_PC_NO_TRUNC", _PC_NO_TRUNC }, { "_PC_VDISABLE", _PC_VDISABLE }, { "_PC_CHOWN_RESTRICTED", _PC_CHOWN_RESTRICTED }, #ifdef _PC_ASYNC_IO { "_PC_ASYNC_IO", _PC_ASYNC_IO }, #endif #ifdef _PC_PRIO_IO { "_PC_PRIO_IO", _PC_PRIO_IO }, #endif #ifdef _PC_SYNC_IO { "_PC_SYNC_IO", _PC_SYNC_IO }, #endif #ifdef _PC_FILESIZEBITS { "_PC_FILESIZEBITS", _PC_FILESIZEBITS }, #endif #ifdef _PC_SOCK_MAXBUF { "_PC_SOCK_MAXBUF", _PC_SOCK_MAXBUF }, #endif }; /* Look up a path variable in the table. */ static int findPathVar(TaskData *taskData, PolyWord ps) { char argName[200]; int length; unsigned i; length = Poly_string_to_C(ps, argName, 200); if (length > 200) raise_syscall(taskData, "Argument name too long", ENAMETOOLONG); for (i = 0; i < sizeof(pathConfTable)/sizeof(pathConfTable[0]); i++) { if (strcmp(argName, pathConfTable[i].pcName) == 0) return pathConfTable[i].pcVal; /* See if it matches without the _PC_ at the beginning. */ if (strcmp(argName, pathConfTable[i].pcName+4) == 0) return pathConfTable[i].pcVal; } raise_syscall(taskData, "pathconf argument not found", EINVAL); } struct _entrypts osSpecificEPT[] = { { "PolyGetOSType", (polyRTSFunction)&PolyGetOSType}, { "PolyOSSpecificGeneral", (polyRTSFunction)&PolyOSSpecificGeneral}, { "PolyPosixSleep", (polyRTSFunction)&PolyPosixSleep}, { NULL, NULL} // End of list. }; class UnixSpecific: public RtsModule { public: virtual void Init(void); }; // Declare this. It will be automatically added to the table. static UnixSpecific unixModule; void UnixSpecific::Init(void) { struct sigaction sigcatch; /* Ignore SIGPIPE - return any errors as failure to write. */ memset(&sigcatch, 0, sizeof(sigcatch)); sigcatch.sa_handler = SIG_IGN; sigaction(SIGPIPE, &sigcatch, NULL); } diff --git a/libpolyml/x86_dep.cpp b/libpolyml/x86_dep.cpp index 53827520..48300ded 100644 --- a/libpolyml/x86_dep.cpp +++ b/libpolyml/x86_dep.cpp @@ -1,1465 +1,1465 @@ /* Title: Machine dependent code for i386 and X64 under Windows and Unix Copyright (c) 2000-7 Cambridge University Technical Services Limited Further work copyright David C. J. Matthews 2011-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_STDLIB_H #include #endif #include #ifdef HAVE_SIGNAL_H #include #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 #if (defined(_WIN32)) #include #include #endif #include "globals.h" #include "run_time.h" #include "diagnostics.h" #include "processes.h" #include "profiling.h" #include "machine_dep.h" #include "scanaddrs.h" #include "memmgr.h" #include "rtsentry.h" #include "sys.h" // Temporary /********************************************************************** * * Register usage: * * %Reax: First argument to function. Result of function call. * %Rebx: Second argument to function. * %Recx: General register * %Redx: Closure pointer in call. * %Rebp: Points to memory used for extra registers * %Resi: General register. * %Redi: General register. * %Resp: Stack pointer. * The following apply only on the X64 * %R8: Third argument to function * %R9: Fourth argument to function * %R10: Fifth argument to function * %R11: General register * %R12: General register * %R13: General register * %R14: General register * %R15: Memory allocation pointer * **********************************************************************/ #ifdef HOSTARCHITECTURE_X86_64 struct fpSaveArea { double fpregister[7]; // Save area for xmm0-6 }; #else // Structure of floating point save area. // This is dictated by the hardware. typedef byte fpregister[10]; struct fpSaveArea { unsigned short cw; unsigned short _unused0; unsigned short sw; unsigned short _unused1; unsigned short tw; unsigned short _unused2; unsigned fip; unsigned short fcs0; unsigned short _unused3; unsigned foo; unsigned short fcs1; unsigned short _unused4; fpregister registers[8]; }; #endif /* the amount of ML stack space to reserve for registers, C exception handling etc. The compiler requires us to reserve 2 stack-frames worth (2 * 20 words). We actually reserve slightly more than this. */ #if (!defined(_WIN32) && !defined(HAVE_SIGALTSTACK)) // If we can't handle signals on a separate stack make sure there's space // on the Poly stack. #define OVERFLOW_STACK_SIZE (50+1024) #else #define OVERFLOW_STACK_SIZE 50 #endif union stackItem { /* #ifndef POLYML32IN64 stackItem(PolyWord v) { words[0] = v.AsUnsigned(); }; stackItem() { words[0] = TAGGED(0).AsUnsigned(); } POLYUNSIGNED words[1]; #else // In 32-in-64 we need to clear the second PolyWord. This assumes little-endian. stackItem(PolyWord v) { words[0] = v.AsUnsigned(); words[1] = 0; }; stackItem() { words[0] = TAGGED(0).AsUnsigned(); words[1] = 0; } POLYUNSIGNED words[2]; #endif */ stackItem(PolyWord v) { argValue = v.AsUnsigned(); } stackItem() { argValue = TAGGED(0).AsUnsigned(); } // These return the low order word. PolyWord w()const { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } operator PolyWord () { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } POLYCODEPTR codeAddr; // Return addresses stackItem *stackAddr; // Stack addresses uintptr_t argValue; // Treat an address as an int }; class X86TaskData; // This is passed as the argument vector to X86AsmSwitchToPoly. // The offsets are built into the assembly code and the code-generator. // localMpointer and stackPtr are updated before control returns to C. typedef struct _AssemblyArgs { public: PolyWord *localMpointer; // Allocation ptr + 1 word stackItem *handlerRegister; // Current exception handler PolyWord *localMbottom; // Base of memory + 1 word stackItem *stackLimit; // Lower limit of stack stackItem exceptionPacket; // Set if there is an exception byte unusedRequestCode; // No longer used. byte unusedFlag; // No longer used byte returnReason; // Reason for returning from ML. byte unusedRestore; // No longer used. uintptr_t saveCStack; // Saved C stack frame. PolyWord threadId; // My thread id. Saves having to call into RTS for it. stackItem *stackPtr; // Current stack pointer byte *noLongerUsed; // Now removed byte *heapOverFlowCall; // These are filled in with the functions. byte *stackOverFlowCall; byte *stackOverFlowCallEx; // Saved registers, where applicable. stackItem p_rax; stackItem p_rbx; stackItem p_rcx; stackItem p_rdx; stackItem p_rsi; stackItem p_rdi; #ifdef HOSTARCHITECTURE_X86_64 stackItem p_r8; stackItem p_r9; stackItem p_r10; stackItem p_r11; stackItem p_r12; stackItem p_r13; stackItem p_r14; #endif struct fpSaveArea p_fp; } AssemblyArgs; // These next few are temporarily added for the interpreter // This duplicates some code in reals.cpp but is now updated. #define DOUBLESIZE (sizeof(double)/sizeof(POLYUNSIGNED)) union realdb { double dble; POLYUNSIGNED puns[DOUBLESIZE]; }; #define LGWORDSIZE (sizeof(uintptr_t) / sizeof(PolyWord)) class X86TaskData: public TaskData { public: X86TaskData(); unsigned allocReg; // The register to take the allocated space. POLYUNSIGNED allocWords; // The words to allocate. Handle callBackResult; AssemblyArgs assemblyInterface; int saveRegisterMask; // Registers that need to be updated by a GC. virtual void GarbageCollect(ScanAddress *process); void ScanStackAddress(ScanAddress *process, stackItem &val, StackSpace *stack); virtual Handle EnterPolyCode(); // Start running ML virtual void InterruptCode(); virtual bool AddTimeProfileCount(SIGNALCONTEXT *context); virtual void InitStackFrame(TaskData *parentTask, Handle proc, Handle arg); virtual void SetException(poly_exn *exc); // Release a mutex in exactly the same way as compiler code virtual Handle AtomicIncrement(Handle mutexp); virtual void AtomicReset(Handle mutexp); // Return the minimum space occupied by the stack. Used when setting a limit. // N.B. This is PolyWords not native words. virtual uintptr_t currentStackSpace(void) const { return (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE*sizeof(uintptr_t)/sizeof(PolyWord); } // Increment the profile count for an allocation. Also now used for mutex contention. virtual void addProfileCount(POLYUNSIGNED words) { add_count(this, assemblyInterface.stackPtr[0].codeAddr, words); } // PreRTSCall: After calling from ML to the RTS we need to save the current heap pointer virtual void PreRTSCall(void) { TaskData::PreRTSCall(); SaveMemRegisters(); } // PostRTSCall: Before returning we need to restore the heap pointer. // If there has been a GC in the RTS call we need to create a new heap area. virtual void PostRTSCall(void) { SetMemRegisters(); TaskData::PostRTSCall(); } virtual void CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length); virtual Handle EnterCallbackFunction(Handle func, Handle args); int SwitchToPoly(); void HeapOverflowTrap(byte *pcPtr); void SetMemRegisters(); void SaveMemRegisters(); void SetRegisterMask(); void MakeTrampoline(byte **pointer, byte*entryPt); PLock interruptLock; stackItem *get_reg(int n); stackItem *®SP() { return assemblyInterface.stackPtr; } stackItem ®AX() { return assemblyInterface.p_rax; } stackItem ®BX() { return assemblyInterface.p_rbx; } stackItem ®CX() { return assemblyInterface.p_rcx; } stackItem ®DX() { return assemblyInterface.p_rdx; } stackItem ®SI() { return assemblyInterface.p_rsi; } stackItem ®DI() { return assemblyInterface.p_rdi; } #ifdef HOSTARCHITECTURE_X86_64 stackItem ®8() { return assemblyInterface.p_r8; } stackItem ®9() { return assemblyInterface.p_r9; } stackItem ®10() { return assemblyInterface.p_r10; } stackItem ®11() { return assemblyInterface.p_r11; } stackItem ®12() { return assemblyInterface.p_r12; } stackItem ®13() { return assemblyInterface.p_r13; } stackItem ®14() { return assemblyInterface.p_r14; } #endif -#if (defined(_WIN32) && !defined(__CYGWIN__)) +#if (defined(_WIN32)) DWORD savedErrno; #else int savedErrno; #endif }; class X86Dependent: public MachineDependent { public: X86Dependent() {} // Create a task data object. virtual TaskData *CreateTaskData(void) { return new X86TaskData(); } // Initial size of stack in PolyWords virtual unsigned InitialStackSize(void) { return (128+OVERFLOW_STACK_SIZE) * sizeof(uintptr_t) / sizeof(PolyWord); } virtual void ScanConstantsWithinCode(PolyObject *addr, PolyObject *oldAddr, POLYUNSIGNED length, ScanAddress *process); virtual Architectures MachineArchitecture(void) #ifndef HOSTARCHITECTURE_X86_64 { return MA_I386; } #elif defined(POLYML32IN64) { return MA_X86_64_32; } #else { return MA_X86_64; } #endif }; // Values for the returnReason byte enum RETURN_REASON { RETURN_IO_CALL_NOW_UNUSED = 0, RETURN_HEAP_OVERFLOW = 1, RETURN_STACK_OVERFLOW = 2, RETURN_STACK_OVERFLOWEX = 3, RETURN_CALLBACK_RETURN = 6, RETURN_CALLBACK_EXCEPTION = 7, RETURN_KILL_SELF = 9 }; extern "C" { // These are declared in the assembly code segment. void X86AsmSwitchToPoly(void *); extern int X86AsmKillSelf(void); extern int X86AsmCallbackReturn(void); extern int X86AsmCallbackException(void); extern int X86AsmPopArgAndClosure(void); extern int X86AsmRaiseException(void); extern int X86AsmCallExtraRETURN_HEAP_OVERFLOW(void); extern int X86AsmCallExtraRETURN_STACK_OVERFLOW(void); extern int X86AsmCallExtraRETURN_STACK_OVERFLOWEX(void); POLYUNSIGNED X86AsmAtomicIncrement(PolyObject*); POLYUNSIGNED X86AsmAtomicDecrement(PolyObject*); }; // Pointers to assembly code or trampolines to assembly code. static byte *popArgAndClosure, *killSelf, *raiseException, *callbackException, *callbackReturn; X86TaskData::X86TaskData(): allocReg(0), allocWords(0), saveRegisterMask(0) { assemblyInterface.heapOverFlowCall = (byte*)X86AsmCallExtraRETURN_HEAP_OVERFLOW; assemblyInterface.stackOverFlowCall = (byte*)X86AsmCallExtraRETURN_STACK_OVERFLOW; assemblyInterface.stackOverFlowCallEx = (byte*)X86AsmCallExtraRETURN_STACK_OVERFLOWEX; savedErrno = 0; } void X86TaskData::GarbageCollect(ScanAddress *process) { TaskData::GarbageCollect(process); // Process the parent first assemblyInterface.threadId = threadObject; if (stack != 0) { // Now the values on the stack. for (stackItem *q = assemblyInterface.stackPtr; q < (stackItem*)stack->top; q++) ScanStackAddress(process, *q, stack); } // Register mask for (int i = 0; i < 16; i++) { if (saveRegisterMask & (1 << i)) ScanStackAddress(process, *get_reg(i), stack); } } // Process a value within the stack. void X86TaskData::ScanStackAddress(ScanAddress *process, stackItem &stackItem, StackSpace *stack) { // We may have return addresses on the stack which could look like // tagged values. Check whether the value is in the code area before // checking whether it is untagged. #ifdef POLYML32IN64 // In 32-in-64 return addresses always have the top 32 bits non-zero. if (stackItem.argValue < ((uintptr_t)1 << 32)) { // It's either a tagged integer or an object pointer. if (stackItem.w().IsDataPtr()) { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } } else { // Could be a code address or a stack address. MemSpace *space = gMem.SpaceForAddress(stackItem.codeAddr - 1); if (space == 0 || space->spaceType != ST_CODE) return; PolyObject *obj = gMem.FindCodeObject(stackItem.codeAddr); ASSERT(obj != 0); // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } #else // The -1 here is because we may have a zero-sized cell in the last // word of a space. MemSpace *space = gMem.SpaceForAddress(stackItem.codeAddr-1); if (space == 0) return; // In particular we may have one of the assembly code addresses. if (space->spaceType == ST_CODE) { PolyObject *obj = gMem.FindCodeObject(stackItem.codeAddr); // If it is actually an integer it might be outside a valid code object. if (obj == 0) { ASSERT(stackItem.w().IsTagged()); // It must be an integer } else // Process the address of the start. Don't update anything. process->ScanObjectAddress(obj); } else if (space->spaceType == ST_LOCAL && stackItem.w().IsDataPtr()) // Local values must be word addresses. { PolyWord val = process->ScanObjectAddress(stackItem.w().AsObjPtr()); stackItem = val; } #endif } // Copy a stack void X86TaskData::CopyStackFrame(StackObject *old_stack, uintptr_t old_length, StackObject *new_stack, uintptr_t new_length) { /* Moves a stack, updating all references within the stack */ #ifdef POLYML32IN64 old_length = old_length / 2; new_length = new_length / 2; #endif stackItem *old_base = (stackItem *)old_stack; stackItem *new_base = (stackItem*)new_stack; stackItem *old_top = old_base + old_length; /* Calculate the offset of the new stack from the old. If the frame is being extended objects in the new frame will be further up the stack than in the old one. */ uintptr_t offset = new_base - old_base + new_length - old_length; stackItem *oldStackPtr = assemblyInterface.stackPtr; // Adjust the stack pointer and handler pointer since these point into the stack. assemblyInterface.stackPtr = assemblyInterface.stackPtr + offset; assemblyInterface.handlerRegister = assemblyInterface.handlerRegister + offset; // We need to adjust any values on the stack that are pointers within the stack. // Skip the unused part of the stack. size_t i = oldStackPtr - old_base; ASSERT (i <= old_length); i = old_length - i; stackItem *old = oldStackPtr; stackItem *newp = assemblyInterface.stackPtr; while (i--) { stackItem old_word = *old++; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem *addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *newp++ = old_word; } ASSERT(old == ((stackItem*)old_stack)+old_length); ASSERT(newp == ((stackItem*)new_stack)+new_length); // And change any registers that pointed into the old stack for (int j = 0; j < 16; j++) { if (saveRegisterMask & (1 << j)) { stackItem *regAddr = get_reg(j); stackItem old_word = *regAddr; if (old_word.w().IsDataPtr() && old_word.stackAddr >= old_base && old_word.stackAddr <= old_top) old_word.stackAddr = old_word.stackAddr + offset; else if (old_word.w().IsDataPtr() && IsHeapAddress(old_word.stackAddr)) { stackItem *addr = (stackItem*)old_word.w().AsStackAddr(); if (addr >= old_base && addr <= old_top) { addr += offset; old_word = PolyWord::FromStackAddr((PolyWord*)addr); } } *regAddr = old_word; } } } Handle X86TaskData::EnterPolyCode() /* Called from "main" to enter the code. */ { Handle hOriginal = this->saveVec.mark(); // Set this up for the IO calls. while (1) { this->saveVec.reset(hOriginal); // Remove old RTS arguments and results. // Run the ML code and return with the function to call. this->inML = true; int ioFunction = SwitchToPoly(); this->inML = false; try { switch (ioFunction) { case -1: // We've been interrupted. This usually involves simulating a // stack overflow so we could come here because of a genuine // stack overflow. // Previously this code was executed on every RTS call but there // were problems on Mac OS X at least with contention on schedLock. // Process any asynchronous events i.e. interrupts or kill processes->ProcessAsynchRequests(this); // Release and re-acquire use of the ML memory to allow another thread // to GC. processes->ThreadReleaseMLMemory(this); processes->ThreadUseMLMemory(this); break; case -2: // A callback has returned. return callBackResult; // Return the saved value. Not used in the new interface. default: Crash("Unknown io operation %d\n", ioFunction); } } catch (IOException &) { } } } // Run the current ML process. X86AsmSwitchToPoly saves the C state so that // whenever the ML requires assistance from the rest of the RTS it simply // returns to C with the appropriate values set in assemblyInterface.requestCode and // int X86TaskData::SwitchToPoly() // (Re)-enter the Poly code from C. Returns with the io function to call or // -1 if we are responding to an interrupt. { Handle mark = this->saveVec.mark(); do { this->saveVec.reset(mark); // Remove old data e.g. from arbitrary precision. SetMemRegisters(); // We need to save the C stack entry across this call in case // we're making a callback and the previous C stack entry is // for the original call. uintptr_t savedCStack = this->assemblyInterface.saveCStack; // Restore the saved error state. -#if (defined(_WIN32) && !defined(__CYGWIN__)) +#if (defined(_WIN32)) SetLastError(savedErrno); #else errno = savedErrno; #endif if (assemblyInterface.exceptionPacket.argValue != TAGGED(0).AsUnsigned()) { (--assemblyInterface.stackPtr)->codeAddr = (byte*)X86AsmRaiseException; regAX() = (PolyWord)assemblyInterface.exceptionPacket; /* put exception data into eax */ } // Enter the ML code. X86AsmSwitchToPoly(&this->assemblyInterface); this->assemblyInterface.saveCStack = savedCStack; // Save the error codes. We may have made an RTS/FFI call that // has set these and we don't want to do anything to change them. -#if (defined(_WIN32) && !defined(__CYGWIN__)) +#if (defined(_WIN32)) savedErrno = GetLastError(); #else savedErrno = errno; #endif SaveMemRegisters(); // Update globals from the memory registers. // Handle any heap/stack overflows or arbitrary precision traps. switch (this->assemblyInterface.returnReason) { case RETURN_HEAP_OVERFLOW: // The heap has overflowed. SetRegisterMask(); this->HeapOverflowTrap(assemblyInterface.stackPtr[0].codeAddr); // Computes a value for allocWords only break; case RETURN_STACK_OVERFLOW: case RETURN_STACK_OVERFLOWEX: { SetRegisterMask(); uintptr_t min_size; // Size in PolyWords if (assemblyInterface.returnReason == RETURN_STACK_OVERFLOW) { min_size = (this->stack->top - (PolyWord*)assemblyInterface.stackPtr) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } else { // Stack limit overflow. If the required stack space is larger than // the fixed overflow size the code will calculate the limit in %EDI. stackItem *stackP = regDI().stackAddr; min_size = (this->stack->top - (PolyWord*)stackP) + OVERFLOW_STACK_SIZE * sizeof(uintptr_t) / sizeof(PolyWord); } try { // The stack check has failed. This may either be because we really have // overflowed the stack or because the stack limit value has been adjusted // to result in a call here. CheckAndGrowStack(this, min_size); } catch (IOException &) { // We may get an exception while handling this if we run out of store } { PLocker l(&interruptLock); // Set the stack limit. This clears any interrupt and also sets the // correct value if we've grown the stack. this->assemblyInterface.stackLimit = (stackItem*)this->stack->bottom + OVERFLOW_STACK_SIZE; } return -1; // We're in a safe state to handle any interrupts. } case RETURN_CALLBACK_RETURN: // regSP has been set by the assembly code. N.B. This may not be the same value as when // EnterCallbackFunction was called because the callback may have grown and moved the stack. // Remove the extra exception handler we created in EnterCallbackFunction ASSERT(assemblyInterface.handlerRegister == regSP()); regSP() += 1; assemblyInterface.handlerRegister = (*(regSP()++)).stackAddr; // Restore the previous handler. this->callBackResult = this->saveVec.push(regAX()); // Argument to return is in RAX. return -2; case RETURN_CALLBACK_EXCEPTION: // An ML callback has raised an exception. // It isn't possible to do anything here except abort. Crash("An ML function called from foreign code raised an exception. Unable to continue."); case RETURN_KILL_SELF: exitThread(this); default: Crash("Unknown return reason code %u", this->assemblyInterface.returnReason); } } while (1); } void X86TaskData::MakeTrampoline(byte **pointer, byte *entryPt) { #ifdef POLYML32IN64 // In the native address versions we can store the address directly onto the stack. // We can't do that in 32-in-64 because it's likely that the address will be in the // bottom 32-bits and we can't distinguish it from an object ID. Instead we have to // build a small code segment which jumps to the code. unsigned requiredSize = 8; // 8 words i.e. 32 bytes PolyObject *result = gMem.AllocCodeSpace(requiredSize); byte *p = (byte*)result; *p++ = 0x48; // rex.w *p++ = 0x8b; // Movl *p++ = 0x0d; // rcx, pc relative *p++ = 0x09; // +2 bytes *p++ = 0x00; *p++ = 0x00; *p++ = 0x00; *p++ = 0xff; // jmp *p++ = 0xe1; // rcx *p++ = 0xf4; // hlt - needed to stop scan of constants for (unsigned i = 0; i < 6; i++) *p++ = 0; uintptr_t ep = (uintptr_t)entryPt; for (unsigned i = 0; i < 8; i++) { *p++ = ep & 0xff; ep >>= 8; } // Clear the remainder. In particular this sets the number // of address constants to zero. for (unsigned i = 0; i < 8; i++) *p++ = 0; result->SetLengthWord(requiredSize, F_CODE_OBJ); *pointer = (byte*)result; #else *pointer = entryPt; // Can go there directly #endif } void X86TaskData::InitStackFrame(TaskData *parentTaskData, Handle proc, Handle arg) /* Initialise stack frame. */ { // Set the assembly code addresses. if (popArgAndClosure == 0) MakeTrampoline(&popArgAndClosure, (byte*)&X86AsmPopArgAndClosure); if (killSelf == 0) MakeTrampoline(&killSelf, (byte*)&X86AsmKillSelf); if (raiseException == 0) MakeTrampoline(&raiseException, (byte*)&X86AsmRaiseException); if (callbackException == 0) MakeTrampoline(&callbackException, (byte*)&X86AsmCallbackException); if (callbackReturn == 0) MakeTrampoline(&callbackReturn, (byte*)&X86AsmCallbackReturn); StackSpace *space = this->stack; StackObject * newStack = space->stack(); uintptr_t stack_size = space->spaceSize() * sizeof(PolyWord) / sizeof(stackItem); uintptr_t topStack = stack_size-6; stackItem *stackTop = (stackItem*)newStack + topStack; assemblyInterface.stackPtr = stackTop; assemblyInterface.stackLimit = (stackItem*)space->bottom + OVERFLOW_STACK_SIZE; assemblyInterface.handlerRegister = (stackItem*)newStack+topStack+4; // Floating point save area. memset(&assemblyInterface.p_fp, 0, sizeof(struct fpSaveArea)); #ifndef HOSTARCHITECTURE_X86_64 // Set the control word for 64-bit precision otherwise we get inconsistent results. assemblyInterface.p_fp.cw = 0x027f ; // Control word assemblyInterface.p_fp.tw = 0xffff; // Tag registers - all unused #endif // Initial entry point - on the stack. stackTop[0].codeAddr = popArgAndClosure; // Push the argument and the closure on the stack. We can't put them into the registers // yet because we might get a GC before we actually start the code. stackTop[1] = proc->Word(); // Closure stackTop[2] = (arg == 0) ? TAGGED(0) : DEREFWORD(arg); // Argument /* We initialise the end of the stack with a sequence that will jump to kill_self whether the process ends with a normal return or by raising an exception. A bit of this was added to fix a bug when stacks were objects on the heap and could be scanned by the GC. */ stackTop[5] = TAGGED(0); // Probably no longer needed // Set the default handler and return address to point to this code. // PolyWord killJump(PolyWord::FromCodePtr((byte*)&X86AsmKillSelf)); // Exception handler. stackTop[4].codeAddr = killSelf; // Normal return address. We need a separate entry on the stack from // the exception handler because it is possible that the code we are entering // may replace this entry with an argument. The code-generator optimises tail-recursive // calls to functions with more args than the called function. stackTop[3].codeAddr = killSelf; #ifdef POLYML32IN64 // In 32-in-64 RBX always contains the heap base address. assemblyInterface.p_rbx.stackAddr = (stackItem*)globalHeapBase; #endif } // In Solaris-x86 the registers are named EIP and ESP. #if (!defined(REG_EIP) && defined(EIP)) #define REG_EIP EIP #endif #if (!defined(REG_ESP) && defined(ESP)) #define REG_ESP ESP #endif // Get the PC and SP(stack) from a signal context. This is needed for profiling. // This version gets the actual sp and pc if we are in ML. bool X86TaskData::AddTimeProfileCount(SIGNALCONTEXT *context) { stackItem * sp = 0; POLYCODEPTR pc = 0; if (context != 0) { // The tests for HAVE_UCONTEXT_T, HAVE_STRUCT_SIGCONTEXT and HAVE_WINDOWS_H need // to follow the tests in processes.h. #if defined(HAVE_WINDOWS_H) #ifdef _WIN64 sp = (stackItem *)context->Rsp; pc = (POLYCODEPTR)context->Rip; #else // Windows 32 including cygwin. sp = (stackItem *)context->Esp; pc = (POLYCODEPTR)context->Eip; #endif #elif defined(HAVE_UCONTEXT_T) #ifdef HAVE_MCONTEXT_T_GREGS // Linux #ifndef HOSTARCHITECTURE_X86_64 pc = (byte*)context->uc_mcontext.gregs[REG_EIP]; sp = (stackItem*)context->uc_mcontext.gregs[REG_ESP]; #else /* HOSTARCHITECTURE_X86_64 */ pc = (byte*)context->uc_mcontext.gregs[REG_RIP]; sp = (stackItem*)context->uc_mcontext.gregs[REG_RSP]; #endif /* HOSTARCHITECTURE_X86_64 */ #elif defined(HAVE_MCONTEXT_T_MC_ESP) // FreeBSD #ifndef HOSTARCHITECTURE_X86_64 pc = (byte*)context->uc_mcontext.mc_eip; sp = (stackItem*)context->uc_mcontext.mc_esp; #else /* HOSTARCHITECTURE_X86_64 */ pc = (byte*)context->uc_mcontext.mc_rip; sp = (stackItem*)context->uc_mcontext.mc_rsp; #endif /* HOSTARCHITECTURE_X86_64 */ #else // Mac OS X #ifndef HOSTARCHITECTURE_X86_64 #if(defined(HAVE_STRUCT_MCONTEXT_SS)||defined(HAVE_STRUCT___DARWIN_MCONTEXT32_SS)) pc = (byte*)context->uc_mcontext->ss.eip; sp = (PolyWord*)context->uc_mcontext->ss.esp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT32___SS)) pc = (byte*)context->uc_mcontext->__ss.__eip; sp = (PolyWord*)context->uc_mcontext->__ss.__esp; #endif #else /* HOSTARCHITECTURE_X86_64 */ #if(defined(HAVE_STRUCT_MCONTEXT_SS)||defined(HAVE_STRUCT___DARWIN_MCONTEXT64_SS)) pc = (byte*)context->uc_mcontext->ss.rip; sp = (PolyWord*)context->uc_mcontext->ss.rsp; #elif(defined(HAVE_STRUCT___DARWIN_MCONTEXT64___SS)) pc = (byte*)context->uc_mcontext->__ss.__rip; sp = (PolyWord*)context->uc_mcontext->__ss.__rsp; #endif #endif /* HOSTARCHITECTURE_X86_64 */ #endif #elif defined(HAVE_STRUCT_SIGCONTEXT) #if defined(HOSTARCHITECTURE_X86_64) && defined(__OpenBSD__) // CPP defines missing in amd64/signal.h in OpenBSD pc = (byte*)context->sc_rip; sp = (PolyWord*)context->sc_rsp; #else // !HOSTARCHITEXTURE_X86_64 || !defined(__OpenBSD__) pc = (byte*)context->sc_pc; sp = (PolyWord*)context->sc_sp; #endif #endif } if (pc != 0) { // See if the PC we've got is an ML code address. MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, pc, 1); return true; } } // See if the sp value is in the current stack. if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the assembly code. The top of the stack will be a return address. pc = sp[0].w().AsCodePtr(); MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, pc, 1); return true; } } // See if the value of regSP is a valid stack pointer. // This works if we happen to be in an RTS call using a "Full" call. // It doesn't work if we've used a "Fast" call because that doesn't save the SP. sp = assemblyInterface.stackPtr; if (sp >= (stackItem*)this->stack->bottom && sp < (stackItem*)this->stack->top) { // We may be in the run-time system. pc = sp[0].w().AsCodePtr(); MemSpace *space = gMem.SpaceForAddress(pc); if (space != 0 && (space->spaceType == ST_CODE || space->spaceType == ST_PERMANENT)) { add_count(this, pc, 1); return true; } } // None of those worked return false; } // This is called from a different thread so we have to be careful. void X86TaskData::InterruptCode() { PLocker l(&interruptLock); // Set the stack limit pointer to the top of the stack to cause // a trap when we next check for stack overflow. // We use a lock here to ensure that we always use the current value of the // stack. The thread we're interrupting could be growing the stack at this point. if (this->stack != 0) this->assemblyInterface.stackLimit = (stackItem*)(this->stack->top-1); } // This is called from SwitchToPoly before we enter the ML code. void X86TaskData::SetMemRegisters() { // Copy the current store limits into variables before we go into the assembly code. // If we haven't yet set the allocation area or we don't have enough we need // to create one (or a new one). if (this->allocPointer <= this->allocLimit + this->allocWords) { if (this->allocPointer < this->allocLimit) Crash ("Bad length in heap overflow trap"); // Find some space to allocate in. Updates taskData->allocPointer and // returns a pointer to the newly allocated space (if allocWords != 0) PolyWord *space = processes->FindAllocationSpace(this, this->allocWords, true); if (space == 0) { // We will now raise an exception instead of returning. // Set allocWords to zero so we don't set the allocation register // since that could be holding the exception packet. this->allocWords = 0; } // Undo the allocation just now. this->allocPointer += this->allocWords; } if (this->allocWords != 0) { // If we have had a heap trap we actually do the allocation here. // We will have already garbage collected and recovered sufficient space. // This also happens if we have just trapped because of store profiling. this->allocPointer -= this->allocWords; // Now allocate // Set the allocation register to this area. N.B. This is an absolute address. if (this->allocReg < 15) get_reg(this->allocReg)[0].codeAddr = (POLYCODEPTR)(this->allocPointer + 1); /* remember: it's off-by-one */ this->allocWords = 0; } // If we have run out of store, either just above or while allocating in the RTS, // allocPointer and allocLimit will have been set to zero as part of the GC. We will // now be raising an exception which may free some store but we need to come back here // before we allocate anything. The compiled code uses unsigned arithmetic to check for // heap overflow but only after subtracting the space required. We need to make sure // that the values are still non-negative after substracting any object size. if (this->allocPointer == 0) this->allocPointer += MAX_OBJECT_SIZE; if (this->allocLimit == 0) this->allocLimit += MAX_OBJECT_SIZE; this->assemblyInterface.localMbottom = this->allocLimit + 1; this->assemblyInterface.localMpointer = this->allocPointer + 1; // If we are profiling store allocation we set mem_hl so that a trap // will be generated. if (profileMode == kProfileStoreAllocation) this->assemblyInterface.localMbottom = this->assemblyInterface.localMpointer; this->assemblyInterface.returnReason = RETURN_IO_CALL_NOW_UNUSED; this->assemblyInterface.threadId = this->threadObject; } // This is called whenever we have returned from ML to C. void X86TaskData::SaveMemRegisters() { this->allocPointer = this->assemblyInterface.localMpointer - 1; this->allocWords = 0; this->assemblyInterface.exceptionPacket = TAGGED(0); this->saveRegisterMask = 0; } // Called on a GC or stack overflow trap. The register mask // is in the bytes after the trap call. void X86TaskData::SetRegisterMask() { byte *pc = assemblyInterface.stackPtr[0].codeAddr; if (*pc == 0xcd) // CD - INT n is used for a single byte { pc++; saveRegisterMask = *pc++; } else if (*pc == 0xca) // CA - FAR RETURN is used for a two byte mask { pc++; saveRegisterMask = pc[0] | (pc[1] << 8); pc += 2; } assemblyInterface.stackPtr[0].codeAddr = pc; } stackItem *X86TaskData::get_reg(int n) /* Returns a pointer to the register given by n. */ { switch (n) { case 0: return &assemblyInterface.p_rax; case 1: return &assemblyInterface.p_rcx; case 2: return &assemblyInterface.p_rdx; case 3: return &assemblyInterface.p_rbx; // Should not have rsp or rbp. case 6: return &assemblyInterface.p_rsi; case 7: return &assemblyInterface.p_rdi; #ifdef HOSTARCHITECTURE_X86_64 case 8: return &assemblyInterface.p_r8; case 9: return &assemblyInterface.p_r9; case 10: return &assemblyInterface.p_r10; case 11: return &assemblyInterface.p_r11; case 12: return &assemblyInterface.p_r12; case 13: return &assemblyInterface.p_r13; case 14: return &assemblyInterface.p_r14; // R15 is the heap pointer so shouldn't occur here. #endif /* HOSTARCHITECTURE_X86_64 */ default: Crash("Unknown register %d\n", n); } } // Called as a result of a heap overflow trap void X86TaskData::HeapOverflowTrap(byte *pcPtr) { X86TaskData *mdTask = this; POLYUNSIGNED wordsNeeded = 0; // The next instruction, after any branches round forwarding pointers or pop // instructions, will be a store of register containing the adjusted heap pointer. // We need to find that register and the value in it in order to find out how big // the area we actually wanted is. N.B. The code-generator and assembly code // must generate the correct instruction sequence. // byte *pcPtr = assemblyInterface.programCtr; while (true) { if (pcPtr[0] == 0xeb) { // Forwarding pointer if (pcPtr[1] >= 128) pcPtr += 256 - pcPtr[1] + 2; else pcPtr += pcPtr[1] + 2; } else if ((pcPtr[0] & 0xf8) == 0x58) // Pop instruction. pcPtr++; else if (pcPtr[0] == 0x41 && ((pcPtr[1] & 0xf8) == 0x58)) // Pop with Rex prefix pcPtr += 2; else break; } #ifndef HOSTARCHITECTURE_X86_64 // This should be movl REG,0[%ebp]. ASSERT(pcPtr[0] == 0x89); mdTask->allocReg = (pcPtr[1] >> 3) & 7; // Remember this until we allocate the memory stackItem *reg = get_reg(mdTask->allocReg); stackItem reg_val = *reg; // The space we need is the difference between this register // and the current value of newptr. // The +1 here is because assemblyInterface.localMpointer is A.M.pointer +1. The reason // is that after the allocation we have the register pointing at the address we will // actually use. wordsNeeded = (this->allocPointer - (PolyWord*)reg_val.stackAddr) + 1; *reg = TAGGED(0); // Clear this - it's not a valid address. /* length in words, including length word */ ASSERT (wordsNeeded <= (1<<24)); /* Max object size including length/flag word is 2^24 words. */ #else /* HOSTARCHITECTURE_X86_64 */ ASSERT(pcPtr[1] == 0x89 || pcPtr[1] == 0x8b); if (pcPtr[1] == 0x89) { // New (5.4) format. This should be movq REG,%r15 ASSERT(pcPtr[0] == 0x49 || pcPtr[0] == 0x4d); mdTask->allocReg = (pcPtr[2] >> 3) & 7; // Remember this until we allocate the memory if (pcPtr[0] & 0x4) mdTask->allocReg += 8; } else { // Alternative form of movq REG,%r15 ASSERT(pcPtr[0] == 0x4c || pcPtr[0] == 0x4d); mdTask->allocReg = pcPtr[2] & 7; // Remember this until we allocate the memory if (pcPtr[0] & 0x1) mdTask->allocReg += 8; } stackItem *reg = get_reg(this->allocReg); stackItem reg_val = *reg; wordsNeeded = (POLYUNSIGNED)((this->allocPointer - (PolyWord*)reg_val.stackAddr) + 1); *reg = TAGGED(0); // Clear this - it's not a valid address. #endif /* HOSTARCHITECTURE_X86_64 */ if (profileMode == kProfileStoreAllocation) addProfileCount(wordsNeeded); mdTask->allocWords = wordsNeeded; // The actual allocation is done in SetMemRegisters. } void X86TaskData::SetException(poly_exn *exc) // The RTS wants to raise an exception packet. Normally this is as the // result of an RTS call in which case the caller will check this. It can // also happen in a trap. { assemblyInterface.exceptionPacket = (PolyWord)exc; // Set for direct calls. } // Sets up a callback function on the current stack. The present state is that // the ML code has made a call in to foreign_dispatch. We need to set the stack // up so that we will enter the callback (as with CallCodeTupled) but when we return // the result we enter callback_return. Handle X86TaskData::EnterCallbackFunction(Handle func, Handle args) { // If we ever implement a light version of the FFI that allows a call to C // code without saving enough to allow allocation in C code we need to ensure // that this code doesn't do any allocation. Essentially we need the values // in localMpointer and localMbottom to be valid across a call to C. If we do // a callback the ML callback function would pick up the values saved in the // originating call. // However, it is essential that the light version still saves the stack pointer // and reloads it afterwards. // Set up an exception handler so we will enter callBackException if there is an exception. (--regSP())->stackAddr = assemblyInterface.handlerRegister; // Create a special handler entry (--regSP())->codeAddr = callbackException; assemblyInterface.handlerRegister = regSP(); // Push the call to callBackReturn onto the stack as the return address. (--regSP())->codeAddr = callbackReturn; // Set up the entry point of the callback. PolyObject *functToCall = func->WordP(); regDX() = (PolyWord)functToCall; // Closure address regAX() = args->Word(); // Push entry point address (--regSP())->codeAddr = *(POLYCODEPTR*)functToCall; // First word of closure is entry pt. return EnterPolyCode(); } // Decode and process an effective address. There may // be a constant address in here but in any case we need // to decode it to work out where the next instruction starts. // If this is an lea instruction any addresses are just constants // so must not be treated as addresses. static void skipea(PolyObject *base, byte **pt, ScanAddress *process, bool lea) { unsigned int modrm = *((*pt)++); unsigned int md = modrm >> 6; unsigned int rm = modrm & 7; if (md == 3) { } /* Register. */ else if (rm == 4) { /* s-i-b present. */ unsigned int sib = *((*pt)++); if (md == 0) { if ((sib & 7) == 5) { if (! lea) { #ifndef HOSTARCHITECTURE_X86_64 process->ScanConstant(base, *pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ } (*pt) += 4; } } else if (md == 1) (*pt)++; else if (md == 2) (*pt) += 4; } else if (md == 0 && rm == 5) { if (!lea) { #ifndef HOSTARCHITECTURE_X86_64 /* Absolute address. */ process->ScanConstant(base, *pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ } *pt += 4; } else { if (md == 1) *pt += 1; else if (md == 2) *pt += 4; } } /* Added to deal with constants within the code rather than in the constant area. The constant area is still needed for the function name. DCJM 2/1/2001 */ void X86Dependent::ScanConstantsWithinCode(PolyObject *addr, PolyObject *old, POLYUNSIGNED length, ScanAddress *process) { byte *pt = (byte*)addr; PolyWord *end = addr->Offset(length - 1); #ifdef POLYML32IN64 // If this begins with enter-int it's interpreted code - ignore if (pt[0] == 0xff && pt[1] == 0x55 && pt[2] == 0x48) return; #endif while (true) { // Escape prefixes come before any Rex byte if (*pt == 0xf2 || *pt == 0xf3 || *pt == 0x66) pt++; #ifdef HOSTARCHITECTURE_X86_64 // REX prefixes. Set this first. byte lastRex; if (*pt >= 0x40 && *pt <= 0x4f) lastRex = *pt++; else lastRex = 0; //printf("pt=%p *pt=%x\n", pt, *pt); #endif /* HOSTARCHITECTURE_X86_64 */ switch (*pt) { case 0x00: return; // This is actually the first byte of the old "marker" word. case 0xf4: return; // Halt - now used as a marker. case 0x50: case 0x51: case 0x52: case 0x53: case 0x54: case 0x55: case 0x56: case 0x57: /* Push */ case 0x58: case 0x59: case 0x5a: case 0x5b: case 0x5c: case 0x5d: case 0x5e: case 0x5f: /* Pop */ case 0x90: /* nop */ case 0xc3: /* ret */ case 0xf9: /* stc */ case 0xce: /* into */ case 0xf0: /* lock. */ case 0xf3: /* rep/repe */ case 0xa4: case 0xa5: case 0xaa: case 0xab: /* movs/stos */ case 0xa6: /* cmpsb */ case 0x9e: /* sahf */ case 0x99: /* cqo/cdq */ pt++; break; case 0x70: case 0x71: case 0x72: case 0x73: case 0x74: case 0x75: case 0x76: case 0x77: case 0x78: case 0x79: case 0x7a: case 0x7b: case 0x7c: case 0x7d: case 0x7e: case 0x7f: case 0xeb: /* short jumps. */ case 0xcd: /* INT - now used for a register mask */ case 0xa8: /* TEST_ACC8 */ case 0x6a: /* PUSH_8 */ pt += 2; break; case 0xc2: /* RET_16 */ case 0xca: /* FAR RET 16 - used for a register mask */ pt += 3; break; case 0x8d: /* leal. */ pt++; skipea(addr, &pt, process, true); break; case 0x03: case 0x0b: case 0x13: case 0x1b: case 0x23: case 0x2b: case 0x33: case 0x3b: /* Add r,ea etc. */ case 0x88: /* MOVB_R_A */ case 0x89: /* MOVL_R_A */ case 0x8b: /* MOVL_A_R */ case 0x62: /* BOUNDL */ case 0xff: /* Group5 */ case 0xd1: /* Group2_1_A */ case 0x8f: /* POP_A */ case 0xd3: /* Group2_CL_A */ case 0x87: // XCHNG case 0x63: // MOVSXD pt++; skipea(addr, &pt, process, false); break; case 0xf6: /* Group3_a */ { int isTest = 0; pt++; /* The test instruction has an immediate operand. */ if ((*pt & 0x38) == 0) isTest = 1; skipea(addr, &pt, process, false); if (isTest) pt++; break; } case 0xf7: /* Group3_A */ { int isTest = 0; pt++; /* The test instruction has an immediate operand. */ if ((*pt & 0x38) == 0) isTest = 1; skipea(addr, &pt, process, false); if (isTest) pt += 4; break; } case 0xc1: /* Group2_8_A */ case 0xc6: /* MOVB_8_A */ case 0x83: /* Group1_8_A */ case 0x80: /* Group1_8_a */ case 0x6b: // IMUL Ev,Ib pt++; skipea(addr, &pt, process, false); pt++; break; case 0x69: // IMUL Ev,Iv pt++; skipea(addr, &pt, process, false); pt += 4; break; case 0x81: /* Group1_32_A */ { pt ++; #ifndef HOSTARCHITECTURE_X86_64 unsigned opCode = *pt; #endif skipea(addr, &pt, process, false); // Only check the 32 bit constant if this is a comparison. // For other operations this may be untagged and shouldn't be an address. #ifndef HOSTARCHITECTURE_X86_64 if ((opCode & 0x38) == 0x38) process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += 4; break; } case 0xe8: case 0xe9: // Long jump and call. These are used to call constant (known) functions // and also long jumps within the function. { pt++; POLYSIGNED disp = (pt[3] & 0x80) ? -1 : 0; // Set the sign just in case. for(unsigned i = 4; i > 0; i--) disp = (disp << 8) | pt[i-1]; byte *absAddr = pt + disp + 4; // The address is relative to AFTER the constant // If the new address is within the current piece of code we don't do anything if (absAddr >= (byte*)addr && absAddr < (byte*)end) {} else { #ifdef HOSTARCHITECTURE_X86_64 ASSERT(sizeof(PolyWord) == 4); // Should only be used internally on x64 #endif /* HOSTARCHITECTURE_X86_64 */ if (addr != old) { // The old value of the displacement was relative to the old address before // we copied this code segment. // We have to correct it back to the original address. absAddr = absAddr - (byte*)addr + (byte*)old; // We have to correct the displacement for the new location and store // that away before we call ScanConstant. size_t newDisp = absAddr - pt - 4; for (unsigned i = 0; i < 4; i++) { pt[i] = (byte)(newDisp & 0xff); newDisp >>= 8; } } process->ScanConstant(addr, pt, PROCESS_RELOC_I386RELATIVE); } pt += 4; break; } case 0xc7:/* MOVL_32_A */ { pt++; if ((*pt & 0xc0) == 0x40 /* Byte offset or sib present */ && ((*pt & 7) != 4) /* But not sib present */ && pt[1] == 256-sizeof(PolyWord)) { /* We may use a move instruction to set the length word on a new segment. We mustn't try to treat this as a constant. */ pt += 6; /* Skip the modrm byte, the offset and the constant. */ } else { skipea(addr, &pt, process, false); #ifndef HOSTARCHITECTURE_X86_64 // This isn't used for addresses even in 32-in-64 process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif /* HOSTARCHITECTURE_X86_64 */ pt += 4; } break; } case 0xb8: case 0xb9: case 0xba: case 0xbb: case 0xbc: case 0xbd: case 0xbe: case 0xbf: /* MOVL_32_64_R */ pt ++; #ifdef HOSTARCHITECTURE_X86_64 if ((lastRex & 8) == 0) pt += 4; // 32-bit mode on 64-bits else #endif /* HOSTARCHITECTURE_X86_64 */ { // This is no longer generated in 64-bit mode but needs to // be retained in native 64-bit for backwards compatibility. #ifndef POLYML32IN64 // 32 bits in 32-bit mode, 64-bits in 64-bit mode. process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += sizeof(PolyWord); } break; case 0x68: /* PUSH_32 */ pt ++; #if (!defined(HOSTARCHITECTURE_X86_64) || defined(POLYML32IN64)) // Currently the only inline constant in 32-in-64. process->ScanConstant(addr, pt, PROCESS_RELOC_DIRECT); #endif pt += 4; break; case 0x0f: /* ESCAPE */ { pt++; switch (*pt) { case 0xb6: /* movzl */ case 0xb7: // movzw case 0xc1: /* xaddl */ case 0xae: // ldmxcsr/stmxcsr case 0xaf: // imul case 0x40: case 0x41: case 0x42: case 0x43: case 0x44: case 0x45: case 0x46: case 0x47: case 0x48: case 0x49: case 0x4a: case 0x4b: case 0x4c: case 0x4d: case 0x4e: case 0x4f: // cmov pt++; skipea(addr, &pt, process, false); break; case 0x80: case 0x81: case 0x82: case 0x83: case 0x84: case 0x85: case 0x86: case 0x87: case 0x88: case 0x89: case 0x8a: case 0x8b: case 0x8c: case 0x8d: case 0x8e: case 0x8f: /* Conditional branches with 32-bit displacement. */ pt += 5; break; case 0x90: case 0x91: case 0x92: case 0x93: case 0x94: case 0x95: case 0x96: case 0x97: case 0x98: case 0x99: case 0x9a: case 0x9b: case 0x9c: case 0x9d: case 0x9e: case 0x9f: /* SetCC. */ pt++; skipea(addr, &pt, process, false); break; // These are SSE2 instructions case 0x10: case 0x11: case 0x58: case 0x5c: case 0x59: case 0x5e: case 0x2e: case 0x2a: case 0x54: case 0x57: case 0x5a: case 0x6e: case 0x7e: case 0x2c: case 0x2d: pt++; skipea(addr, &pt, process, false); break; case 0x73: // PSRLDQ - EA,imm pt++; skipea(addr, &pt, process, false); pt++; break; default: Crash("Unknown opcode %d at %p\n", *pt, pt); } break; } case 0xd8: case 0xd9: case 0xda: case 0xdb: case 0xdc: case 0xdd: case 0xde: case 0xdf: // Floating point escape instructions { pt++; if ((*pt & 0xe0) == 0xe0) pt++; else skipea(addr, &pt, process, false); break; } default: Crash("Unknown opcode %d at %p\n", *pt, pt); } } } // Increment the value contained in the first word of the mutex. Handle X86TaskData::AtomicIncrement(Handle mutexp) { PolyObject *p = DEREFHANDLE(mutexp); POLYUNSIGNED result = X86AsmAtomicIncrement(p); return this->saveVec.push(PolyWord::FromUnsigned(result)); } // Release a mutex. Because the atomic increment and decrement // use the hardware LOCK prefix we can simply set this to one. void X86TaskData::AtomicReset(Handle mutexp) { DEREFHANDLE(mutexp)->Set(0, TAGGED(1)); } static X86Dependent x86Dependent; MachineDependent *machineDependent = &x86Dependent; class X86Module : public RtsModule { public: virtual void GarbageCollect(ScanAddress * /*process*/); }; // Declare this. It will be automatically added to the table. static X86Module x86Module; void X86Module::GarbageCollect(ScanAddress *process) { #ifdef POLYML32IN64 // These are trampolines in the code area rather than direct calls. if (popArgAndClosure != 0) process->ScanRuntimeAddress((PolyObject**)&popArgAndClosure, ScanAddress::STRENGTH_STRONG); if (killSelf != 0) process->ScanRuntimeAddress((PolyObject**)&killSelf, ScanAddress::STRENGTH_STRONG); if (raiseException != 0) process->ScanRuntimeAddress((PolyObject**)&raiseException, ScanAddress::STRENGTH_STRONG); if (callbackException != 0) process->ScanRuntimeAddress((PolyObject**)&callbackException, ScanAddress::STRENGTH_STRONG); if (callbackReturn != 0) process->ScanRuntimeAddress((PolyObject**)&callbackReturn, ScanAddress::STRENGTH_STRONG); #endif } \ No newline at end of file diff --git a/libpolyml/x86assembly_gas32.S b/libpolyml/x86assembly_gas32.S index d21a6cff..4707d083 100644 --- a/libpolyml/x86assembly_gas32.S +++ b/libpolyml/x86assembly_gas32.S @@ -1,207 +1,207 @@ /* Title: Assembly code routines for the poly system. Author: David Matthews - Copyright (c) David C. J. Matthews 2000-2016 + Copyright (c) David C. J. Matthews 2000-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 */ /* This is the 32-bit Unix version of the assembly code file. There are separate versions of 32/64 and Windows (Intel syntax) and Unix (gas syntax). */ /* Registers used :- %%eax: First argument to function. Result of function call. %%ebx: Second argument to function. %%ecx: General register %%edx: Closure pointer in call. %%ebp: Points to memory used for extra registers %%esi: General register. %%edi: General register. %%esp: Stack pointer. */ #include "config.h" #ifdef SYMBOLS_REQUIRE_UNDERSCORE #define EXTNAME(x) _##x #else #define EXTNAME(x) x #endif # # Macro to begin the hand-coded functions # #ifdef MACOSX #define GLOBAL .globl #else #define GLOBAL .global #endif #define INLINE_ROUTINE(id) \ GLOBAL EXTNAME(id); \ EXTNAME(id): -#define Fr_Size 56 +#define Fr_Size 16 /* This is the argument vector passed in to X86AsmSwitchToPoly It is used to initialise the frame. A few values are updated when ML returns. */ #define Arg_LocalMpointer 0x0 #define Arg_HandlerRegister 0x4 #define Arg_LocalMbottom 0x8 #define Arg_StackLimit 0xc #define Arg_ExceptionPacket 0x10 /* Address of packet to raise */ #define Arg_RequestCode 0x14 /* Byte: Io function to call. */ #define Arg_ReturnReason 0x16 /* Byte: Reason for returning from ML. */ #define Arg_FullRestore 0x17 /* Byte: Full/partial restore */ #define Arg_SaveCStack 0x18 /* Save C Stack pointer */ #define Arg_ThreadId 0x1c /* My thread id */ #define Arg_StackPtr 0x20 /* Stack Pointer */ #define Arg_SaveRAX 0x34 #define Arg_SaveRBX 0x38 #define Arg_SaveRCX 0x3c #define Arg_SaveRDX 0x40 #define Arg_SaveRSI 0x44 #define Arg_SaveRDI 0x48 #define Arg_SaveFP 0x4c #define RETURN_HEAP_OVERFLOW 1 #define RETURN_STACK_OVERFLOW 2 #define RETURN_STACK_OVERFLOWEX 3 #define RETURN_CALLBACK_RETURN 6 #define RETURN_CALLBACK_EXCEPTION 7 #define RETURN_KILL_SELF 9 # Mark the stack as non-executable when supported #ifdef HAVE_GNU_STACK .section .note.GNU-stack, "", @progbits #endif # # CODE STARTS HERE # .text #define CALL_EXTRA(index) \ pushl %ecx; \ movb $index,Arg_ReturnReason(%ebp); \ popl %ecx; \ jmp SaveFullState; /* Load the registers from the ML stack and jump to the code. This is used to start ML code. The argument is the address of the MemRegisters struct and goes into %rbp. This is the general code for switching control to ML. There are a number of cases to consider: 1. Initial entry to root function or a new thread. Needs to load EDX at least. 2. Normal return from an RTS call. Could just do a simple return. 3. Exception raised in RTS call. 4. Callback from C to an ML function. In effect this is a coroutine. Similar to 1. 5. Return from "trap" i.e. Heap/Stack overflow. Stack-overflow can result in an exception either because the stack can't be grown or because Interrupt has been raised. */ INLINE_ROUTINE(X86AsmSwitchToPoly) pushl %ebp # Standard entry sequence movl 8(%esp),%ebp # Address of argument vector - movl %esp,Arg_SaveCStack(%ebp) pushl %ebx pushl %edi pushl %esi # Push callee-save registers subl $(Fr_Size-12),%esp # Allocate frame + movl %esp,Arg_SaveCStack(%ebp) movl Arg_StackPtr(%ebp),%esp movl Arg_ExceptionPacket(%ebp),%eax cmpl $1,%eax # Did we raise an exception? jnz raisexlocal FRSTOR Arg_SaveFP(%ebp) movl Arg_SaveRAX(%ebp),%eax # Load the registers movl Arg_SaveRBX(%ebp),%ebx # Load the registers movl Arg_SaveRCX(%ebp),%ecx movl Arg_SaveRDX(%ebp),%edx movl Arg_SaveRSI(%ebp),%esi movl Arg_SaveRDI(%ebp),%edi cld # Clear this just in case ret /* Code to save the state and switch to C This saves the full register state. */ SaveFullState: movl %eax,Arg_SaveRAX(%ebp) movl %ebx,Arg_SaveRBX(%ebp) movl %ecx,Arg_SaveRCX(%ebp) movl %edx,Arg_SaveRDX(%ebp) movl %esi,Arg_SaveRSI(%ebp) movl %edi,Arg_SaveRDI(%ebp) fnsave Arg_SaveFP(%ebp) # Save FP state. Also resets the state so... fldcw Arg_SaveFP(%ebp) # ...load because we need the same rounding mode in the RTS movl %esp,Arg_StackPtr(%ebp) # Save ML stack pointer movl Arg_SaveCStack(%ebp),%esp # Restore C stack pointer - subl $12,%esp # Sp is just before the registers + addl $(Fr_Size-12),%esp popl %esi popl %edi popl %ebx popl %ebp ret INLINE_ROUTINE(X86AsmCallExtraRETURN_HEAP_OVERFLOW) CALL_EXTRA(RETURN_HEAP_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOW) CALL_EXTRA(RETURN_STACK_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOWEX) CALL_EXTRA(RETURN_STACK_OVERFLOWEX) /* Used when entering new code. The argument and closure are on the stack in case there is a GC before we enter the code. */ INLINE_ROUTINE(X86AsmPopArgAndClosure) popl %edx popl %eax jmp *(%edx) INLINE_ROUTINE(X86AsmRaiseException) raisexlocal: movl Arg_HandlerRegister(%ebp),%ecx # Get next handler into %rcx jmp *(%ecx) # Additional assembly code routines # RTS call to kill the current thread. INLINE_ROUTINE(X86AsmKillSelf) CALL_EXTRA(RETURN_KILL_SELF) INLINE_ROUTINE(X86AsmCallbackReturn) CALL_EXTRA(RETURN_CALLBACK_RETURN) INLINE_ROUTINE(X86AsmCallbackException) CALL_EXTRA(RETURN_CALLBACK_EXCEPTION) # This implements atomic addition in the same way as atomic_increment INLINE_ROUTINE(X86AsmAtomicIncrement) #ifndef HOSTARCHITECTURE_X86_64 movl 4(%esp),%eax #else movl %edi,%eax # On X86_64 the argument is passed in %edi #endif # Use %ecx and %eax because they are volatile (unlike %ebx on X86/64/Unix) movl $2,%ecx lock; xaddl %ecx,(%eax) addl $2,%ecx movl %ecx,%eax ret diff --git a/libpolyml/x86assembly_gas64.S b/libpolyml/x86assembly_gas64.S index 41f3d791..d90c93b3 100644 --- a/libpolyml/x86assembly_gas64.S +++ b/libpolyml/x86assembly_gas64.S @@ -1,288 +1,288 @@ /* Title: Assembly code routines for the poly system. Author: David Matthews - Copyright (c) David C. J. Matthews 2000-2018 + Copyright (c) David C. J. Matthews 2000-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 */ /* This is the 64-bit gas version of the assembly code file. There are separate versions of 32/64 and MAMS (Intel syntax) and and GCC (gas syntax). */ /* Registers used :- %rax: First argument to function. Result of function call. %rbx: Second argument to function. %rcx: General register %rdx: Closure pointer in call. %rbp: Points to memory used for extra registers %rsi: General register. %rdi: General register. %rsp: Stack pointer. %r8: Third argument to function %r9: Fourth argument to function %r10: Fifth argument to function %r11: General register %r12: General register %r13: General register %r14: General register %r15: Memory allocation pointer */ #include "config.h" #ifdef SYMBOLS_REQUIRE_UNDERSCORE #define EXTNAME(x) _##x #else #define EXTNAME(x) x #endif #ifdef __CYGWIN__ #define _WIN32 1 #endif /* Macro to begin the hand-coded functions */ #ifdef MACOSX #define GLOBAL .globl #else #define GLOBAL .global #endif #define INLINE_ROUTINE(id) \ GLOBAL EXTNAME(id); \ EXTNAME(id): /* Extra entries on the C stack */ -#define Fr_Size 144 /* Must be multiple of 16 to get alignment correct */ +#define Fr_Size 64 /* Must be multiple of 16 to get alignment correct */ /* This is the argument vector passed in to X86AsmSwitchToPoly It is used to initialise the frame. A few values are updated when ML returns. */ #define Arg_LocalMpointer 0x0 #define Arg_HandlerRegister 0x8 #define Arg_LocalMbottom 0x10 #define Arg_StackLimit 0x18 #define Arg_ExceptionPacket 0x20 /* Address of packet to raise */ #define Arg_RequestCode 0x28 /* Byte: Io function to call. */ #define Arg_ReturnReason 0x2a /* Byte: Reason for returning from ML. */ #define Arg_UnusedRestore 0x2b /* Byte: Full/partial restore */ #define Arg_SaveCStack 0x30 /* Current stack base */ #define Arg_ThreadId 0x38 /* My thread id */ #define Arg_StackPtr 0x40 /* Stack Pointer */ #define Arg_SaveRAX 0x68 #define Arg_SaveRBX 0x70 #define Arg_SaveRCX 0x78 #define Arg_SaveRDX 0x80 #define Arg_SaveRSI 0x88 #define Arg_SaveRDI 0x90 #define Arg_SaveR8 0x98 #define Arg_SaveR9 0xa0 #define Arg_SaveR10 0xa8 #define Arg_SaveR11 0xb0 #define Arg_SaveR12 0xb8 #define Arg_SaveR13 0xc0 #define Arg_SaveR14 0xc8 #define Arg_SaveXMM0 0xd0 #define Arg_SaveXMM1 0xd8 #define Arg_SaveXMM2 0xe0 #define Arg_SaveXMM3 0xe8 #define Arg_SaveXMM4 0xf0 #define Arg_SaveXMM5 0xf8 #define Arg_SaveXMM6 0x100 /* IO function numbers. These are functions that are called to handle special cases in this code */ #include "sys.h" #define RETURN_HEAP_OVERFLOW 1 #define RETURN_STACK_OVERFLOW 2 #define RETURN_STACK_OVERFLOWEX 3 #define RETURN_CALLBACK_RETURN 6 #define RETURN_CALLBACK_EXCEPTION 7 #define RETURN_RAISE_OVERFLOW 8 #define RETURN_KILL_SELF 9 # Mark the stack as non-executable when supported #ifdef HAVE_GNU_STACK .section .note.GNU-stack, "", @progbits #endif # # CODE STARTS HERE # .text #define CALL_EXTRA(index) \ pushq %rcx; \ movb $index,Arg_ReturnReason(%rbp); \ popq %rcx; \ jmp SaveFullState; /* Load the registers from the ML stack and jump to the code. */ INLINE_ROUTINE(X86AsmSwitchToPoly) pushq %rbp # Standard entry sequence /* If we're compiling with Mingw we're using Windows calling conventions. */ #ifdef _WIN32 movq %rcx,%rbp # Argument is in %rcx #else movq %rdi,%rbp # Argument is in %rdi #endif - movq %rsp,Arg_SaveCStack(%rbp) pushq %rbx pushq %r12 pushq %r13 pushq %r14 pushq %r15 #ifdef _WIN32 pushq %rdi # Callee save in Windows pushq %rsi subq $(Fr_Size-56),%rsp # Argument is already in %rcx #else subq $(Fr_Size-40),%rsp #endif + movq %rsp,Arg_SaveCStack(%rbp) movq Arg_LocalMpointer(%rbp),%r15 movq Arg_StackPtr(%rbp),%rsp # Set the new stack ptr movsd Arg_SaveXMM0(%rbp),%xmm0 # Load the registers movsd Arg_SaveXMM1(%rbp),%xmm1 movsd Arg_SaveXMM2(%rbp),%xmm2 movsd Arg_SaveXMM3(%rbp),%xmm3 movsd Arg_SaveXMM4(%rbp),%xmm4 movsd Arg_SaveXMM5(%rbp),%xmm5 movsd Arg_SaveXMM6(%rbp),%xmm6 movq Arg_SaveRBX(%rbp),%rbx movq Arg_SaveRCX(%rbp),%rcx movq Arg_SaveRDX(%rbp),%rdx movq Arg_SaveRSI(%rbp),%rsi movq Arg_SaveRDI(%rbp),%rdi movq Arg_SaveR8(%rbp),%r8 movq Arg_SaveR9(%rbp),%r9 movq Arg_SaveR10(%rbp),%r10 movq Arg_SaveR11(%rbp),%r11 movq Arg_SaveR12(%rbp),%r12 movq Arg_SaveR13(%rbp),%r13 movq Arg_SaveR14(%rbp),%r14 movq Arg_ExceptionPacket(%rbp),%rax cmpq $1,%rax # Did we raise an exception? jnz raisexLocal movq Arg_SaveRAX(%rbp),%rax cld # Clear this just in case ret /* This is exactly the same as raisex but seems to be needed to work round a PIC problem. */ raisexLocal: movq Arg_HandlerRegister(%rbp),%rcx # Get next handler into %rcx jmp *(%rcx) /* Code to save the state and switch to C This saves the full register state. */ SaveFullState: movq %rax,Arg_SaveRAX(%rbp) movq %rbx,Arg_SaveRBX(%rbp) movq %rcx,Arg_SaveRCX(%rbp) movq %rdx,Arg_SaveRDX(%rbp) movq %rsi,Arg_SaveRSI(%rbp) movq %rdi,Arg_SaveRDI(%rbp) movsd %xmm0,Arg_SaveXMM0(%rbp) movsd %xmm1,Arg_SaveXMM1(%rbp) movsd %xmm2,Arg_SaveXMM2(%rbp) movsd %xmm3,Arg_SaveXMM3(%rbp) movsd %xmm4,Arg_SaveXMM4(%rbp) movsd %xmm5,Arg_SaveXMM5(%rbp) movsd %xmm6,Arg_SaveXMM6(%rbp) movq %r8,Arg_SaveR8(%rbp) movq %r9,Arg_SaveR9(%rbp) movq %r10,Arg_SaveR10(%rbp) movq %r11,Arg_SaveR11(%rbp) movq %r12,Arg_SaveR12(%rbp) movq %r13,Arg_SaveR13(%rbp) movq %r14,Arg_SaveR14(%rbp) movq %rsp,Arg_StackPtr(%rbp) movq %r15,Arg_LocalMpointer(%rbp) # Save back heap pointer movq Arg_SaveCStack(%rbp),%rsp # Restore C stack pointer #ifdef _WIN32 - subq $56,%rsp + addq $(Fr_Size-56),%rsp popq %rsi popq %rdi #else - subq $40,%rsp + addq $(Fr_Size-40),%rsp #endif popq %r15 # Restore callee-save registers popq %r14 popq %r13 popq %r12 popq %rbx popq %rbp ret /* Used when entering new code. The argument and closure are on the stack in case there is a GC before we enter the code. */ INLINE_ROUTINE(X86AsmPopArgAndClosure) popq %rdx popq %rax #ifdef POLYML32IN64 jmp *(%rbx,%rdx,4) #else jmp *(%rdx) #endif # This is used if the RTS sets up an exception. It's probably no longer relevant. INLINE_ROUTINE(X86AsmRaiseException) movq Arg_HandlerRegister(%rbp),%rcx # Get next handler into %rcx jmp *(%rcx) # Additional assembly code routines # RTS call to kill the current thread. INLINE_ROUTINE(X86AsmKillSelf) CALL_EXTRA(RETURN_KILL_SELF) INLINE_ROUTINE(X86AsmCallbackReturn) CALL_EXTRA(RETURN_CALLBACK_RETURN) INLINE_ROUTINE(X86AsmCallbackException) CALL_EXTRA(RETURN_CALLBACK_EXCEPTION) INLINE_ROUTINE(X86AsmCallExtraRETURN_HEAP_OVERFLOW) CALL_EXTRA(RETURN_HEAP_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOW) CALL_EXTRA(RETURN_STACK_OVERFLOW) INLINE_ROUTINE(X86AsmCallExtraRETURN_STACK_OVERFLOWEX) CALL_EXTRA(RETURN_STACK_OVERFLOWEX) # This implements atomic addition in the same way as atomic_increment INLINE_ROUTINE(X86AsmAtomicIncrement) #ifdef _WIN32 movq %rcx,%rax # On Windows the argument is passed in %rcx #else movq %rdi,%rax # On X86_64 the argument is passed in %rdi #endif # Use %rcx and %rax because they are volatile (unlike %rbx on X86/64/Unix) movq $2,%rcx #ifdef POLYML32IN64 lock xaddl %ecx,(%rax) # Rax is an absolute address but this is only a word #else lock xaddq %rcx,(%rax) #endif addq $2,%rcx movq %rcx,%rax ret diff --git a/libpolyml/x86assembly_masm32.S b/libpolyml/x86assembly_masm32.S index ca1ccaf3..2f312db7 100644 --- a/libpolyml/x86assembly_masm32.S +++ b/libpolyml/x86assembly_masm32.S @@ -1,194 +1,194 @@ ; ; Title: Assembly code routines for the poly system. ; Author: David Matthews -; Copyright (c) David C. J. Matthews 2000-2016 +; Copyright (c) David C. J. Matthews 2000-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 ; ; ; Registers used :- ; ; eax: First argument to function. Result of function call. ; ebx: Second argument to function. ; ecx: General register ; edx: Closure pointer in call. ; ebp: Points to memory used for extra registers ; esi: General register. ; edi: General register. ; esp: Stack pointer. .486 .model flat,c -Fr_Size EQU 56 +Fr_Size EQU 16 ; Make this a multiple of 16 ; This is the argument vector passed in to X86AsmSwitchToPoly ; It is used to initialise the frame. A few values are updated ; when ML returns. ArgVector STRUCT LocalMPointer DWORD ? HandlerRegister DWORD ? LocalMbottom DWORD ? StackLimit DWORD ? ExceptionPacket DWORD ? ; Address of packet to raise UnusedRequestCode DB ? ; Byte: Io function to call. UnusedFlag DB ? ReturnReason DB ? ; Byte: Reason for returning from ML. UnusedRestore DB ? ; SaveCStack DWORD ? ; Saved C stack pointer ThreadId DWORD ? ; My thread id StackPtr DWORD ? ; Stack pointer UnusedProgramCtr DWORD ? HeapOverFlowCall DWORD ? StackOverFlowCall DWORD ? StackOverFlowCallEx DWORD ? SaveRAX DWORD ? SaveRBX DWORD ? SaveRCX DWORD ? SaveRDX DWORD ? SaveRSI DWORD ? SaveRDI DWORD ? SaveFP WORD ? ; Actually larger ArgVector ENDS ; Codes to indicate the reason for return. RETURN_HEAP_OVERFLOW EQU 1 RETURN_STACK_OVERFLOW EQU 2 RETURN_STACK_OVERFLOWEX EQU 3 RETURN_CALLBACK_RETURN EQU 6 RETURN_CALLBACK_EXCEPTION EQU 7 RETURN_KILL_SELF EQU 9 ; ; CODE STARTS HERE ; .CODE ; Load the registers from the ML stack and jump to the code. ; This is used to start ML code. ; The argument is the address of the MemRegisters struct and goes into ebp. ; This is the general code for switching control to ML. There are a number of cases to consider: ; 1. Initial entry to root function or a new thread. Needs to load EDX at least. ; 2. Normal return from an RTS call. Could just do a simple return. ; 3. Exception raised in RTS call. ; 4. Callback from C to an ML function. In effect this is a coroutine. Similar to 1. ; 5. Return from "trap" i.e. Heap/Stack overflow. Stack-overflow can result in an exception ; either because the stack can't be grown or because Interrupt has been raised. PUBLIC X86AsmSwitchToPoly X86AsmSwitchToPoly: push ebp ; Standard entry sequence mov ebp,[8+esp] ; Address of argument vector - mov [ArgVector.SaveCStack+ebp],esp push ebx ; Push callee-save registers push edi push esi sub esp,(Fr_size-12) ; Allocate frame - mov esp,[ArgVector.StackPtr+ebp] + mov [ArgVector.SaveCStack+ebp],esp + mov esp,[ArgVector.StackPtr+ebp] mov eax,[ArgVector.ExceptionPacket+ebp] cmp eax,1 ; Did we raise an exception? jnz raisex frstor [ArgVector.SaveFP+ebp] mov eax,[ArgVector.SaveRAX+ebp] mov ebx,[ArgVector.SaveRBX+ebp] mov ecx,[ArgVector.SaveRCX+ebp] mov edx,[ArgVector.SaveRDX+ebp] mov esi,[ArgVector.SaveRSI+ebp] mov edi,[ArgVector.SaveRDI+ebp] cld ; Clear this just in case ret ; Code to save the state and switch to C ; This saves the full register state. SaveFullState: mov [ArgVector.SaveRAX+ebp],eax mov [ArgVector.SaveRBX+ebp],ebx mov [ArgVector.SaveRCX+ebp],ecx mov [ArgVector.SaveRDX+ebp],edx mov [ArgVector.SaveRSI+ebp],esi mov [ArgVector.SaveRDI+ebp],edi FNSAVE [ArgVector.SaveFP+ebp] ; Save FP state. Also resets the state so... FLDCW [ArgVector.SaveFP+ebp] ; ...load because we need the same rounding mode in the RTS mov [ArgVector.StackPtr+ebp],esp ; Save ML stack pointer mov esp,[ArgVector.SaveCStack+ebp] ; Restore C stack pointer - sub esp,12 ; Sp is just before the registers + add esp,(Fr_size-12) pop esi ; Restore saved registers pop edi pop ebx pop ebp ret ; Used when entering new code. The argument and closure are on the stack ; in case there is a GC before we enter the code. PUBLIC X86AsmPopArgAndClosure X86AsmPopArgAndClosure: pop edx pop eax jmp dword ptr [edx] ; This is used if the RTS sets up an exception. It's probably no longer relevant. PUBLIC X86AsmRaiseException X86AsmRaiseException: raisex: mov ecx,[ArgVector.HandlerRegister+ebp] jmp dword ptr [ecx] ; Define standard call macro. ; Defined as an Masm macro because there are multiple instructions. CALL_EXTRA MACRO index push ecx mov byte ptr [ArgVector.ReturnReason+ebp],index pop ecx jmp SaveFullState ENDM ; Terminate the current thread PUBLIC X86AsmKillSelf X86AsmKillSelf: CALL_EXTRA RETURN_KILL_SELF PUBLIC X86AsmCallbackReturn X86AsmCallbackReturn: CALL_EXTRA RETURN_CALLBACK_RETURN PUBLIC X86AsmCallbackException X86AsmCallbackException: CALL_EXTRA RETURN_CALLBACK_EXCEPTION ; This implements atomic addition in the same way as atomic_increment ; N.B. It is called from the RTS so uses C linkage conventions. PUBLIC X86AsmAtomicIncrement X86AsmAtomicIncrement: mov eax,4[esp] ; Use ecx and eax because they are volatile (unlike ebx on X86/64/Unix) mov ecx,2 lock xadd [eax],ecx add ecx,2 mov eax,ecx ret CREATE_EXTRA_CALL MACRO index PUBLIC X86AsmCallExtra&index& X86AsmCallExtra&index&: CALL_EXTRA index ENDM CREATE_EXTRA_CALL RETURN_HEAP_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOWEX END diff --git a/libpolyml/x86assembly_masm64.S b/libpolyml/x86assembly_masm64.S index 38c59552..c10d3ee1 100644 --- a/libpolyml/x86assembly_masm64.S +++ b/libpolyml/x86assembly_masm64.S @@ -1,263 +1,263 @@ ; ; Title: Assembly code routines for the poly system. ; Author: David Matthews -; Copyright (c) David C. J. Matthews 2000-2018 +; Copyright (c) David C. J. Matthews 2000-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 ; ; ; Registers used :- ; ; rax: First argument to function. Result of function call. ; rbx: Second argument to function. ; rcx: General register ; rdx: Closure pointer in call. ; rbp: Points to memory used for extra registers ; rsi: General register. ; rdi: General register. ; rsp: Stack pointer. ; r8: Third argument to function ; r9: Fourth argument to function ; r10: Fifth argument to function ; r11: General register ; r12: General register ; r13: General register ; r14: General register ; r15: Memory allocation pointer ; Extra entries on the C stack -Fr_Size EQU 144 ; Must be multiple of 16 to get alignment correct +Fr_Size EQU 64 ; Must be multiple of 16 to get alignment correct ; This is the argument vector passed in to X86AsmSwitchToPoly ; It is used to initialise the frame. A few values are updated ; when ML returns. ArgVector STRUCT LocalMPointer QWORD ? HandlerRegister QWORD ? LocalMbottom QWORD ? StackLimit QWORD ? ExceptionPacket QWORD ? ; Address of packet to raise UnusedRequestCode DB ? ; Byte: Io function to call. UnusedFlag DB ? ReturnReason DB ? ; Byte: Reason for returning from ML. UnusedRestore DB ? ; Byte: UnusedAlign DWORD ? SaveCStack QWORD ? ; Saved C stack frame ThreadId QWORD ? ; My thread id StackPtr QWORD ? ; Stack pointer UnusedProgramCtr QWORD ? HeapOverFlowCall QWORD ? StackOverFlowCall QWORD ? StackOverFlowCallEx QWORD ? SaveRAX QWORD ? SaveRBX QWORD ? SaveRCX QWORD ? SaveRDX QWORD ? SaveRSI QWORD ? SaveRDI QWORD ? SaveR8 QWORD ? SaveR9 QWORD ? SaveR10 QWORD ? SaveR11 QWORD ? SaveR12 QWORD ? SaveR13 QWORD ? SaveR14 QWORD ? SaveXMM0 QWORD ? SaveXMM1 QWORD ? SaveXMM2 QWORD ? SaveXMM3 QWORD ? SaveXMM4 QWORD ? SaveXMM5 QWORD ? SaveXMM6 QWORD ? ArgVector ENDS RETURN_HEAP_OVERFLOW EQU 1 RETURN_STACK_OVERFLOW EQU 2 RETURN_STACK_OVERFLOWEX EQU 3 RETURN_CALLBACK_RETURN EQU 6 RETURN_CALLBACK_EXCEPTION EQU 7 RETURN_KILL_SELF EQU 9 ; ; CODE STARTS HERE ; .CODE ; Define standard call macro. CALL_EXTRA MACRO index push rcx mov byte ptr [ArgVector.ReturnReason+rbp],index pop rcx jmp SaveFullState ENDM ; Load the registers from the ML stack and jump to the code. ; This is used to start ML code. ; The argument is the address of the MemRegisters struct and goes into rbp. ; This is the general code for switching control to ML. There are a number of cases to consider: ; 1. Initial entry to root function or a new thread. Needs to load EDX at least. ; 2. Normal return from an RTS call. Could just do a simple return. ; 3. Exception raised in RTS call. ; 4. Callback from C to an ML function. In effect this is a coroutine. Similar to 1. ; 5. Return from "trap" i.e. Heap/Stack overflow. Stack-overflow can result in an exception ; either because the stack can't be grown or because Interrupt has been raised. ; Switch from C code to ML. This code uses the X86/64 Windows calling conventions. It ; saves the callee-save registers. ; This does not set up a correct frame because we don't want to reserve a register for ; that. RBP needs to be the original argument because we need to be able to modify ; the stack limit "register" from another thread in order to be able to interrupt ; this one. X86AsmSwitchToPoly PROC FRAME push rbp ; Standard entry sequence - mov [ArgVector.SaveCStack+rcx],rsp ; Save this here instead of setting rbp itself push rbx ; Save callee-save registers push r12 push r13 push r14 push r15 push rdi ; Callee save in Windows push rsi ; Strictly, we should also save xmm6 .endprolog mov rbp,rcx ; Move argument into rbp - this is definitely non-standard sub rsp,(Fr_size-56) + mov [ArgVector.SaveCStack+rcx],rsp ; Save the C stack pointer mov r15,[ArgVector.LocalMpointer+rbp] mov rsp,[ArgVector.StackPtr+rbp] movsd xmm0,[ArgVector.SaveXMM0+rbp] movsd xmm1,[ArgVector.SaveXMM1+rbp] movsd xmm2,[ArgVector.SaveXMM2+rbp] movsd xmm3,[ArgVector.SaveXMM3+rbp] movsd xmm4,[ArgVector.SaveXMM4+rbp] movsd xmm5,[ArgVector.SaveXMM5+rbp] movsd xmm6,[ArgVector.SaveXMM6+rbp] mov rbx,[ArgVector.SaveRBX+rbp] mov rcx,[ArgVector.SaveRCX+rbp] mov rdx,[ArgVector.SaveRDX+rbp] mov rsi,[ArgVector.SaveRSI+rbp] mov rdi,[ArgVector.SaveRDI+rbp] mov r8,[ArgVector.SaveR8+rbp] mov r9,[ArgVector.SaveR9+rbp] mov r10,[ArgVector.SaveR10+rbp] mov r11,[ArgVector.SaveR11+rbp] mov r12,[ArgVector.SaveR12+rbp] mov r13,[ArgVector.SaveR13+rbp] mov r14,[ArgVector.SaveR14+rbp] mov rax,[ArgVector.ExceptionPacket+rbp] cmp rax,1 ; Did we raise an exception? jnz raisex mov rax,[ArgVector.SaveRAX+rbp] cld ; Clear this just in case ret ; Everything up to here is considered as part of the X86AsmSwitchToPoly proc X86AsmSwitchToPoly ENDP ; Code to save the state and switch to C ; This saves the full register state. SaveFullState: mov [ArgVector.SaveRAX+rbp],rax mov [ArgVector.SaveRBX+rbp],rbx mov [ArgVector.SaveRCX+rbp],rcx mov [ArgVector.SaveRDX+rbp],rdx mov [ArgVector.SaveRSI+rbp],rsi mov [ArgVector.SaveRDI+rbp],rdi movsd [ArgVector.SaveXMM0+rbp],xmm0 movsd [ArgVector.SaveXMM1+rbp],xmm1 movsd [ArgVector.SaveXMM2+rbp],xmm2 movsd [ArgVector.SaveXMM3+rbp],xmm3 movsd [ArgVector.SaveXMM4+rbp],xmm4 movsd [ArgVector.SaveXMM5+rbp],xmm5 movsd [ArgVector.SaveXMM6+rbp],xmm6 mov [ArgVector.SaveR8+rbp],r8 mov [ArgVector.SaveR9+rbp],r9 mov [ArgVector.SaveR10+rbp],r10 mov [ArgVector.SaveR11+rbp],r11 mov [ArgVector.SaveR12+rbp],r12 mov [ArgVector.SaveR13+rbp],r13 mov [ArgVector.SaveR14+rbp],r14 mov [ArgVector.StackPtr+rbp],rsp mov [ArgVector.LocalMpointer+rbp],r15 ; Save back heap pointer mov rsp,[ArgVector.SaveCStack+rbp] ; Restore C stack pointer - sub rsp,56 + add rsp,(Fr_size-56) pop rsi pop rdi pop r15 ; Restore callee-save registers pop r14 pop r13 pop r12 pop rbx pop rbp ret ;# Used when entering new code. The argument and closure are on the stack ;# in case there is a GC before we enter the code. PUBLIC X86AsmPopArgAndClosure X86AsmPopArgAndClosure: pop rdx pop rax #ifdef POLYML32IN64 jmp qword ptr [rbx+rdx*4] #else jmp qword ptr [rdx] #endif ;# This is used if the RTS sets up an exception. It's probably no longer relevant. PUBLIC X86AsmRaiseException X86AsmRaiseException: raisex: mov rcx,[ArgVector.HandlerRegister+rbp] jmp qword ptr [rcx] ; RTS call to kill the current thread. PUBLIC X86AsmKillSelf X86AsmKillSelf: CALL_EXTRA RETURN_KILL_SELF PUBLIC X86AsmCallbackReturn X86AsmCallbackReturn: CALL_EXTRA RETURN_CALLBACK_RETURN PUBLIC X86AsmCallbackException X86AsmCallbackException: CALL_EXTRA RETURN_CALLBACK_EXCEPTION ; This implements atomic addition in the same way as atomic_increment PUBLIC X86AsmAtomicIncrement X86AsmAtomicIncrement: mov rax,rcx ; Use rcx and rax because they are volatile (unlike rbx on X86/64/Unix) mov rcx,2 #ifdef POLYML32IN64 lock xadd [rax],ecx ;# Rax is an absolute address but this is only a word #else lock xadd [rax],rcx #endif add rcx,2 mov rax,rcx ret CREATE_EXTRA_CALL MACRO index PUBLIC X86AsmCallExtra&index& X86AsmCallExtra&index&: CALL_EXTRA index ENDM CREATE_EXTRA_CALL RETURN_HEAP_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOW CREATE_EXTRA_CALL RETURN_STACK_OVERFLOWEX END diff --git a/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml index e66503fb..c6b449cf 100644 --- a/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml +++ b/mlsource/MLCompiler/CodeTree/CODETREE_SIMPLIFIER.sml @@ -1,1731 +1,1731 @@ (* Copyright (c) 2013, 2016-17 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 a cut-down version of the optimiser which simplifies the code but does not apply any heuristics. It follows chained bindings, in particular through tuples, folds constants expressions involving built-in functions, expands inline functions that have previously been marked as inlineable. It does not detect small functions that can be inlined nor does it code-generate functions without free variables. *) functor CODETREE_SIMPLIFIER( structure BASECODETREE: BaseCodeTreeSig structure CODETREE_FUNCTIONS: CodetreeFunctionsSig structure REMOVE_REDUNDANT: sig type codetree type loadForm type codeUse val cleanProc : (codetree * codeUse list * (int -> loadForm) * int) -> codetree structure Sharing: sig type codetree = codetree and loadForm = loadForm and codeUse = codeUse end end sharing BASECODETREE.Sharing = CODETREE_FUNCTIONS.Sharing = REMOVE_REDUNDANT.Sharing ) : sig type codetree and codeBinding and envSpecial val simplifier: codetree * int -> (codetree * codeBinding list * envSpecial) * int * bool val specialToGeneral: codetree * codeBinding list * envSpecial -> codetree structure Sharing: sig type codetree = codetree and codeBinding = codeBinding and envSpecial = envSpecial end end = struct open BASECODETREE open Address open CODETREE_FUNCTIONS open BuiltIns exception InternalError = Misc.InternalError exception RaisedException (* The bindings are held internally as a reversed list. This is really only a check that the reversed and forward lists aren't confused. *) datatype revlist = RevList of codeBinding list type simpContext = { lookupAddr: loadForm -> envGeneral * envSpecial, enterAddr: int * (envGeneral * envSpecial) -> unit, nextAddress: unit -> int, reprocess: bool ref } fun envGeneralToCodetree(EnvGenLoad ext) = Extract ext | envGeneralToCodetree(EnvGenConst w) = Constnt w fun mkDec (laddr, res) = Declar{value = res, addr = laddr, use=[]} fun mkEnv([], exp) = exp | mkEnv(decs, exp as Extract(LoadLocal loadAddr)) = ( (* A common case is where we have a binding as the last item and then a load of that binding. Reduce this so other optimisations are possible. This is still something of a special case that could/should be generalised. *) case List.last decs of Declar{addr=decAddr, value, ... } => if loadAddr = decAddr then mkEnv(List.take(decs, List.length decs - 1), value) else Newenv(decs, exp) | _ => Newenv(decs, exp) ) | mkEnv(decs, exp) = Newenv(decs, exp) fun isConstnt(Constnt _) = true | isConstnt _ = false (* Wrap up the general, bindings and special value as a codetree node. The special entry is discarded except for Constnt entries which are converted to ConstntWithInline. That allows any inlineable code to be carried forward to later passes. *) fun specialToGeneral(g, RevList(b as _ :: _), s) = mkEnv(List.rev b, specialToGeneral(g, RevList [], s)) | specialToGeneral(Constnt(w, p), RevList [], s) = Constnt(w, setInline s p) | specialToGeneral(g, RevList [], _) = g (* Convert a constant to a fixed value. Used in some constant folding. *) val toFix: machineWord -> FixedInt.int = FixedInt.fromInt o Word.toIntX o toShort local val ffiSizeFloat: unit -> word = RunCall.rtsCallFast1 "PolySizeFloat" and ffiSizeDouble: unit -> word = RunCall.rtsCallFast1 "PolySizeDouble" in (* If we have a constant index value we convert that into a byte offset. We need to know the size of the item on this platform. We have to make this check when we actually compile the code because the interpreted version will generally be run on a platform different from the one the pre-built compiler was compiled on. The ML word length will be the same because we have separate pre-built compilers for 32 and 64-bit. *) fun getMultiplier (LoadStoreMLWord _) = RunCall.bytesPerWord | getMultiplier (LoadStoreMLByte _) = 0w1 | getMultiplier LoadStoreC8 = 0w1 | getMultiplier LoadStoreC16 = 0w2 | getMultiplier LoadStoreC32 = 0w4 | getMultiplier LoadStoreC64 = 0w8 | getMultiplier LoadStoreCFloat = ffiSizeFloat() | getMultiplier LoadStoreCDouble = ffiSizeDouble() | getMultiplier LoadStoreUntaggedUnsigned = RunCall.bytesPerWord end fun simplify(c, s) = mapCodetree (simpGeneral s) c (* Process the codetree to return a codetree node. This is used when we don't want the special case. *) and simpGeneral { lookupAddr, ...} (Extract ext) = let val (gen, spec) = lookupAddr ext in SOME(specialToGeneral(envGeneralToCodetree gen, RevList [], spec)) end | simpGeneral context (Newenv envArgs) = SOME(specialToGeneral(simpNewenv(envArgs, context, RevList []))) | simpGeneral context (Lambda lambda) = SOME(Lambda(#1(simpLambda(lambda, context, NONE, NONE)))) | simpGeneral context (Eval {function, argList, resultType}) = SOME(specialToGeneral(simpFunctionCall(function, argList, resultType, context, RevList[]))) (* BuiltIn0 functions can't be processed specially. *) | simpGeneral context (Unary{oper, arg1}) = SOME(specialToGeneral(simpUnary(oper, arg1, context, RevList []))) | simpGeneral context (Binary{oper, arg1, arg2}) = SOME(specialToGeneral(simpBinary(oper, arg1, arg2, context, RevList []))) | simpGeneral context (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}) = SOME(specialToGeneral(simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, RevList []))) | simpGeneral context (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}) = SOME(specialToGeneral(simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, RevList []))) | simpGeneral context (AllocateWordMemory {numWords, flags, initial}) = SOME(specialToGeneral(simpAllocateWordMemory(numWords, flags, initial, context, RevList []))) | simpGeneral context (Cond(condTest, condThen, condElse)) = SOME(specialToGeneral(simpIfThenElse(condTest, condThen, condElse, context, RevList []))) | simpGeneral context (Tuple { fields, isVariant }) = SOME(specialToGeneral(simpTuple(fields, isVariant, context, RevList []))) | simpGeneral context (Indirect{ base, offset, indKind }) = SOME(specialToGeneral(simpFieldSelect(base, offset, indKind, context, RevList []))) | simpGeneral context (SetContainer{container, tuple, filter}) = let val optCont = simplify(container, context) val (cGen, cDecs, cSpec) = simpSpecial(tuple, context, RevList []) in case cSpec of (* If the tuple is a local binding it is simpler to pick it up from the "special" entry. *) EnvSpecTuple(size, recEnv) => let val fields = List.tabulate(size, envGeneralToCodetree o #1 o recEnv) in SOME(simpPostSetContainer(optCont, Tuple{isVariant=false, fields=fields}, cDecs, filter)) end | _ => SOME(simpPostSetContainer(optCont, cGen, cDecs, filter)) end | simpGeneral (context as { enterAddr, nextAddress, reprocess, ...}) (BeginLoop{loop, arguments, ...}) = let val didReprocess = ! reprocess (* To see if we really need the loop first try simply binding the arguments and process it. It's often the case that if one or more arguments is a constant that the looping case will be eliminated. *) val withoutBeginLoop = simplify(mkEnv(List.map (Declar o #1) arguments, loop), context) fun foldLoop f n (Loop l) = f(l, n) | foldLoop f n (Newenv(_, exp)) = foldLoop f n exp | foldLoop f n (Cond(_, t, e)) = foldLoop f (foldLoop f n t) e | foldLoop f n (Handle {handler, ...}) = foldLoop f n handler | foldLoop f n (SetContainer{tuple, ...}) = foldLoop f n tuple | foldLoop _ n _ = n (* Check if the Loop instruction is there. This assumes that these are the only tail-recursive cases. *) val hasLoop = foldLoop (fn _ => true) false in if not (hasLoop withoutBeginLoop) then SOME withoutBeginLoop else let (* Reset "reprocess". It may have been set in the withoutBeginLoop that's not the code we're going to return. *) val () = reprocess := didReprocess (* We need the BeginLoop. Create new addresses for the arguments. *) fun declArg({addr, value, use, ...}, typ) = let val newAddr = nextAddress() in enterAddr(addr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)); ({addr = newAddr, value = simplify(value, context), use = use }, typ) end (* Now look to see if the (remaining) loops have any arguments that do not change. Do this after processing because we could be eliminating other loops that may change the arguments. *) val declArgs = map declArg arguments val beginBody = simplify(loop, context) local fun argsMatch((Extract (LoadLocal argNo), _), ({addr, ...}, _)) = argNo = addr | argsMatch _ = false fun checkLoopArgs(loopArgs, checks) = let fun map3(loopA :: loopArgs, decA :: decArgs, checkA :: checkArgs) = (argsMatch(loopA, decA) andalso checkA) :: map3(loopArgs, decArgs, checkArgs) | map3 _ = [] in map3(loopArgs, declArgs, checks) end in val checkList = foldLoop checkLoopArgs (map (fn _ => true) arguments) beginBody end in if List.exists (fn l => l) checkList then let (* Turn the original arguments into bindings. *) local fun argLists(true, (arg, _), (tArgs, fArgs)) = (Declar arg :: tArgs, fArgs) | argLists(false, arg, (tArgs, fArgs)) = (tArgs, arg :: fArgs) in val (unchangedArgs, filteredDeclArgs) = ListPair.foldrEq argLists ([], []) (checkList, declArgs) end fun changeLoops (Loop loopArgs) = let val newArgs = ListPair.foldrEq(fn (false, arg, l) => arg :: l | (true, _, l) => l) [] (checkList, loopArgs) in Loop newArgs end | changeLoops(Newenv(decs, exp)) = Newenv(decs, changeLoops exp) | changeLoops(Cond(i, t, e)) = Cond(i, changeLoops t, changeLoops e) | changeLoops(Handle{handler, exp, exPacketAddr}) = Handle{handler=changeLoops handler, exp=exp, exPacketAddr=exPacketAddr} | changeLoops(SetContainer{tuple, container, filter}) = SetContainer{tuple=changeLoops tuple, container=container, filter=filter} | changeLoops code = code val beginBody = simplify(changeLoops loop, context) (* Reprocess because we've lost any special part from the arguments that haven't changed. *) val () = reprocess := true in SOME(mkEnv(unchangedArgs, BeginLoop {loop=beginBody, arguments=filteredDeclArgs})) end else SOME(BeginLoop {loop=beginBody, arguments=declArgs}) end end | simpGeneral context (TagTest{test, tag, maxTag}) = ( case simplify(test, context) of Constnt(testResult, _) => if isShort testResult andalso toShort testResult = tag then SOME CodeTrue else SOME CodeFalse | sTest => SOME(TagTest{test=sTest, tag=tag, maxTag=maxTag}) ) | simpGeneral context (LoadOperation{kind, address}) = let (* Try to move constants out of the index. *) val (genAddress, RevList decAddress) = simpAddress(address, getMultiplier kind, context) (* If the base address and index are constant and this is an immutable load we can do this at compile time. *) val result = case (genAddress, kind) of ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLWord _) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let (* Ignore the "isImmutable" flag and look at the immutable status of the memory. Check that this is a word object and that the offset is within range. The code for Vector.sub, for example, raises an exception if the index is out of range but still generates the (unreachable) indexing code. *) val addr = toAddress baseAddr val wordOffset = offset div RunCall.bytesPerWord in if isMutable addr orelse not(isWords addr) orelse wordOffset >= length addr then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(loadWord(addr, wordOffset)), []) end | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLByte _) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let val addr = toAddress baseAddr val wordOffset = offset div RunCall.bytesPerWord in if isMutable addr orelse not(isBytes addr) orelse wordOffset >= length addr then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(loadByte(addr, offset)), []) end | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreUntaggedUnsigned) => if isShort baseAddr then LoadOperation{kind=kind, address=genAddress} else let val addr = toAddress baseAddr (* We don't currently have loadWordUntagged in Address but it's only ever used to load the string length word so we can use that. *) in if isMutable addr orelse not(isBytes addr) orelse offset <> 0w0 then LoadOperation{kind=kind, address=genAddress} else Constnt(toMachineWord(String.size(RunCall.unsafeCast addr)), []) end | _ => LoadOperation{kind=kind, address=genAddress} in SOME(mkEnv(List.rev decAddress, result)) end | simpGeneral context (StoreOperation{kind, address, value}) = let val (genAddress, decAddress) = simpAddress(address, getMultiplier kind, context) val (genValue, RevList decValue, _) = simpSpecial(value, context, decAddress) in SOME(mkEnv(List.rev decValue, StoreOperation{kind=kind, address=genAddress, value=genValue})) end | simpGeneral (context as {reprocess, ...}) (BlockOperation{kind, sourceLeft, destRight, length}) = let val multiplier = case kind of BlockOpMove{isByteMove=false} => RunCall.bytesPerWord | BlockOpMove{isByteMove=true} => 0w1 | BlockOpEqualByte => 0w1 | BlockOpCompareByte => 0w1 val (genSrcAddress, RevList decSrcAddress) = simpAddress(sourceLeft, multiplier, context) val (genDstAddress, RevList decDstAddress) = simpAddress(destRight, multiplier, context) val (genLength, RevList decLength, _) = simpSpecial(length, context, RevList []) (* If we have a short length move we're better doing it as a sequence of loads and stores. This is particularly useful with string concatenation. Small here means three or less. Four and eight byte moves are handled as single instructions in the code-generator provided the alignment is correct. *) val shortLength = case genLength of Constnt(lenConst, _) => if isShort lenConst then let val l = toShort lenConst in if l <= 0w3 then SOME l else NONE end else NONE | _ => NONE val combinedDecs = List.rev decSrcAddress @ List.rev decDstAddress @ List.rev decLength val operation = case (shortLength, kind) of (SOME length, BlockOpMove{isByteMove}) => let val _ = reprocess := true (* Frequently the source will be a constant. *) val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress (* We don't know if the source is immutable but the destination definitely isn't *) val moveKind = if isByteMove then LoadStoreMLByte{isImmutable=false} else LoadStoreMLWord{isImmutable=false} fun makeMoves offset = if offset = length then [] else NullBinding( StoreOperation{kind=moveKind, address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}, value=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}}) :: makeMoves(offset+0w1) in mkEnv(combinedDecs @ makeMoves 0w0, CodeZero (* unit result *)) end | (SOME length, BlockOpEqualByte) => (* Comparing with the null string and up to 3 characters. *) let val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress val moveKind = LoadStoreMLByte{isImmutable=false} (* Build andalso tree to check each byte. For the null string this simply returns "true". *) fun makeComparison offset = if offset = length then CodeTrue else Cond( Binary{oper=WordComparison{test=TestEqual, isSigned=false}, arg1=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}, arg2=LoadOperation{kind=moveKind, address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}}}, makeComparison(offset+0w1), CodeFalse) in mkEnv(combinedDecs, makeComparison 0w0) end | _ => mkEnv(combinedDecs, BlockOperation{kind=kind, sourceLeft=genSrcAddress, destRight=genDstAddress, length=genLength}) in SOME operation end | simpGeneral (context as {enterAddr, nextAddress, ...}) (Handle{exp, handler, exPacketAddr}) = let (* We need to make a new binding for the exception packet. *) val expBody = simplify(exp, context) val newAddr = nextAddress() val () = enterAddr(exPacketAddr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)) val handleBody = simplify(handler, context) in SOME(Handle{exp=expBody, handler=handleBody, exPacketAddr=newAddr}) end | simpGeneral _ _ = NONE (* Where we have an Indirect or Eval we want the argument as either a tuple or an inline function respectively if that's possible. Getting that also involves various other cases as well. Because a binding may later be used in such a context we treat any binding in that way as well. *) and simpSpecial (Extract ext, { lookupAddr, ...}, tailDecs) = let val (gen, spec) = lookupAddr ext in (envGeneralToCodetree gen, tailDecs, spec) end | simpSpecial (Newenv envArgs, context, tailDecs) = simpNewenv(envArgs, context, tailDecs) | simpSpecial (Lambda lambda, context, tailDecs) = let val (gen, spec) = simpLambda(lambda, context, NONE, NONE) in (Lambda gen, tailDecs, spec) end | simpSpecial (Eval {function, argList, resultType}, context, tailDecs) = simpFunctionCall(function, argList, resultType, context, tailDecs) | simpSpecial (Unary{oper, arg1}, context, tailDecs) = simpUnary(oper, arg1, context, tailDecs) | simpSpecial (Binary{oper, arg1, arg2}, context, tailDecs) = simpBinary(oper, arg1, arg2, context, tailDecs) | simpSpecial (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}, context, tailDecs) = simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, tailDecs) | simpSpecial (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}, context, tailDecs) = simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) | simpSpecial (AllocateWordMemory{numWords, flags, initial}, context, tailDecs) = simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) | simpSpecial (Cond(condTest, condThen, condElse), context, tailDecs) = simpIfThenElse(condTest, condThen, condElse, context, tailDecs) | simpSpecial (Tuple { fields, isVariant }, context, tailDecs) = simpTuple(fields, isVariant, context, tailDecs) | simpSpecial (Indirect{ base, offset, indKind }, context, tailDecs) = simpFieldSelect(base, offset, indKind, context, tailDecs) | simpSpecial (c: codetree, s: simpContext, tailDecs): codetree * revlist * envSpecial = let (* Anything else - copy it and then split it into the fields. *) fun split(Newenv(l, e), RevList tailDecs) = (* Pull off bindings. *) split (e, RevList(List.rev l @ tailDecs)) | split(Constnt(m, p), tailDecs) = (Constnt(m, p), tailDecs, findInline p) | split(c, tailDecs) = (c, tailDecs, EnvSpecNone) in split(simplify(c, s), tailDecs) end (* Process a Newenv. We need to add the bindings to the context. *) and simpNewenv((envDecs: codeBinding list, envExp), context as { enterAddr, nextAddress, reprocess, ...}, tailDecs): codetree * revlist * envSpecial = let fun copyDecs ([], decs) = simpSpecial(envExp, context, decs) (* End of the list - process the result expression. *) | copyDecs ((Declar{addr, value, ...} :: vs), decs) = ( case simpSpecial(value, context, decs) of (* If this raises an exception stop here. *) vBinding as (Raise _, _, _) => vBinding | vBinding => let (* Add the declaration to the table. *) val (optV, dec) = makeNewDecl(vBinding, context) val () = enterAddr(addr, optV) in copyDecs(vs, dec) end ) | copyDecs(NullBinding v :: vs, decs) = (* Not a binding - process this and the rest.*) ( case simpSpecial(v, context, decs) of (* If this raises an exception stop here. *) vBinding as (Raise _, _, _) => vBinding | (cGen, RevList cDecs, _) => copyDecs(vs, RevList(NullBinding cGen :: cDecs)) ) | copyDecs(RecDecs mutuals :: vs, RevList decs) = (* Mutually recursive declarations. Any of the declarations may refer to any of the others. They should all be lambdas. The front end generates functions with more than one argument (either curried or tupled) as pairs of mutually recursive functions. The main function body takes its arguments on the stack (or in registers) and the auxiliary inline function, possibly nested, takes the tupled or curried arguments and calls it. If the main function is recursive it will first call the inline function which is why the pair are mutually recursive. As far as possible we want to use the main function since that uses the least memory. Specifically, if the function recurses we want the recursive call to pass all the arguments if it can. *) let (* Reorder the function so the explicitly-inlined ones come first. Their code can then be inserted into the main functions. *) local val (inlines, nonInlines) = List.partition ( fn {lambda = { isInline=Inline, ...}, ... } => true | _ => false) mutuals in val orderedDecs = inlines @ nonInlines end (* Go down the functions creating new addresses for them and entering them in the table. *) val addresses = map (fn {addr, ... } => let val decAddr = nextAddress() in enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)); decAddr end) orderedDecs fun processFunction({ lambda, addr, ... }, newAddr) = let val (gen, spec) = simpLambda(lambda, context, SOME addr, SOME newAddr) (* Update the entry in the table to include any inlineable function. *) val () = enterAddr (addr, (EnvGenLoad (LoadLocal newAddr), spec)) in {addr=newAddr, lambda=gen, use=[]} end val rlist = ListPair.map processFunction (orderedDecs, addresses) in (* and put these declarations onto the list. *) copyDecs(vs, RevList(List.rev(partitionMutableBindings(RecDecs rlist)) @ decs)) end | copyDecs (Container{addr, size, setter, ...} :: vs, RevList decs) = let (* Enter the new address immediately - it's needed in the setter. *) val decAddr = nextAddress() val () = enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)) val (setGen, RevList setDecs, _) = simpSpecial(setter, context, RevList []) in (* If we have inline expanded a function that sets the container we're better off eliminating the container completely. *) case setGen of SetContainer { tuple, filter, container } => let (* Check the container we're setting is the address we've made for it. *) val _ = (case container of Extract(LoadLocal a) => a = decAddr | _ => false) orelse raise InternalError "copyDecs: Container/SetContainer" val newDecAddr = nextAddress() val () = enterAddr (addr, (EnvGenLoad(LoadLocal newDecAddr), EnvSpecNone)) val tupleAddr = nextAddress() val tupleDec = Declar{addr=tupleAddr, use=[], value=tuple} val tupleLoad = mkLoadLocal tupleAddr val resultTuple = BoolVector.foldri(fn (i, true, l) => mkInd(i, tupleLoad) :: l | (_, false, l) => l) [] filter val _ = List.length resultTuple = size orelse raise InternalError "copyDecs: Container/SetContainer size" val containerDec = Declar{addr=newDecAddr, use=[], value=mkTuple resultTuple} (* TODO: We're replacing a container with what is notionally a tuple on the heap. It should be optimised away as a result of a further pass but we currently have indirections from a container for these. On the native platforms that doesn't matter but on 32-in-64 indirecting from the heap and from the stack are different. *) val _ = reprocess := true in copyDecs(vs, RevList(containerDec :: tupleDec :: setDecs @ decs)) end | _ => let val dec = Container{addr=decAddr, use=[], size=size, setter=setGen} in copyDecs(vs, RevList(dec :: setDecs @ decs)) end end in copyDecs(envDecs, tailDecs) end (* Prepares a binding for entry into a look-up table. Returns the entry to put into the table together with any bindings that must be made. If the general part of the optVal is a constant we can just put the constant in the table. If it is a load (Extract) it is just renaming an existing entry so we can return it. Otherwise we have to make a new binding and return a load (Extract) entry for it. *) and makeNewDecl((Constnt w, RevList decs, spec), _) = ((EnvGenConst w, spec), RevList decs) (* No need to create a binding for a constant. *) | makeNewDecl((Extract ext, RevList decs, spec), _) = ((EnvGenLoad ext, spec), RevList decs) (* Binding is simply giving a new name to a variable - can ignore this declaration. *) | makeNewDecl((gen, RevList decs, spec), { nextAddress, ...}) = let (* Create a binding for this value. *) val newAddr = nextAddress() in ((EnvGenLoad(LoadLocal newAddr), spec), RevList(mkDec(newAddr, gen) :: decs)) end and simpLambda({body, isInline, name, argTypes, resultType, closure, localCount, ...}, { lookupAddr, reprocess, ... }, myOldAddrOpt, myNewAddrOpt) = let (* A new table for the new function. *) val oldAddrTab = Array.array (localCount, NONE) val optClosureList = makeClosure() val isNowRecursive = ref false local fun localOldAddr (LoadLocal addr) = valOf(Array.sub(oldAddrTab, addr)) | localOldAddr (ext as LoadArgument _) = (EnvGenLoad ext, EnvSpecNone) | localOldAddr (ext as LoadRecursive) = (EnvGenLoad ext, EnvSpecNone) | localOldAddr (LoadClosure addr) = let val oldEntry = List.nth(closure, addr) (* If the entry in the closure is our own address this is recursive. *) fun isRecursive(EnvGenLoad(LoadLocal a), SOME b) = if a = b then (isNowRecursive := true; true) else false | isRecursive _ = false in if isRecursive(EnvGenLoad oldEntry, myOldAddrOpt) then (EnvGenLoad LoadRecursive, EnvSpecNone) else let val newEntry = lookupAddr oldEntry val makeClosure = addToClosure optClosureList fun convertResult(genEntry, specEntry) = (* If after looking up the entry we get our new address it's recursive. *) if isRecursive(genEntry, myNewAddrOpt) then (EnvGenLoad LoadRecursive, EnvSpecNone) else let val newGeneral = case genEntry of EnvGenLoad ext => EnvGenLoad(makeClosure ext) | EnvGenConst w => EnvGenConst w (* Have to modify the environment here so that if we look up free variables we add them to the closure. *) fun convertEnv env args = convertResult(env args) val newSpecial = case specEntry of EnvSpecTuple(size, env) => EnvSpecTuple(size, convertEnv env) | EnvSpecInlineFunction(spec, env) => EnvSpecInlineFunction(spec, convertEnv env) | EnvSpecUnary _ => EnvSpecNone (* Don't pass this in *) | EnvSpecBinary _ => EnvSpecNone (* Don't pass this in *) | EnvSpecNone => EnvSpecNone in (newGeneral, newSpecial) end in convertResult newEntry end end and setTab (index, v) = Array.update (oldAddrTab, index, SOME v) in val newAddressAllocator = ref 0 fun mkAddr () = ! newAddressAllocator before newAddressAllocator := ! newAddressAllocator + 1 val newCode = simplify (body, { enterAddr = setTab, lookupAddr = localOldAddr, nextAddress=mkAddr, reprocess = reprocess }) end val closureAfterOpt = extractClosure optClosureList val localCount = ! newAddressAllocator (* If we have mutually recursive "small" functions we may turn them into recursive functions. We have to remove the "small" status from them to prevent them from being expanded inline anywhere else. The optimiser may turn them back into "small" functions if the recursion is actually tail-recursion. *) val isNowInline = case isInline of Inline => if ! isNowRecursive then NonInline else Inline | NonInline => NonInline (* Clean up the function body at this point if it could be inlined. There are examples where failing to do this can blow up. This can be the result of creating both a general and special function inside an inline function. *) val cleanBody = case isNowInline of NonInline => newCode | _ => REMOVE_REDUNDANT.cleanProc(newCode, [UseExport], LoadClosure, localCount) val copiedLambda: lambdaForm = { body = cleanBody, isInline = isNowInline, name = name, closure = closureAfterOpt, argTypes = argTypes, resultType = resultType, localCount = localCount, recUse = [] } val inlineCode = case isNowInline of NonInline => EnvSpecNone | _ => EnvSpecInlineFunction(copiedLambda, fn addr => (EnvGenLoad(List.nth(closureAfterOpt, addr)), EnvSpecNone)) in ( copiedLambda, inlineCode ) end and simpFunctionCall(function, argList, resultType, context as { reprocess, ...}, tailDecs) = let (* Function call - This may involve inlining the function. *) (* Get the function to be called and see if it is inline or a lambda expression. *) val (genFunct, decsFunct, specFunct) = simpSpecial(function, context, tailDecs) (* We have to make a special check here that we are not passing in the function we are trying to expand. This could result in an infinitely recursive expansion. It is only going to happen in very special circumstances such as a definition of the Y combinator. If we see that we don't attempt to expand inline. It could be embedded in a tuple or the closure of a function as well as passed directly. *) val isRecursiveArg = case function of Extract extOrig => let fun containsFunction(Extract thisArg, v) = (v orelse thisArg = extOrig, FOLD_DESCEND) | containsFunction(Lambda{closure, ...}, v) = (* Only the closure, not the body *) (foldl (fn (c, w) => foldtree containsFunction w (Extract c)) v closure, FOLD_DONT_DESCEND) | containsFunction(Eval _, v) = (v, FOLD_DONT_DESCEND) (* OK if it's called *) | containsFunction(_, v) = (v, FOLD_DESCEND) in List.exists(fn (c, _) => foldtree containsFunction false c) argList end | _ => false in case (specFunct, genFunct, isRecursiveArg) of (EnvSpecInlineFunction({body=lambdaBody, localCount, argTypes, ...}, functEnv), _, false) => let val _ = List.length argTypes = List.length argList orelse raise InternalError "simpFunctionCall: argument mismatch" val () = reprocess := true (* If we expand inline we have to reprocess *) and { nextAddress, reprocess, ...} = context (* Expand a function inline, either one marked explicitly to be inlined or one detected as "small". *) (* Calling inline proc or a lambda expression which is just called. The function is replaced with a block containing declarations of the parameters. We need a new table here because the addresses we use to index it are the addresses which are local to the function. New addresses are created in the range of the surrounding function. *) val localVec = Array.array(localCount, NONE) local fun processArgs([], bindings) = ([], bindings) | processArgs((arg, _)::args, bindings) = let val (thisArg, newBindings) = makeNewDecl(simpSpecial(arg, context, bindings), context) val (otherArgs, resBindings) = processArgs(args, newBindings) in (thisArg::otherArgs, resBindings) end val (params, bindings) = processArgs(argList, decsFunct) val paramVec = Vector.fromList params in fun getParameter n = Vector.sub(paramVec, n) (* Bindings necessary for the arguments *) val copiedArgs = bindings end local fun localOldAddr(LoadLocal addr) = valOf(Array.sub(localVec, addr)) | localOldAddr(LoadArgument addr) = getParameter addr | localOldAddr(LoadClosure closureEntry) = functEnv closureEntry | localOldAddr LoadRecursive = raise InternalError "localOldAddr: LoadRecursive" fun setTabForInline (index, v) = Array.update (localVec, index, SOME v) val lambdaContext = { lookupAddr=localOldAddr, enterAddr=setTabForInline, nextAddress=nextAddress, reprocess = reprocess } in val (cGen, cDecs, cSpec) = simpSpecial(lambdaBody,lambdaContext, copiedArgs) end in (cGen, cDecs, cSpec) end | (_, gen as Constnt _, _) => (* Not inlinable - constant function. *) let val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList val evCopiedCode = Eval {function = gen, argList = copiedArgs, resultType=resultType} in (evCopiedCode, decsFunct, EnvSpecNone) end | (_, gen, _) => (* Anything else. *) let val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList val evCopiedCode = Eval {function = gen, argList = copiedArgs, resultType=resultType} in (evCopiedCode, decsFunct, EnvSpecNone) end end (* Special processing for the current builtIn1 operations. *) (* Constant folding for built-ins. These ought to be type-correct i.e. we should have tagged values in some cases and addresses in others. However there may be run-time tests that would ensure type-correctness and we can't be sure that they will always be folded at compile-time. e.g. we may have if isShort c then shortOp c else longOp c If c is a constant then we may try to fold both the shortOp and the longOp and one of these will be type-incorrect although never executed at run-time. *) and simpUnary(oper, arg1, context as { reprocess, ...}, tailDecs) = let val (genArg1, decArg1, specArg1) = simpSpecial(arg1, context, tailDecs) in case (oper, genArg1) of (NotBoolean, Constnt(v, _)) => ( reprocess := true; (if isShort v andalso toShort v = 0w0 then CodeTrue else CodeFalse, decArg1, EnvSpecNone) ) | (NotBoolean, genArg1) => ( (* NotBoolean: This can be the result of using Bool.not but more usually occurs as a result of other code. We don't have TestNotEqual or IsAddress so both of these use NotBoolean with TestEqual and IsTagged. Also we can insert a NotBoolean as a result of a Cond. We try to eliminate not(not a) and to push other NotBooleans down to a point where a boolean is tested. *) case specArg1 of EnvSpecUnary(NotBoolean, originalArg) => ( (* not(not a) - Eliminate. *) reprocess := true; (originalArg, decArg1, EnvSpecNone) ) | _ => (* Otherwise pass this on. It is also extracted in a Cond. *) (Unary{oper=NotBoolean, arg1=genArg1}, decArg1, EnvSpecUnary(NotBoolean, genArg1)) ) | (IsTaggedValue, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeTrue else CodeFalse, decArg1, EnvSpecNone) ) | (IsTaggedValue, genArg1) => ( (* We use this to test for nil values and if we have constructed a record (or possibly a function) it can't be null. *) case specArg1 of EnvSpecTuple _ => (CodeFalse, decArg1, EnvSpecNone) before reprocess := true | EnvSpecInlineFunction _ => (CodeFalse, decArg1, EnvSpecNone) before reprocess := true | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) ) | (MemoryCellLength, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeZero else Constnt(toMachineWord(Address.length(toAddress v)), []), decArg1, EnvSpecNone) ) | (MemoryCellFlags, Constnt(v, _)) => ( reprocess := true; (if isShort v then CodeZero else Constnt(toMachineWord(Address.flags(toAddress v)), []), decArg1, EnvSpecNone) ) | (LongWordToTagged, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.fromLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (LongWordToTagged, genArg1) => ( (* If we apply LongWordToTagged to an argument we have created with UnsignedToLongWord we can return the original argument. *) case specArg1 of EnvSpecUnary(UnsignedToLongWord, originalArg) => ( reprocess := true; (originalArg, decArg1, EnvSpecNone) ) | _ => (Unary{oper=LongWordToTagged, arg1=genArg1}, decArg1, EnvSpecNone) ) | (SignedToLongWord, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.toLargeWordX(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (UnsignedToLongWord, Constnt(v, _)) => ( reprocess := true; (Constnt(toMachineWord(Word.toLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) ) | (UnsignedToLongWord, genArg1) => (* Add the operation as the special entry. It can then be recognised by LongWordToTagged. *) (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecUnary(UnsignedToLongWord, genArg1)) | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) end and simpBinary(oper, arg1, arg2, context as {reprocess, ...}, tailDecs) = let val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, tailDecs) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) in case (oper, genArg1, genArg2) of (WordComparison{test, isSigned}, Constnt(v1, _), Constnt(v2, _)) => if (case test of TestEqual => false | _ => not(isShort v1) orelse not(isShort v2)) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val testResult = case (test, isSigned) of (* TestEqual can be applied to addresses. *) (TestEqual, _) => RunCall.pointerEq(v1, v2) | (TestLess, false) => toShort v1 < toShort v2 | (TestLessEqual, false) => toShort v1 <= toShort v2 | (TestGreater, false) => toShort v1 > toShort v2 | (TestGreaterEqual, false) => toShort v1 >= toShort v2 | (TestLess, true) => toFix v1 < toFix v2 | (TestLessEqual, true) => toFix v1 <= toFix v2 | (TestGreater, true) => toFix v1 > toFix v2 | (TestGreaterEqual, true) => toFix v1 >= toFix v2 | (TestUnordered, _) => raise InternalError "WordComparison: TestUnordered" in (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) end | (FixedPrecisionArith arithOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toFix v1 and v2S = toFix v2 fun asConstnt v = Constnt(toMachineWord v, []) val raiseOverflow = Raise(Constnt(toMachineWord Overflow, [])) val raiseDiv = Raise(Constnt(toMachineWord Div, [])) (* ?? There's usually an explicit test. *) val resultCode = case arithOp of ArithAdd => (asConstnt(v1S+v2S) handle Overflow => raiseOverflow) | ArithSub => (asConstnt(v1S-v2S) handle Overflow => raiseOverflow) | ArithMult => (asConstnt(v1S*v2S) handle Overflow => raiseOverflow) | ArithQuot => (asConstnt(FixedInt.quot(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithRem => (asConstnt(FixedInt.rem(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithDiv => (asConstnt(FixedInt.div(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) | ArithMod => (asConstnt(FixedInt.mod(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) in (resultCode, decArgs, EnvSpecNone) end (* Addition and subtraction of zero. These can arise as a result of inline expansion of more general functions. *) | (FixedPrecisionArith ArithAdd, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (FixedPrecisionArith ArithAdd, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (FixedPrecisionArith ArithSub, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith arithOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toShort v1 and v2S = toShort v2 fun asConstnt v = Constnt(toMachineWord v, []) val resultCode = case arithOp of ArithAdd => asConstnt(v1S+v2S) | ArithSub => asConstnt(v1S-v2S) | ArithMult => asConstnt(v1S*v2S) | ArithQuot => raise InternalError "WordArith: ArithQuot" | ArithRem => raise InternalError "WordArith: ArithRem" | ArithDiv => asConstnt(v1S div v2S) | ArithMod => asConstnt(v1S mod v2S) in (resultCode, decArgs, EnvSpecNone) end | (WordArith ArithAdd, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith ArithAdd, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 then (arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordArith ArithSub, arg1, Constnt(v2, _)) => if isShort v2 andalso toShort v2 = 0w0 then (arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordLogical logOp, Constnt(v1, _), Constnt(v2, _)) => if not(isShort v1) orelse not(isShort v2) then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) else let val () = reprocess := true val v1S = toShort v1 and v2S = toShort v2 fun asConstnt v = Constnt(toMachineWord v, []) val resultCode = case logOp of LogicalAnd => asConstnt(Word.andb(v1S,v2S)) | LogicalOr => asConstnt(Word.orb(v1S,v2S)) | LogicalXor => asConstnt(Word.xorb(v1S,v2S)) in (resultCode, decArgs, EnvSpecNone) end | (WordLogical logop, arg1, arg2 as Constnt(v2, _)) => (* Return the zero if we are anding with zero otherwise the original arg *) if isShort v2 andalso toShort v2 = 0w0 - then (case logop of LogicalAnd => arg2 | _ => arg1, decArgs, EnvSpecNone) + then (case logop of LogicalAnd => CodeZero | _ => arg1, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) | (WordLogical logop, Constnt(v1, _), arg2) => if isShort v1 andalso toShort v1 = 0w0 - then (case logop of LogicalAnd => arg2 | _ => arg2, decArgs, EnvSpecNone) + then (case logop of LogicalAnd => CodeZero | _ => arg2, decArgs, EnvSpecNone) else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) (* TODO: Constant folding of shifts. *) | _ => (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) end (* Arbitrary precision operations. This is a sort of mixture of a built-in and a conditional. *) and simpArbitraryCompare(TestEqual, shortCond, arg1, arg2, longCall, context, tailDecs) = (* Equality is a special case and is only there to ensure that it is not accidentally converted into an indexed case further down. We must leave it as it is. *) let val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) in case (genArg1, genArg2) of (Constnt(v1, _), Constnt(v2, _)) => let val a1: LargeInt.int = RunCall.unsafeCast v1 and a2: LargeInt.int = RunCall.unsafeCast v2 in (if a1 = a2 then CodeTrue else CodeFalse, decArgs, EnvSpecNone) end | _ => (Arbitrary{oper=ArbCompare TestEqual, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) end | simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context as {reprocess, ...}, tailDecs) = let val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) val posFlags = Address.F_bytes and negFlags = Word8.orb(Address.F_bytes, Address.F_negative) in (* Fold any constant/constant operations but more importantly, if we have variable/constant operations where the constant is short we can avoid using the full arbitrary precision call by just looking at the sign bit. *) case (genCond, genArg1, genArg2) of (_, Constnt(v1, _), Constnt(v2, _)) => let val a1: LargeInt.int = RunCall.unsafeCast v1 and a2: LargeInt.int = RunCall.unsafeCast v2 val testResult = case test of TestLess => a1 < a2 | TestGreater => a1 > a2 | TestLessEqual => a1 <= a2 | TestGreaterEqual => a1 >= a2 | _ => raise InternalError "simpArbitraryCompare: Unimplemented function" in (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) end | (Constnt(c1, _), _, _) => if isShort c1 andalso toShort c1 = 0w0 then (* One argument is definitely long - generate the long form. *) (Binary{oper=WordComparison{test=test, isSigned=true}, arg1=simplify(longCall, context), arg2=CodeZero}, decArgs, EnvSpecNone) else (* Both arguments are short. That should mean they're constants. *) (Binary{oper=WordComparison{test=test, isSigned=true}, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) before reprocess := true | (_, genArg1, cArg2 as Constnt _) => let (* The constant must be short otherwise the test would be false. *) val isNeg = case test of TestLess => true | TestLessEqual => true | _ => false (* Translate i < c into if isShort i then toShort i < c else isNegative i *) val newCode = Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg1}, Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = genArg1, arg2 = cArg2 }, Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, arg1=Unary { oper = MemoryCellFlags, arg1=genArg1 }, arg2=Constnt(toMachineWord(if isNeg then negFlags else posFlags), [])} ) in (newCode, decArgs, EnvSpecNone) end | (_, cArg1 as Constnt _, genArg2) => let (* We're testing c < i so the test is if isShort i then c < toShort i else isPositive i *) val isPos = case test of TestLess => true | TestLessEqual => true | _ => false val newCode = Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg2}, Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = cArg1, arg2 = genArg2 }, Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, arg1=Unary { oper = MemoryCellFlags, arg1=genArg2 }, arg2=Constnt(toMachineWord(if isPos then posFlags else negFlags), [])} ) in (newCode, decArgs, EnvSpecNone) end | _ => (Arbitrary{oper=ArbCompare test, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) end and simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) = let (* arg1 and arg2 are the arguments. shortCond is the condition that must be satisfied in order to use the short precision operation i.e. each argument must be short. *) val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) in case (genArg1, genArg2, genCond) of (Constnt(v1, _), Constnt(v2, _), _) => let val a1: LargeInt.int = RunCall.unsafeCast v1 and a2: LargeInt.int = RunCall.unsafeCast v2 (*val _ = print ("Fold arbitrary precision: " ^ PolyML.makestring(arith, a1, a2) ^ "\n")*) in case arith of ArithAdd => (Constnt(toMachineWord(a1+a2), []), decArgs, EnvSpecNone) | ArithSub => (Constnt(toMachineWord(a1-a2), []), decArgs, EnvSpecNone) | ArithMult => (Constnt(toMachineWord(a1*a2), []), decArgs, EnvSpecNone) | _ => raise InternalError "simpArbitraryArith: Unimplemented function" end | (_, _, Constnt(c1, _)) => if isShort c1 andalso toShort c1 = 0w0 then (* One argument is definitely long - generate the long form. *) (simplify(longCall, context), decArgs, EnvSpecNone) else (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) | _ => (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) end and simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) = let val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(numWords, context, tailDecs) val (genArg2, decArg2, _ (*specArg2*)) = simpSpecial(flags, context, decArg1) val (genArg3, decArg3, _ (*specArg3*)) = simpSpecial(initial, context, decArg2) in (AllocateWordMemory{numWords=genArg1, flags=genArg2, initial=genArg3}, decArg3, EnvSpecNone) end (* Loads, stores and block operations use address values. The index value is initially an arbitrary code tree but we can recognise common cases of constant index values or where a constant has been added to the index. TODO: If these are C memory moves we can also look at the base address. The base address for C memory operations is a LargeWord.word value i.e. the address is contained in a box. The base addresses for ML memory moves is an ML address i.e. unboxed. *) and simpAddress({base, index=NONE, offset}, _, context) = let val (genBase, decBase, _ (*specBase*)) = simpSpecial(base, context, RevList[]) in ({base=genBase, index=NONE, offset=offset}, decBase) end | simpAddress({base, index=SOME index, offset}, multiplier, context) = let val (genBase, RevList decBase, _) = simpSpecial(base, context, RevList[]) val (genIndex, RevList decIndex, _ (* specIndex *)) = simpSpecial(index, context, RevList[]) val (newIndex, newOffset) = case genIndex of Constnt(indexOffset, _) => if isShort indexOffset then (NONE, offset + toShort indexOffset * multiplier) else (SOME genIndex, offset) | _ => (SOME genIndex, offset) in ({base=genBase, index=newIndex, offset=newOffset}, RevList(decIndex @ decBase)) end (* (* A built-in function. We can call certain built-ins immediately if the arguments are constants. *) and simpBuiltIn(rtsCallNo, argList, context as { reprocess, ...}) = let val copiedArgs = map (fn arg => simpSpecial(arg, context)) argList open RuntimeCalls (* When checking for a constant we need to check that there are no bindings. They could have side-effects. *) fun isAConstant(Constnt _, [], _) = true | isAConstant _ = false in (* If the function is an RTS call that is safe to evaluate immediately and all the arguments are constants evaluate it now. *) if earlyRtsCall rtsCallNo andalso List.all isAConstant copiedArgs then let val () = reprocess := true exception Interrupt = Thread.Thread.Interrupt (* Turn the arguments into a vector. *) val argVector = case makeConstVal(mkTuple(List.map specialToGeneral copiedArgs)) of Constnt(w, _) => w | _ => raise InternalError "makeConstVal: Not constant" (* Call the function. If it raises an exception (e.g. divide by zero) generate code to raise the exception at run-time. We don't do that for Interrupt which we assume only arises by user interaction and not as a result of executing the code so we reraise that exception immediately. *) val ioOp : int -> machineWord = RunCall.run_call1 RuntimeCalls.POLY_SYS_io_operation (* We need callcode_tupled here because we pass the arguments as a tuple but the RTS functions we're calling expect arguments in registers or on the stack. *) val call: (address * machineWord) -> machineWord = RunCall.run_call1 RuntimeCalls.POLY_SYS_callcode_tupled val code = Constnt (call(toAddress(ioOp rtsCallNo), argVector), []) handle exn as Interrupt => raise exn (* Must not handle this *) | exn => Raise (Constnt(toMachineWord exn, [])) in (code, [], EnvSpecNone) end (* We can optimise certain built-ins in combination with others. If we have POLY_SYS_unsigned_to_longword combined with POLY_SYS_longword_to_tagged we can eliminate both. This can occur in cases such as Word.fromLargeWord o Word8.toLargeWord. If we have POLY_SYS_cmem_load_X functions where the address is formed by adding a constant to an address we can move the addend into the load instruction. *) (* TODO: Could we also have POLY_SYS_signed_to_longword here? *) else if rtsCallNo = POLY_SYS_longword_to_tagged andalso (case copiedArgs of [(_, _, EnvSpecBuiltIn(r, _))] => r = POLY_SYS_unsigned_to_longword | _ => false) then let val arg = (* Get the argument of the argument. *) case copiedArgs of [(_, _, EnvSpecBuiltIn(_, [arg]))] => arg | _ => raise Bind in (arg, [], EnvSpecNone) end else if (rtsCallNo = POLY_SYS_cmem_load_8 orelse rtsCallNo = POLY_SYS_cmem_load_16 orelse rtsCallNo = POLY_SYS_cmem_load_32 orelse rtsCallNo = POLY_SYS_cmem_load_64 orelse rtsCallNo = POLY_SYS_cmem_store_8 orelse rtsCallNo = POLY_SYS_cmem_store_16 orelse rtsCallNo = POLY_SYS_cmem_store_32 orelse rtsCallNo = POLY_SYS_cmem_store_64) andalso (* Check if the first argument is an addition. The second should be a constant. If the addend is a constant it will be a large integer i.e. the address of a byte segment. *) let (* Check that we have a valid value to add to a large word. The cmem_load/store values sign extend their arguments so we use toLargeWordX here. *) fun isAcceptableOffset c = if isShort c (* Shouldn't occur. *) then false else let val l: LargeWord.word = RunCall.unsafeCast c in Word.toLargeWordX(Word.fromLargeWord l) = l end in case copiedArgs of (_, _, EnvSpecBuiltIn(r, args)) :: (Constnt _, _, _) :: _ => r = POLY_SYS_plus_longword andalso (case args of (* If they were both constants we'd have folded them. *) [Constnt(c, _), _] => isAcceptableOffset c | [_, Constnt(c, _)] => isAcceptableOffset c | _ => false) | _ => false end then let (* We have a load or store with an added constant. *) val (base, offset) = case copiedArgs of (_, _, EnvSpecBuiltIn(_, [Constnt(offset, _), base])) :: (Constnt(existing, _), _, _) :: _ => (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) | (_, _, EnvSpecBuiltIn(_, [base, Constnt(offset, _)])) :: (Constnt(existing, _), _, _) :: _ => (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) | _ => raise Bind val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs val preDecs = List.foldr (op @) [] (List.map #2 newDecs) val gen = BuiltIn(rtsCallNo, base :: Constnt(toMachineWord offset, []) :: List.drop(genArgs, 2)) in (gen, preDecs, EnvSpecNone) end else let (* Create bindings for the arguments. This ensures that any side-effects in the evaluation of the arguments are performed in the correct order even if the application of the built-in itself is applicative. The new arguments are either loads or constants which are applicative. *) val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs val preDecs = List.foldr (op @) [] (List.map #2 newDecs) val gen = BuiltIn(rtsCallNo, genArgs) val spec = if reorderable gen then EnvSpecBuiltIn(rtsCallNo, genArgs) else EnvSpecNone in (gen, preDecs, spec) end end *) and simpIfThenElse(condTest, condThen, condElse, context, tailDecs) = (* If-then-else. The main simplification is if we have constants in the test or in both the arms. *) let val word0 = toMachineWord 0 val word1 = toMachineWord 1 val False = word0 val True = word1 in case simpSpecial(condTest, context, tailDecs) of (* If the test is a constant we can return the appropriate arm and ignore the other. *) (Constnt(testResult, _), bindings, _) => let val arm = if wordEq (testResult, False) (* false - return else-part *) then condElse (* if false then x else y == y *) (* if true then x else y == x *) else condThen in simpSpecial(arm, context, bindings) end | (testGen, testbindings as RevList testBList, testSpec) => let fun mkNot (Unary{oper=BuiltIns.NotBoolean, arg1}) = arg1 | mkNot arg = Unary{oper=BuiltIns.NotBoolean, arg1=arg} (* If the test involves a variable that was created with a NOT it's better to move it in here. *) val testCond = case testSpec of EnvSpecUnary(BuiltIns.NotBoolean, arg1) => mkNot arg1 | _ => testGen in case (simpSpecial(condThen, context, RevList[]), simpSpecial(condElse, context, RevList[])) of ((thenConst as Constnt(thenVal, _), RevList [], _), (elseConst as Constnt(elseVal, _), RevList [], _)) => (* Both arms return constants. This situation can arise in situations where we have andalso/orelse where the second "argument" has been reduced to a constant. *) if wordEq (thenVal, elseVal) then (* If the test has a side-effect we have to do it otherwise we can remove it. If we're in a nested andalso/orelse that may mean we can simplify the next level out. *) (thenConst (* or elseConst *), if sideEffectFree testCond then testbindings else RevList(NullBinding testCond :: testBList), EnvSpecNone) (* if x then true else false == x *) else if wordEq (thenVal, True) andalso wordEq (elseVal, False) then (testCond, testbindings, EnvSpecNone) (* if x then false else true == not x *) else if wordEq (thenVal, False) andalso wordEq (elseVal, True) then (mkNot testCond, testbindings, EnvSpecNone) else (* can't optimise *) (Cond (testCond, thenConst, elseConst), testbindings, EnvSpecNone) (* Rewrite "if x then raise y else z" into "(if x then raise y else (); z)" The advantage is that any tuples in z are lifted outside the "if". *) | (thenPart as (Raise _, _:revlist, _), (elsePart, RevList elseBindings, elseSpec)) => (* then-part raises an exception *) (elsePart, RevList(elseBindings @ NullBinding(Cond (testCond, specialToGeneral thenPart, CodeZero)) :: testBList), elseSpec) | ((thenPart, RevList thenBindings, thenSpec), elsePart as (Raise _, _, _)) => (* else part raises an exception *) (thenPart, RevList(thenBindings @ NullBinding(Cond (testCond, CodeZero, specialToGeneral elsePart)) :: testBList), thenSpec) | (thenPart, elsePart) => (Cond (testCond, specialToGeneral thenPart, specialToGeneral elsePart), testbindings, EnvSpecNone) end end (* Tuple construction. Tuples are also used for datatypes and structures (i.e. modules) *) and simpTuple(entries, isVariant, context, tailDecs) = (* The main reason for optimising record constructions is that they appear as tuples in ML. We try to ensure that loads from locally created tuples do not involve indirecting from the tuple but can get the value which was put into the tuple directly. If that is successful we may find that the tuple is never used directly so the use-count mechanism will ensure it is never created. *) let val tupleSize = List.length entries (* The record construction is treated as a block of local declarations so that any expressions which might have side-effects are done exactly once. *) (* We thread the bindings through here to avoid having to append the result. *) fun processFields([], bindings) = ([], bindings) | processFields(field::fields, bindings) = let val (thisField, newBindings) = makeNewDecl(simpSpecial(field, context, bindings), context) val (otherFields, resBindings) = processFields(fields, newBindings) in (thisField::otherFields, resBindings) end val (fieldEntries, allBindings) = processFields(entries, tailDecs) (* Make sure we include any inline code in the result. If this tuple is being "exported" we will lose the "special" part. *) fun envResToCodetree(EnvGenLoad(ext), _) = Extract ext | envResToCodetree(EnvGenConst(w, p), s) = Constnt(w, setInline s p) val generalFields = List.map envResToCodetree fieldEntries val genRec = if List.all isConstnt generalFields then makeConstVal(Tuple{ fields = generalFields, isVariant = isVariant }) else Tuple{ fields = generalFields, isVariant = isVariant } (* Get the field from the tuple if possible. If it's a variant, though, we may try to get an invalid field. See Tests/Succeed/Test167. *) fun getField addr = if addr < tupleSize then List.nth(fieldEntries, addr) else if isVariant then (EnvGenConst(toMachineWord 0, []), EnvSpecNone) else raise InternalError "getField - invalid index" val specRec = EnvSpecTuple(tupleSize, getField) in (genRec, allBindings, specRec) end and simpFieldSelect(base, offset, indKind, context, tailDecs) = let val (genSource, decSource, specSource) = simpSpecial(base, context, tailDecs) in (* Try to do the selection now if possible. *) case specSource of EnvSpecTuple(_, recEnv) => let (* The "special" entry we've found is a tuple. That means that we are taking a field from a tuple we made earlier and so we should be able to get the original code we used when we made the tuple. That might mean the tuple is never used and we can optimise away the construction of it completely. *) val (newGen, newSpec) = recEnv offset in (envGeneralToCodetree newGen, decSource, newSpec) end | _ => (* No special case possible. If the tuple is a constant mkInd/mkVarField will do the selection immediately. *) let val genSelect = case indKind of IndTuple => mkInd(offset, genSource) | IndVariant => mkVarField(offset, genSource) | IndContainer => mkIndContainer(offset, genSource) in (genSelect, decSource, EnvSpecNone) end end (* Process a SetContainer. Unlike the other simpXXX functions this is called after the arguments have been processed. We try to push the SetContainer to the leaves of the expression. *) and simpPostSetContainer(container, Tuple{fields, ...}, RevList tupleDecs, filter) = let (* Apply the filter now. *) fun select(n, hd::tl) = if n >= BoolVector.length filter then [] else if BoolVector.sub(filter, n) then hd :: select(n+1, tl) else select(n+1, tl) | select(_, []) = [] val selected = select(0, fields) (* Frequently we will have produced an indirection from the same base. These will all be bindings so we have to reverse the process. *) fun findOriginal a = List.find(fn Declar{addr, ...} => addr = a | _ => false) tupleDecs fun checkFields(last, Extract(LoadLocal a) :: tl) = ( case findOriginal a of SOME(Declar{value=Indirect{base=Extract ext, indKind=IndTuple, offset, ...}, ...}) => ( case last of NONE => checkFields(SOME(ext, [offset]), tl) | SOME(lastExt, offsets) => (* It has to be the same base and with increasing offsets (no reordering). *) if lastExt = ext andalso offset > hd offsets then checkFields(SOME(ext, offset :: offsets), tl) else NONE ) | _ => NONE ) | checkFields(_, _ :: _) = NONE | checkFields(last, []) = last fun fieldsToFilter fields = let val maxDest = List.foldl Int.max ~1 fields val filterArray = BoolArray.array(maxDest+1, false) val _ = List.app(fn n => BoolArray.update(filterArray, n, true)) fields in BoolArray.vector filterArray end in case checkFields(NONE, selected) of SOME (ext, fields) => let val filter = fieldsToFilter fields in case ext of LoadLocal localAddr => let (* Is this a container? If it is and we're copying all of it we can replace the inner container with a binding to the outer. We have to be careful because it is possible that we may create and set the inner container, then have some bindings that do some side-effects with the inner container before then copying it to the outer container. For simplicity and to maintain the condition that the container is set in the tails we only merge the containers if it's at the end (after any "filtering"). *) val allSet = BoolVector.foldl (fn (a, t) => a andalso t) true filter fun findContainer [] = NONE | findContainer (Declar{value, ...} :: tl) = if sideEffectFree value then findContainer tl else NONE | findContainer (Container{addr, size, setter, ...} :: tl) = if localAddr = addr andalso size = BoolVector.length filter andalso allSet then SOME (setter, tl) else NONE | findContainer _ = NONE in case findContainer tupleDecs of SOME (setter, decs) => (* Put in a binding for the inner container address so the setter will set the outer container. *) mkEnv(List.rev(Declar{addr=localAddr, value=container, use=[]} :: decs), setter) | NONE => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = Extract ext, filter=filter}) end | _ => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = Extract ext, filter=filter}) end | NONE => mkEnv(List.rev tupleDecs, SetContainer{container=container, tuple = mkTuple selected, filter=BoolVector.tabulate(List.length selected, fn _ => true)}) end | simpPostSetContainer(container, Cond(ifpt, thenpt, elsept), RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, Cond(ifpt, simpPostSetContainer(container, thenpt, RevList [], filter), simpPostSetContainer(container, elsept, RevList [], filter))) | simpPostSetContainer(container, Newenv(envDecs, envExp), RevList tupleDecs, filter) = simpPostSetContainer(container, envExp, RevList(List.rev envDecs @ tupleDecs), filter) | simpPostSetContainer(container, BeginLoop{loop, arguments}, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, BeginLoop{loop = simpPostSetContainer(container, loop, RevList [], filter), arguments=arguments}) | simpPostSetContainer(_, loop as Loop _, RevList tupleDecs, _) = (* If we are inside a BeginLoop we only set the container on leaves that exit the loop. Loop entries will go back to the BeginLoop so we don't add SetContainer nodes. *) mkEnv(List.rev tupleDecs, loop) | simpPostSetContainer(container, Handle{exp, handler, exPacketAddr}, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, Handle{ exp = simpPostSetContainer(container, exp, RevList [], filter), handler = simpPostSetContainer(container, handler, RevList [], filter), exPacketAddr = exPacketAddr}) | simpPostSetContainer(container, tupleGen, RevList tupleDecs, filter) = mkEnv(List.rev tupleDecs, mkSetContainer(container, tupleGen, filter)) fun simplifier(c, numLocals) = let val localAddressAllocator = ref 0 val addrTab = Array.array(numLocals, NONE) fun lookupAddr (LoadLocal addr) = valOf(Array.sub(addrTab, addr)) | lookupAddr (env as LoadArgument _) = (EnvGenLoad env, EnvSpecNone) | lookupAddr (env as LoadRecursive) = (EnvGenLoad env, EnvSpecNone) | lookupAddr (LoadClosure _) = raise InternalError "top level reached in simplifier" and enterAddr (addr, tab) = Array.update (addrTab, addr, SOME tab) fun mkAddr () = ! localAddressAllocator before localAddressAllocator := ! localAddressAllocator + 1 val reprocess = ref false val (gen, RevList bindings, spec) = simpSpecial(c, {lookupAddr = lookupAddr, enterAddr = enterAddr, nextAddress = mkAddr, reprocess = reprocess}, RevList[]) in ((gen, List.rev bindings, spec), ! localAddressAllocator, !reprocess) end fun specialToGeneral(g, b as _ :: _, s) = mkEnv(b, specialToGeneral(g, [], s)) | specialToGeneral(Constnt(w, p), [], s) = Constnt(w, setInline s p) | specialToGeneral(g, [], _) = g structure Sharing = struct type codetree = codetree and codeBinding = codeBinding and envSpecial = envSpecial end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML b/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML index 7e8699e1..d03a65dc 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/ICodeSig.ML @@ -1,414 +1,413 @@ (* Signature for the high-level X86 code Copyright David C. J. Matthews 2016-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 *) signature ICodeSig = sig type machineWord = Address.machineWord type address = Address.address type closureRef (* Registers. *) datatype genReg = GeneralReg of Word8.word * bool and fpReg = FloatingPtReg of Word8.word and xmmReg = SSE2Reg of Word8.word datatype reg = GenReg of genReg | FPReg of fpReg | XMMReg of xmmReg val regRepr: reg -> string val nReg: reg -> int val is32bit: LargeInt.int -> bool datatype targetArch = Native32Bit | Native64Bit | ObjectId32Bit val targetArch: targetArch (* Should we use SSE2 or X87 floating point? *) datatype fpMode = FPModeSSE2 | FPModeX87 val fpMode: fpMode val eax: genReg and ebx: genReg and ecx: genReg and edx: genReg and edi: genReg and esi: genReg and esp: genReg and ebp: genReg and r8: genReg and r9: genReg and r10: genReg and r11: genReg and r12: genReg and r13: genReg and r14: genReg and r15: genReg and fp0: fpReg and fp1: fpReg and fp2: fpReg and fp3: fpReg and fp4: fpReg and fp5: fpReg and fp6: fpReg and fp7: fpReg and xmm0:xmmReg and xmm1:xmmReg and xmm2:xmmReg and xmm3:xmmReg and xmm4:xmmReg and xmm5:xmmReg and xmm6:xmmReg datatype branchOps = JO | JNO | JE | JNE | JL | JGE | JLE | JG | JB | JNB | JNA | JA | JP | JNP and arithOp = ADD | OR (*|ADC | SBB*) | AND | SUB | XOR | CMP and shiftType = SHL | SHR | SAR datatype boxKind = BoxLargeWord | BoxSSE2Double | BoxSSE2Float | BoxX87Double | BoxX87Float and fpOps = FADD | FMUL | FCOM | FCOMP | FSUB | FSUBR | FDIV | FDIVR and fpUnaryOps = FABS | FCHS | FLD1 | FLDZ datatype sse2UnaryOps = SSE2UDoubleToFloat | SSE2UFloatToDouble and sse2BinaryOps = SSE2BAddDouble | SSE2BSubDouble | SSE2BMulDouble | SSE2BDivDouble | SSE2BXor | SSE2BAnd | SSE2BAddSingle | SSE2BSubSingle | SSE2BMulSingle | SSE2BDivSingle val memRegThreadSelf: int (* Copied from X86CodeSig *) and memRegExceptionPacket: int datatype callKinds = Recursive | ConstantCode of machineWord | FullCall - | DirectReg of genReg datatype preg = PReg of int (* A pseudo-register - an abstract register. *) (* A location on the stack. May be more than word if this is a container or a handler entry. *) datatype stackLocn = StackLoc of {size: int, rno: int } (* This combines pregKind and stackLocn. *) datatype regProperty = RegPropGeneral (* A general register. *) | RegPropUntagged (* An untagged general register. *) | RegPropStack of int (* A stack location or container. *) | RegPropCacheTagged | RegPropCacheUntagged | RegPropMultiple (* The result of a conditional or case. May be defined at multiple points. *) datatype argument = RegisterArgument of preg | AddressConstant of machineWord (* A constant that is an address. *) | IntegerConstant of LargeInt.int (* A non-address constant. Will usually be shifted and tagged. *) | MemoryLocation of { base: preg, offset: int, index: memoryIndex, cache: preg option } (* A memory location. *) (* Offset on the stack. The container is the stack location identifier, the field is an offset in a container. cache is an optional cache register. *) | StackLocation of { wordOffset: int, container: stackLocn, field: int, cache: preg option } (* Address of a container. *) | ContainerAddr of { container: stackLocn, stackOffset: int } (* Generally this indicates the index register if present. For 32-in-64 the "index" may be ObjectIndex in which case the base is actually an object index. *) and memoryIndex = NoMemIndex | MemIndex1 of preg | MemIndex2 of preg | MemIndex4 of preg | MemIndex8 of preg | ObjectIndex (* Kinds of moves. Move32Bit - 32-bit loads and stores Move64Bit - 64-bit loads and stores MoveByte - When loading, load a byte and zero extend. Move16Bit - Used for C-memory loads and stores. Zero extends on load. MoveFloat - Load and store a single-precision value MoveDouble - Load and store a double-precision value. *) datatype moveKind = MoveByte | Move16Bit | Move32Bit | Move64Bit | MoveFloat | MoveDouble val movePolyWord: moveKind and moveNativeWord: moveKind (* The reference to a condition code. *) datatype ccRef = CcRef of int (* Size of operand. OpSize64 is only valid in 64-bit mode. *) datatype opSize = OpSize32 | OpSize64 val polyWordOpSize: opSize and nativeWordOpSize: opSize datatype x86ICode = (* Move a value into a register. *) LoadArgument of { source: argument, dest: preg, kind: moveKind } (* Store a value into memory. The source will usually be a register but could be a constant depending on the value. If isMutable is true we're assigning to a ref and we need to flush the memory cache. *) | StoreArgument of { source: argument, base: preg, offset: int, index: memoryIndex, kind: moveKind, isMutable: bool } (* Load an entry from the "memory registers". Used just for ThreadSelf. *) | LoadMemReg of { offset: int, dest: preg } (* Start of function. Set the register arguments. stackArgs is the list of stack arguments. The last entry is the return address. If the function has a real closure regArgs includes the closure register (rdx). *) | BeginFunction of { regArgs: (preg * reg) list, stackArgs: stackLocn list } (* Call a function. If the code address is a constant it is passed here. Otherwise the address is obtained by indirecting through rdx which has been loaded as one of the argument registers. The result is stored in the destination register. *) | FunctionCall of { callKind: callKinds, regArgs: (argument * reg) list, stackArgs: argument list, dest: preg, realDest: reg, saveRegs: preg list} (* Jump to a tail-recursive function. This is similar to FunctionCall but complicated for stack arguments because the stack and the return address need to be overwritten. stackAdjust is the number of words to remove (positive) or add (negative) to the stack before the call. currStackSize contains the number of items currently on the stack. *) | TailRecursiveCall of { callKind: callKinds, regArgs: (argument * reg) list, stackArgs: {src: argument, stack: int} list, stackAdjust: int, currStackSize: int, workReg: preg } (* Allocate a fixed sized piece of memory. The size is the number of words required. This sets the length word including the flags bits. saveRegs is the list of registers that need to be saved if we need to do a garbage collection. *) | AllocateMemoryOperation of { size: int, flags: Word8.word, dest: preg, saveRegs: preg list } (* Allocate a piece of memory whose size is not known at compile-time. The size argument is the number of words. *) | AllocateMemoryVariable of { size: preg, dest: preg, saveRegs: preg list } (* Initialise a piece of memory. N.B. The size is an untagged value containing the number of words. This uses REP STOSL/Q so addr must be rdi, size must be rcx and init must be rax. *) | InitialiseMem of { size: preg, addr: preg, init: preg } (* Signal that a tuple has been fully initialised. Really a check in the low-level code-generator. *) | InitialisationComplete (* Mark the beginning of a loop. This is really only to prevent the initialisation code being duplicated in ICodeOptimise. *) | BeginLoop (* Set up the registers for a jump back to the start of a loop. *) | JumpLoop of { regArgs: (argument * preg) list, stackArgs: (argument * int * stackLocn) list, checkInterrupt: preg list option, workReg: preg option } (* Raise an exception. The packet is always loaded into rax. *) | RaiseExceptionPacket of { packetReg: preg } (* Reserve a contiguous area on the stack to receive a result tuple. *) | ReserveContainer of { size: int, container: stackLocn } (* Indexed case. *) | IndexedCaseOperation of { testReg: preg, workReg: preg } (* Lock a mutable cell by turning off the mutable bit. *) | LockMutable of { addr: preg } (* Compare two word values. The first argument must be a register. *) | WordComparison of { arg1: preg, arg2: argument, ccRef: ccRef, opSize: opSize } (* Compare with a literal. This is generally used to compare a memory or stack location with a literal and overlaps to some extent with WordComparison. *) | CompareLiteral of { arg1: argument, arg2: LargeInt.int, opSize: opSize, ccRef: ccRef } (* Compare a byte location with a literal. This is the only operation that specifically deals with single bytes. Other cases will use word operations. *) | CompareByteMem of { arg1: { base: preg, offset: int, index: memoryIndex }, arg2: Word8.word, ccRef: ccRef } (* Exception handling. - Set up an exception handler. *) | PushExceptionHandler of { workReg: preg } (* End of a handled section. Restore the previous handler. *) | PopExceptionHandler of { workReg: preg } (* Marks the start of a handler. This sets the stack pointer and restores the old handler. Sets the exception packet register. *) | BeginHandler of { packetReg: preg, workReg: preg } (* Return from the function. *) | ReturnResultFromFunction of { resultReg: preg, realReg: reg, numStackArgs: int } (* Arithmetic or logical operation. These can set the condition codes. *) | ArithmeticFunction of { oper: arithOp, resultReg: preg, operand1: preg, operand2: argument, ccRef: ccRef, opSize: opSize } (* Test the tag bit of a word. Sets the Zero bit if the value is an address i.e. untagged. *) | TestTagBit of { arg: argument, ccRef: ccRef } (* Push a value to the stack. Added during translation phase. *) | PushValue of { arg: argument, container: stackLocn } (* Copy a value to a cache register. LoadArgument could be used for this but it may be better to keep it separate. *) | CopyToCache of { source: preg, dest: preg, kind: moveKind } (* Remove items from the stack. Added during translation phase. *) | ResetStackPtr of { numWords: int, preserveCC: bool } (* Store a value into the stack. *) | StoreToStack of { source: argument, container: stackLocn, field: int, stackOffset: int } (* Tag a value by shifting and setting the tag bit. *) | TagValue of { source: preg, dest: preg, isSigned: bool, opSize: opSize } (* Shift a value to remove the tag bit. The cache is used if this is untagging a value that has previously been tagged. *) | UntagValue of { source: preg, dest: preg, isSigned: bool, cache: preg option, opSize: opSize } (* This provides the LEA instruction which can be used for various sorts of arithmetic. The base register is optional in this case. *) | LoadEffectiveAddress of { base: preg option, offset: int, index: memoryIndex, dest: preg, opSize: opSize } (* Shift a word by an amount that can either be a constant or a register. *) | ShiftOperation of { shift: shiftType, resultReg: preg, operand: preg, shiftAmount: argument, ccRef: ccRef, opSize: opSize } (* Multiplication. We can use signed multiplication for both fixed precision and word (unsigned) multiplication. There are various forms of the instruction including a three-operand version. *) | Multiplication of { resultReg: preg, operand1: preg, operand2: argument, ccRef: ccRef, opSize: opSize } (* Division. This takes a register pair, always RDX:RAX, divides it by the operand register and puts the quotient in RAX and remainder in RDX. At the preg level we represent all of these by pRegs. The divisor can be either a register or a memory location. *) | Division of { isSigned: bool, dividend: preg, divisor: argument, quotient: preg, remainder: preg, opSize: opSize } (* Atomic exchange and addition. This is executed with a lock prefix and is used for atomic increment and decrement for mutexes. Before the operation the source contains an increment. After the operation the source contains the old value of the destination and the destination has been updated with its old value added to the increment. The destination is actually the word pointed at by "base". *) | AtomicExchangeAndAdd of { base: preg, source: preg } (* Create a "box" of a single-word "byte" cell and store the source into it. This can be implemented using AllocateMemoryOperation but the idea is to allow the transform layer to recognise when a value is being boxed and then unboxed and remove unnecessary allocation. *) | BoxValue of { boxKind: boxKind, source: preg, dest: preg, saveRegs: preg list } (* Compare two vectors of bytes and set the condition code on the result. In general vec1Addr and vec2Addr will be pointers inside memory cells so have to be untagged registers. *) | CompareByteVectors of { vec1Addr: preg, vec2Addr: preg, length: preg, ccRef: ccRef } (* Move a block of bytes (isByteMove true) or words (isByteMove false). The length is the number of items (bytes or words) to move. *) | BlockMove of { srcAddr: preg, destAddr: preg, length: preg, isByteMove: bool } (* Floating point comparison. *) | X87Compare of { arg1: preg, arg2: argument, isDouble: bool, ccRef: ccRef } (* Floating point comparison. *) | SSE2Compare of { arg1: preg, arg2: argument, isDouble: bool, ccRef: ccRef } (* The X87 FP unit does not generate condition codes directly. We have to load the cc into RAX and test it there. *) | X87FPGetCondition of { ccRef: ccRef, dest: preg } (* Binary floating point operations on the X87. *) | X87FPArith of { opc: fpOps, resultReg: preg, arg1: preg, arg2: argument, isDouble: bool } (* Floating point operations: negate and set sign positive. *) | X87FPUnaryOps of { fpOp: fpUnaryOps, dest: preg, source: preg } (* Load a fixed point value as a floating point value. *) | X87Float of { dest: preg, source: argument } (* Load a fixed point value as a floating point value. *) | SSE2Float of { dest: preg, source: argument } (* Binary floating point operations using SSE2 instructions. *) | SSE2FPUnary of { opc: sse2UnaryOps, resultReg: preg, source: argument } (* Binary floating point operations using SSE2 instructions. *) | SSE2FPBinary of { opc: sse2BinaryOps, resultReg: preg, arg1: preg, arg2: argument } (* Tag a 32-bit floating point value. This is tagged by shifting left 32-bits and then setting the bottom bit. This allows memory operands to be untagged simply by loading the high-order word. *) | TagFloat of { source: preg, dest: preg } (* Untag a 32-bit floating point value into a XMM register. If the source is in memory we just need to load the high-order word. *) | UntagFloat of { source: argument, dest: preg, cache: preg option } (* Get and set the control registers. These all have to work through memory but it's simpler to assume they work through registers. *) | GetSSE2ControlReg of { dest: preg } | SetSSE2ControlReg of { source: preg } | GetX87ControlReg of { dest: preg } | SetX87ControlReg of { source: preg } (* Convert a floating point value to an integer. *) | X87RealToInt of { source: preg, dest: preg } (* Convert a floating point value to an integer. *) | SSE2RealToInt of { source: argument, dest: preg, isDouble: bool, isTruncate: bool } (* Sign extend a 32-bit value to 64-bits. Not included in LoadArgument because that assumes that if we have the result in a register we can simply reuse the register. *) | SignExtend32To64 of { source: argument, dest: preg } (* Destinations at the end of a basic block. *) and controlFlow = (* Unconditional branch to a label - should be a merge point. *) Unconditional of int (* Conditional branch. Jumps to trueJump if the condional is false, falseJump if false. *) | Conditional of { ccRef: ccRef, condition: branchOps, trueJump: int, falseJump: int } (* Exit - the last instruction of the block is a return, raise or tailcall. *) | ExitCode (* Indexed case - this branches to one of a number of labels *) | IndexedBr of int list (* Set up a handler. This doesn't cause an immediate branch but the state at the start of the handler is the state at this point. *) | SetHandler of { handler: int, continue: int } (* Unconditional branch to a handler. If an exception is raised explicitly within the scope of a handler. *) | UnconditionalHandle of int (* Conditional branch to a handler. Occurs if there is a call to a function within the scope of a handler. It may jump to the handler. *) | ConditionalHandle of { handler: int, continue: int } and basicBlock = BasicBlock of { block: x86ICode list, flow: controlFlow } (* Return the successor blocks from a control flow. *) val successorBlocks: controlFlow -> int list val printICodeAbstract: basicBlock vector * (string -> unit) -> unit val indexRegister: memoryIndex -> preg option (* Destinations used in move. *) datatype destinations = RegDest of reg | StackDest of int structure Sharing: sig type genReg = genReg and argument = argument and memoryIndex = memoryIndex and x86ICode = x86ICode and branchOps = branchOps and reg = reg and preg = preg and destinations = destinations and controlFlow = controlFlow and basicBlock = basicBlock and stackLocn = stackLocn and regProperty = regProperty and callKinds = callKinds and arithOp = arithOp and shiftType = shiftType and fpOps = fpOps and fpUnaryOps = fpUnaryOps and sse2UnaryOps = sse2UnaryOps and sse2BinaryOps = sse2BinaryOps and ccRef = ccRef and opSize = opSize and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86CODESIG.sml b/mlsource/MLCompiler/CodeTree/X86Code/X86CODESIG.sml index b3b45edd..8bac4058 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86CODESIG.sml +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86CODESIG.sml @@ -1,235 +1,227 @@ (* - Copyright David C. J. Matthews 2010, 2012, 2016-18 + Copyright David C. J. Matthews 2010, 2012, 2016-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 *) signature X86CODESIG = sig type machineWord = Address.machineWord type short = Address.short type address = Address.address type closureRef type code (* Registers. *) datatype genReg = GeneralReg of Word8.word * bool and fpReg = FloatingPtReg of Word8.word and xmmReg = SSE2Reg of Word8.word datatype reg = GenReg of genReg | FPReg of fpReg | XMMReg of xmmReg val is32bit: LargeInt.int -> bool val eax: genReg and ebx: genReg and ecx: genReg and edx: genReg and edi: genReg and esi: genReg and esp: genReg and ebp: genReg and r8: genReg and r9: genReg and r10: genReg and r11: genReg and r12: genReg and r13: genReg and r14: genReg and r15: genReg and fp0: fpReg and fp1: fpReg and fp2: fpReg and fp3: fpReg and fp4: fpReg and fp5: fpReg and fp6: fpReg and fp7: fpReg and xmm0:xmmReg and xmm1:xmmReg and xmm2:xmmReg and xmm3:xmmReg and xmm4:xmmReg and xmm5:xmmReg and xmm6:xmmReg (* For vector indexing we provide a numbering for the registers. *) val regs: int val regN: int -> reg val nReg: reg -> int val regRepr: reg -> string (* May be targeted at native 32-bit, native 64-bit or X86/64 with 32-bit words and addresses as object Ids. *) datatype targetArch = Native32Bit | Native64Bit | ObjectId32Bit val targetArch: targetArch type addrs val addrZero: addrs structure RegSet: sig eqtype regSet val singleton: reg -> regSet val allRegisters: regSet (* All registers: data, address, floating pt. *) val generalRegisters: regSet val floatingPtRegisters: regSet val sse2Registers: regSet val noRegisters: regSet val isAllRegs: regSet->bool val regSetUnion: regSet * regSet -> regSet val regSetIntersect: regSet * regSet -> regSet val listToSet: reg list -> regSet val setToList: regSet -> reg list val regSetMinus: regSet * regSet -> regSet val inSet: reg * regSet -> bool val cardinality: regSet -> int val regSetRepr: regSet -> string val oneOf: regSet -> reg end (* Size of operand. OpSize64 is only valid in 64-bit mode. *) datatype opSize = OpSize32 | OpSize64 datatype arithOp = ADD | OR (*|ADC | SBB*) | AND | SUB | XOR | CMP and shiftType = SHL | SHR | SAR and repOps = CMPS8 | MOVS8 | MOVS32 | STOS8 | STOS32 | MOVS64 | STOS64 and fpOps = FADD | FMUL | FCOM | FCOMP | FSUB | FSUBR | FDIV | FDIVR and fpUnaryOps = FABS | FCHS | FLD1 | FLDZ and branchOps = JO | JNO | JE | JNE | JL | JGE | JLE | JG | JB | JNB | JNA | JA | JP | JNP and sse2Operations = SSE2MoveDouble | SSE2MoveFloat | SSE2CompDouble | SSE2AddDouble | SSE2SubDouble | SSE2MulDouble | SSE2DivDouble | SSE2Xor | SSE2And | SSE2FloatToDouble | SSE2DoubleToFloat | SSE2CompSingle | SSE2AddSingle | SSE2SubSingle | SSE2MulSingle | SSE2DivSingle val invertTest: branchOps -> branchOps - datatype callKinds = - Recursive - | ConstantCode of machineWord - | FullCall - | DirectReg of genReg - datatype label = Label of { labelNo: int } datatype indexType = NoIndex | Index1 of genReg | Index2 of genReg | Index4 of genReg | Index8 of genReg type memoryAddress = { base: genReg, offset: int, index: indexType } datatype 'reg regOrMemoryArg = RegisterArg of 'reg | MemoryArg of memoryAddress | NonAddressConstArg of LargeInt.int | AddressConstArg of machineWord datatype moveSize = Move64 | Move32 | Move8 | Move16 | Move32X and fpSize = SinglePrecision | DoublePrecision datatype trapEntries = StackOverflowCall | StackOverflowCallEx | HeapOverflowCall datatype operation = Move of { source: genReg regOrMemoryArg, destination: genReg regOrMemoryArg, moveSize: moveSize } | PushToStack of genReg regOrMemoryArg | PopR of genReg | ArithToGenReg of { opc: arithOp, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } | ArithMemConst of { opc: arithOp, address: memoryAddress, source: LargeInt.int, opSize: opSize } | ArithMemLongConst of { opc: arithOp, address: memoryAddress, source: machineWord } | ArithByteMemConst of { opc: arithOp, address: memoryAddress, source: Word8.word } | ShiftConstant of { shiftType: shiftType, output: genReg, shift: Word8.word, opSize: opSize } | ShiftVariable of { shiftType: shiftType, output: genReg, opSize: opSize } (* Shift amount is in ecx *) | ConditionalBranch of { test: branchOps, label: label } | SetCondition of { output: genReg, test: branchOps } | LoadAddress of { output: genReg, offset: int, base: genReg option, index: indexType, opSize: opSize } | TestByteBits of { arg: genReg regOrMemoryArg, bits: Word8.word } | CallRTS of {rtsEntry: trapEntries, saveRegs: genReg list } | AllocStore of { size: int, output: genReg, saveRegs: genReg list } | AllocStoreVariable of { size: genReg, output: genReg, saveRegs: genReg list } | StoreInitialised - | CallFunction of callKinds - | JumpToFunction of callKinds + | CallAddress of genReg regOrMemoryArg + | JumpAddress of genReg regOrMemoryArg | ReturnFromFunction of int | RaiseException of { workReg: genReg } | UncondBranch of label | ResetStack of { numWords: int, preserveCC: bool } | JumpLabel of label | LoadLabelAddress of { label: label, output: genReg } | RepeatOperation of repOps | DivideAccR of {arg: genReg, isSigned: bool, opSize: opSize } | DivideAccM of {base: genReg, offset: int, isSigned: bool, opSize: opSize } | AtomicXAdd of {address: memoryAddress, output: genReg, opSize: opSize } | FPLoadFromMemory of { address: memoryAddress, precision: fpSize } | FPLoadFromFPReg of { source: fpReg, lastRef: bool } | FPLoadFromConst of { constant: machineWord, precision: fpSize } | FPStoreToFPReg of { output: fpReg, andPop: bool } | FPStoreToMemory of { address: memoryAddress, precision: fpSize, andPop: bool } | FPArithR of { opc: fpOps, source: fpReg } | FPArithConst of { opc: fpOps, source: machineWord, precision: fpSize } | FPArithMemory of { opc: fpOps, base: genReg, offset: int, precision: fpSize } | FPUnary of fpUnaryOps | FPStatusToEAX | FPLoadInt of { base: genReg, offset: int, opSize: opSize } | FPFree of fpReg | MultiplyR of { source: genReg regOrMemoryArg, output: genReg, opSize: opSize } | XMMArith of { opc: sse2Operations, source: xmmReg regOrMemoryArg, output: xmmReg } | XMMStoreToMemory of { toStore: xmmReg, address: memoryAddress, precision: fpSize } | XMMConvertFromInt of { source: genReg, output: xmmReg, opSize: opSize } | SignExtendForDivide of opSize | XChng of { reg: genReg, arg: genReg regOrMemoryArg, opSize: opSize } | Negative of { output: genReg, opSize: opSize } | JumpTable of { cases: label list, jumpSize: jumpSize ref } | IndexedJumpCalc of { addrReg: genReg, indexReg: genReg, jumpSize: jumpSize ref } | MoveXMMRegToGenReg of { source: xmmReg, output: genReg } | MoveGenRegToXMMReg of { source: genReg, output: xmmReg } | XMMShiftRight of { output: xmmReg, shift: Word8.word } | FPLoadCtrlWord of memoryAddress (* Load FP control word. *) | FPStoreCtrlWord of memoryAddress (* Store FP control word. *) | XMMLoadCSR of memoryAddress (* Load combined control/status word. *) | XMMStoreCSR of memoryAddress (* Store combined control/status word. *) | FPStoreInt of memoryAddress | XMMStoreInt of { source: xmmReg regOrMemoryArg, output: genReg, precision: fpSize, isTruncate: bool } | CondMove of { test: branchOps, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } and jumpSize = JumpSize2 | JumpSize8 type operations = operation list val printOperation: operation * (string -> unit) -> unit val codeCreate: string * machineWord * Universal.universal list -> code (* makes the initial segment. *) (* Code generate operations and construct the final code. *) val generateCode: { ops: operations, code: code, labelCount: int, resultClosure: closureRef } -> unit val memRegLocalMPointer: int and memRegHandlerRegister: int and memRegLocalMbottom: int and memRegStackLimit: int and memRegExceptionPacket: int and memRegCStackPtr: int and memRegThreadSelf: int and memRegStackPtr: int - and memRegSize: int (* Debugging controls and streams for optimiser. *) val lowLevelOptimise: code -> bool val printLowLevelCode: operation list * code -> unit structure Sharing: sig type code = code and reg = reg and genReg = genReg and fpReg = fpReg and addrs = addrs and operation = operation and regSet = RegSet.regSet and label = label and branchOps = branchOps - and callKinds = callKinds and arithOp = arithOp and shiftType = shiftType and repOps = repOps and fpOps = fpOps and fpUnaryOps = fpUnaryOps and sse2Operations = sse2Operations and opSize = opSize and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml index 84c2b547..bc1a0687 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86FOREIGNCALL.sml @@ -1,370 +1,372 @@ (* Copyright (c) 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 *) functor X86FOREIGNCALL( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef (* Optimise and code-generate. *) val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef} -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end structure DEBUG: DEBUGSIG structure CODE_ARRAY: CODEARRAYSIG sharing X86CODE.Sharing = X86OPTIMISE.Sharing = CODE_ARRAY.Sharing ): FOREIGNCALLSIG = struct open X86CODE open Address open CODE_ARRAY (* Unix X64. The first six arguments are in rdi, rsi, rdx, rcx, r8, r9. The rest are on the stack. Windows X64. The first four arguments are in rcx, rdx, r8 and r9. The rest are on the stack. The caller must ensure the stack is aligned on 16-byte boundary and must allocate 32-byte save area for the register args. rbx, rbp, rdi, rsi, rsp, r12-r15 are saved by the called function. X86/32. Arguments are pushed to the stack. ebx, edi, esi, ebp and esp are saved by the called function. We use esi to hold the argument data pointer and edi to save the ML stack pointer Our ML conventions use eax, ebx for the first two arguments in X86/32, rax, ebx, r8, r9, r10 for the first five arguments in X86/64 and rax, rsi, r8, r9 and r10 for the first five arguments in X86/64-32 bit. *) + + val memRegSize = 0 val (polyWordOpSize, nativeWordOpSize) = case targetArch of Native32Bit => (OpSize32, OpSize32) | Native64Bit => (OpSize64, OpSize64) | ObjectId32Bit => (OpSize32, OpSize64) (* Ebx/Rbx is used for the second argument on the native architectures but is replaced by esi on the object ID arch because ebx is used as the global base register. *) val mlArg2Reg = case targetArch of ObjectId32Bit => esi | _ => ebx exception InternalError = Misc.InternalError fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 val pushR = PushToStack o RegisterArg fun moveRR{source, output, opSize} = Move{source=RegisterArg source, destination=RegisterArg output, moveSize=opSizeToMove opSize} fun loadMemory(reg, base, offset, opSize) = Move{source=MemoryArg{base=base, offset=offset, index=NoIndex}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} and storeMemory(reg, base, offset, opSize) = Move{source=RegisterArg reg, destination=MemoryArg {base=base, offset=offset, index=NoIndex}, moveSize=opSizeToMove opSize} val loadHeapMemory = case targetArch of ObjectId32Bit => ( fn (reg, base, offset, opSize) => Move{source=MemoryArg{base=ebx, offset=offset, index=Index4 base}, destination=RegisterArg reg, moveSize=opSizeToMove opSize} ) | _ => loadMemory fun createProfileObject _ (*functionName*) = let (* The profile object is a single mutable with the F_bytes bit set. *) open Address val profileObject = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(profileObject, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in toMachineWord profileObject end val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" datatype abi = X86_32 | X64Win | X64Unix local (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val getABICall: unit -> int = RunCall.rtsCallFast0 "PolyGetABI" in fun getABI() = case getABICall() of 0 => X86_32 | 1 => X64Unix | 2 => X64Win | n => raise InternalError ("Unknown ABI type " ^ Int.toString n) end (* This is now the standard entry call code. *) datatype fastArgs = FastArgFixed | FastArgDouble | FastArgFloat fun rtsCallFastGeneral (functionName, argFormats, (*resultFormat*) _, debugSwitches) = let val entryPointAddr = makeEntryPoint functionName (* Get the ABI. On 64-bit Windows and Unix use different calling conventions. *) val abi = getABI() val entryPtrReg = if targetArch <> Native32Bit then r11 else ecx val nArgs = List.length argFormats local (* Compute stack space. The actual number of args passed is nArgs+1. *) val argSpace = case abi of X64Unix => Int.max(0, nArgs-6)*8 | X64Win => Int.max(0, nArgs-4)*8 | X86_32 => List.foldl(fn (FastArgDouble, n) => n+8 | (_, n) => n+4) 0 argFormats val align = argSpace mod 16 in (* Add sufficient space so that esp will be 16-byte aligned after we have pushed any arguments we need to push. *) val stackSpace = if align = 0 then memRegSize else memRegSize + 16 - align end (* The number of ML arguments passed on the stack. *) val mlArgsOnStack = Int.max(case abi of X86_32 => nArgs - 2 | _ => nArgs - 5, 0) val code = [ Move{source=AddressConstArg entryPointAddr, destination=RegisterArg entryPtrReg, moveSize=opSizeToMove polyWordOpSize}, (* Load the entry point ref. *) loadHeapMemory(entryPtrReg, entryPtrReg, 0, nativeWordOpSize)(* Load its value. *) ] @ ( (* Save heap ptr. This is in r15 in X86/64 *) if targetArch <> Native32Bit then [storeMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize)] (* Save heap ptr *) else [] ) @ ( if (case abi of X86_32 => nArgs >= 3 | _ => nArgs >= 6) then [moveRR{source=esp, output=edi, opSize=nativeWordOpSize}] (* Needed if we have to load from the stack. *) else [] ) @ [ storeMemory(esp, ebp, memRegStackPtr, nativeWordOpSize), (* Save ML stack and switch to C stack. *) loadMemory(esp, ebp, memRegCStackPtr, nativeWordOpSize), (* Set the stack pointer past the data on the stack. For Windows/64 add in a 32 byte save area *) ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg(LargeInt.fromInt stackSpace), opSize=nativeWordOpSize} ] @ ( case abi of (* Set the argument registers. *) X86_32 => let fun pushReg(reg, FastArgFixed) = [pushR reg] | pushReg(reg, FastArgDouble) = (* reg contains the address of the value. This must be unboxed onto the stack. *) [ FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=DoublePrecision}, ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 8, opSize=nativeWordOpSize}, FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=DoublePrecision, andPop=true } ] | pushReg(reg, FastArgFloat) = (* reg contains the address of the value. This must be unboxed onto the stack. *) [ FPLoadFromMemory{address={base=reg, offset=0, index=NoIndex}, precision=SinglePrecision}, ArithToGenReg{ opc=SUB, output=esp, source=NonAddressConstArg 4, opSize=nativeWordOpSize}, FPStoreToMemory{ address={base=esp, offset=0, index=NoIndex}, precision=SinglePrecision, andPop=true } ] (* The stack arguments have to be copied first followed by the ebx and finally eax. *) fun pushArgs (_, []) = [] | pushArgs (_, [argType]) = pushReg(eax, argType) | pushArgs (_, [arg2Type, arg1Type]) = pushReg(ebx, arg2Type) @ pushReg(eax, arg1Type) | pushArgs (n, FastArgFixed :: argTypes) = PushToStack(MemoryArg{base=edi, offset=(nArgs-n+1)* 4, index=NoIndex}) :: pushArgs(n-1, argTypes) | pushArgs (n, argType :: argTypes) = (* Use esi as a temporary register. *) loadMemory(esi, edi, (nArgs-n+1)* 4, polyWordOpSize) :: pushReg(esi, argType) @ pushArgs(n-1, argTypes) in pushArgs(nArgs, List.rev argFormats) end | X64Unix => ( if List.all (fn FastArgFixed => true | _ => false) argFormats then let fun pushArgs 0 = [] | pushArgs 1 = [moveRR{source=eax, output=edi, opSize=polyWordOpSize}] | pushArgs 2 = moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize} :: pushArgs 1 | pushArgs 3 = moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs 4 = moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: pushArgs 3 | pushArgs 5 = (* We have to move r8 into edx before we can move r10 into r8 *) moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs 6 = (* We have to move r9 into edi before we can load r9 from the stack. *) moveRR{source=r8, output=edx, opSize=polyWordOpSize} :: moveRR{source=r9, output=ecx, opSize=polyWordOpSize} :: loadMemory(r9, edi, 8, polyWordOpSize) :: moveRR{source=r10, output=r8, opSize=polyWordOpSize} :: pushArgs 2 | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" in pushArgs nArgs end else case argFormats of [] => [] | [FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed] => (* Since mlArgs2Reg is esi on 32-in-64 this is redundant. *) [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, moveRR{source=r8, output=edx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=mlArg2Reg, output=esi, opSize=polyWordOpSize}, moveRR{source=eax, output=edi, opSize=polyWordOpSize}, moveRR{source=r8, output=edx, opSize=polyWordOpSize}, moveRR{source=r9, output=ecx, opSize=polyWordOpSize} ] (* One "double" argument. The value needs to be unboxed. *) | [FastArgDouble] => [] (* Already in xmm0 *) (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) | [FastArgDouble, FastArgDouble] => [] | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edi, opSize=nativeWordOpSize} ] | [FastArgFloat] => [] (* Already in xmm0 *) | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) (* One float argument and one fixed. *) | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edi, opSize=polyWordOpSize} ] | _ => raise InternalError "rtsCall: Abi/argument count not implemented" ) | X64Win => ( if List.all (fn FastArgFixed => true | _ => false) argFormats then let fun pushArgs 0 = [] | pushArgs 1 = [moveRR{source=eax, output=ecx, opSize=polyWordOpSize}] | pushArgs 2 = moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} :: pushArgs 1 | pushArgs 3 = (* Already in r8 *) pushArgs 2 | pushArgs 4 = (* Already in r9, and r8 *) pushArgs 2 | pushArgs 5 = pushR r10 :: pushArgs 2 | pushArgs 6 = PushToStack(MemoryArg{base=edi, offset=8, index=NoIndex}) :: pushArgs 5 | pushArgs _ = raise InternalError "rtsCall: Abi/argument count not implemented" in pushArgs nArgs end else case argFormats of [FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} ] | [FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8. *) ] | [FastArgFixed, FastArgFixed, FastArgFixed, FastArgFixed] => [ moveRR{source=eax, output=ecx, opSize=polyWordOpSize}, moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize} (* Arg3 is already in r8 and arg4 in r9. *) ] | [FastArgDouble] => [ (* Already in xmm0 *) ] (* X64 on both Windows and Unix take the first arg in xmm0 and the second in xmm1. They are already there. *) | [FastArgDouble, FastArgDouble] => [ ] (* X64 on both Windows and Unix take the first arg in xmm0. On Unix the integer argument is treated as the first argument and goes into edi. On Windows it's treated as the second and goes into edx. N.B. It's also the first argument in ML so is in rax. *) | [FastArgDouble, FastArgFixed] => [ moveRR{source=eax, output=edx, opSize=nativeWordOpSize} ] | [FastArgFloat] => [] | [FastArgFloat, FastArgFloat] => [] (* Already in xmm0 and xmm1 *) | [FastArgFloat, FastArgFixed] => [moveRR{source=mlArg2Reg, output=edx, opSize=polyWordOpSize}] | _ => raise InternalError "rtsCall: Abi/argument count not implemented" ) ) @ (* For Windows/64 add in a 32 byte save area ater we've pushed any arguments. *) (case abi of X64Win => [ArithToGenReg{opc=SUB, output=esp, source=NonAddressConstArg 32, opSize=nativeWordOpSize}] | _ => []) @ [ - CallFunction(DirectReg entryPtrReg), (* Call the function *) + CallAddress(RegisterArg entryPtrReg), (* Call the function *) loadMemory(esp, ebp, memRegStackPtr, nativeWordOpSize) (* Restore the ML stack pointer. *) ] @ ( if targetArch <> Native32Bit then [loadMemory(r15, ebp, memRegLocalMPointer, nativeWordOpSize) ] (* Copy back the heap ptr *) else [] ) @ [ (* Since this is an ML function we need to remove any ML stack arguments. *) ReturnFromFunction mlArgsOnStack ] val profileObject = createProfileObject functionName val newCode = codeCreate (functionName, profileObject, debugSwitches) val closure = makeConstantClosure() val () = X86OPTIMISE.generateCode{code=newCode, labelCount=0, ops=code, resultClosure=closure} in closureAsAddress closure end fun rtsCallFast (functionName, nArgs, debugSwitches) = rtsCallFastGeneral (functionName, List.tabulate(nArgs, fn _ => FastArgFixed), FastArgFixed, debugSwitches) (* RTS call with one double-precision floating point argument and a floating point result. *) fun rtsCallFastRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with two double-precision floating point arguments and a floating point result. *) fun rtsCallFastRealRealtoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgDouble], FastArgDouble, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastRealGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgDouble, FastArgFixed], FastArgDouble, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoReal (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgDouble, debugSwitches) (* Operations on Real32.real values. *) fun rtsCallFastFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat], FastArgFloat, debugSwitches) fun rtsCallFastFloatFloattoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFloat], FastArgFloat, debugSwitches) (* RTS call with one double-precision floating point argument, one fixed point argument and a floating point result. *) fun rtsCallFastFloatGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFloat, FastArgFixed], FastArgFloat, debugSwitches) (* RTS call with one general (i.e. ML word) argument and a floating point result. This is used only to convert arbitrary precision values to floats. *) fun rtsCallFastGeneraltoFloat (functionName, debugSwitches) = rtsCallFastGeneral (functionName, [FastArgFixed], FastArgFloat, debugSwitches) end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86ICode.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86ICode.ML index 7d2cfee4..fbbcd76b 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86ICode.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86ICode.ML @@ -1,930 +1,933 @@ (* - Copyright David C. J. Matthews 2016-18 + Copyright David C. J. Matthews 2016-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 *) functor X86ICode( structure X86CODE: X86CODESIG ): ICodeSig = struct open X86CODE open Address datatype fpMode = FPModeSSE2 | FPModeX87 (* For the moment use SSE2 only on X86/64. Not all 32-bit processors support SSE2. *) val fpMode: fpMode = case targetArch of Native32Bit => FPModeX87 | _ => FPModeSSE2 val (polyWordOpSize, nativeWordOpSize) = case targetArch of Native32Bit => (OpSize32, OpSize32) | Native64Bit => (OpSize64, OpSize64) | ObjectId32Bit => (OpSize32, OpSize64) datatype preg = PReg of int (* A pseudo-register - an abstract register. *) (* A location on the stack. May be more than word if this is a container or a handler entry. *) datatype stackLocn = StackLoc of {size: int, rno: int } (* This combines pregKind and stackLocn. *) datatype regProperty = RegPropGeneral (* A general register. *) | RegPropUntagged (* An untagged general register. *) | RegPropStack of int (* A stack location or container. *) | RegPropCacheTagged | RegPropCacheUntagged | RegPropMultiple (* The result of a conditional or case. May be defined at multiple points. *) datatype argument = RegisterArgument of preg | AddressConstant of machineWord (* A constant that is an address. *) | IntegerConstant of LargeInt.int (* A non-address constant. Will usually be shifted and tagged. *) | MemoryLocation of { base: preg, offset: int, index: memoryIndex, cache: preg option } (* A memory location. Could be the stack. *) (* Offset on the stack. The container is the stack location identifier, the field is an offset in a container. cache is an optional cache register. *) | StackLocation of { wordOffset: int, container: stackLocn, field: int, cache: preg option } (* Address of a container. *) | ContainerAddr of { container: stackLocn, stackOffset: int } (* Generally this indicates the index register if present. For 32-in-64 the "index" may be ObjectIndex in which case the base is actually an object index. *) and memoryIndex = NoMemIndex | MemIndex1 of preg | MemIndex2 of preg | MemIndex4 of preg | MemIndex8 of preg | ObjectIndex (* Kinds of moves. Move32Bit - 32-bit loads and stores Move64Bit - 64-bit loads and stores MoveByte - When loading, load a byte and zero extend. Move16Bit - Used for C-memory loads and stores. Zero extends on load. MoveFloat - Load and store a single-precision value MoveDouble - Load and store a double-precision value. *) datatype moveKind = MoveByte | Move16Bit | Move32Bit | Move64Bit | MoveFloat | MoveDouble (* The reference to a condition code. *) and ccRef = CcRef of int val (movePolyWord, moveNativeWord) = case targetArch of Native32Bit => (Move32Bit, Move32Bit) | Native64Bit => (Move64Bit, Move64Bit) | ObjectId32Bit => (Move32Bit, Move64Bit) datatype boxKind = BoxLargeWord | BoxSSE2Double | BoxSSE2Float | BoxX87Double | BoxX87Float - + (* Size of operand. OpSize64 is only valid in 64-bit mode. *) datatype opSize = datatype opSize datatype sse2UnaryOps = SSE2UDoubleToFloat | SSE2UFloatToDouble and sse2BinaryOps = SSE2BAddDouble | SSE2BSubDouble | SSE2BMulDouble | SSE2BDivDouble | SSE2BXor | SSE2BAnd | SSE2BAddSingle | SSE2BSubSingle | SSE2BMulSingle | SSE2BDivSingle + datatype callKinds = + Recursive + | ConstantCode of machineWord + | FullCall + datatype x86ICode = (* Move a value into a register. *) LoadArgument of { source: argument, dest: preg, kind: moveKind } (* Store a value into memory. The source will usually be a register but could be a constant depending on the value. If isMutable is true we're assigning to a ref and we need to flush the memory cache. *) | StoreArgument of { source: argument, base: preg, offset: int, index: memoryIndex, kind: moveKind, isMutable: bool } (* Load an entry from the "memory registers". Used just for ThreadSelf. *) | LoadMemReg of { offset: int, dest: preg } (* Start of function. Set the register arguments. stackArgs is the list of stack arguments. The last entry is the return address. If the function has a real closure regArgs includes the closure register (rdx). *) | BeginFunction of { regArgs: (preg * reg) list, stackArgs: stackLocn list } (* Call a function. If the code address is a constant it is passed here. Otherwise the address is obtained by indirecting through rdx which has been loaded as one of the argument registers. The result is stored in the destination register. *) | FunctionCall of { callKind: callKinds, regArgs: (argument * reg) list, stackArgs: argument list, dest: preg, realDest: reg, saveRegs: preg list} (* Jump to a tail-recursive function. This is similar to FunctionCall but complicated for stack arguments because the stack and the return address need to be overwritten. stackAdjust is the number of words to remove (positive) or add (negative) to the stack before the call. currStackSize contains the number of items currently on the stack. *) | TailRecursiveCall of { callKind: callKinds, regArgs: (argument * reg) list, stackArgs: {src: argument, stack: int} list, stackAdjust: int, currStackSize: int, workReg: preg } (* Allocate a fixed sized piece of memory. The size is the number of words required. This sets the length word including the flags bits. saveRegs is the list of registers that need to be saved if we need to do a garbage collection. *) | AllocateMemoryOperation of { size: int, flags: Word8.word, dest: preg, saveRegs: preg list } (* Allocate a piece of memory whose size is not known at compile-time. The size argument is the number of words. *) | AllocateMemoryVariable of { size: preg, dest: preg, saveRegs: preg list } (* Initialise a piece of memory. N.B. The size is an untagged value containing the number of words. This uses REP STOSL/Q so addr must be rdi, size must be rcx and init must be rax. *) | InitialiseMem of { size: preg, addr: preg, init: preg } (* Signal that a tuple has been fully initialised. Really a check in the low-level code-generator. *) | InitialisationComplete (* Mark the beginning of a loop. This is really only to prevent the initialisation code being duplicated in ICodeOptimise. *) | BeginLoop (* Set up the registers for a jump back to the start of a loop. *) | JumpLoop of { regArgs: (argument * preg) list, stackArgs: (argument * int * stackLocn) list, checkInterrupt: preg list option, workReg: preg option } (* Raise an exception. The packet is always loaded into rax. *) | RaiseExceptionPacket of { packetReg: preg } (* Reserve a contiguous area on the stack to receive a result tuple. *) | ReserveContainer of { size: int, container: stackLocn } (* Indexed case. *) | IndexedCaseOperation of { testReg: preg, workReg: preg } (* Lock a mutable cell by turning off the mutable bit. *) | LockMutable of { addr: preg } (* Compare two word values. The first argument must be a register. *) | WordComparison of { arg1: preg, arg2: argument, ccRef: ccRef, opSize: opSize } (* Compare with a literal. This is generally used to compare a memory or stack location with a literal and overlaps to some extent with WordComparison. *) | CompareLiteral of { arg1: argument, arg2: LargeInt.int, opSize: opSize, ccRef: ccRef } (* Compare a byte location with a literal. This is the only operation that specifically deals with single bytes. Other cases will use word operations. *) | CompareByteMem of { arg1: { base: preg, offset: int, index: memoryIndex }, arg2: Word8.word, ccRef: ccRef } (* Exception handling. - Set up an exception handler. *) | PushExceptionHandler of { workReg: preg } (* End of a handled section. Restore the previous handler. *) | PopExceptionHandler of { workReg: preg } (* Marks the start of a handler. This sets the stack pointer and restores the old handler. Sets the exception packet register. *) | BeginHandler of { packetReg: preg, workReg: preg } (* Return from the function. *) | ReturnResultFromFunction of { resultReg: preg, realReg: reg, numStackArgs: int } (* Arithmetic or logical operation. These can set the condition codes. *) | ArithmeticFunction of { oper: arithOp, resultReg: preg, operand1: preg, operand2: argument, ccRef: ccRef, opSize: opSize } (* Test the tag bit of a word. Sets the Zero bit if the value is an address i.e. untagged. *) | TestTagBit of { arg: argument, ccRef: ccRef } (* Push a value to the stack. Added during translation phase. *) | PushValue of { arg: argument, container: stackLocn } (* Copy a value to a cache register. LoadArgument could be used for this but it may be better to keep it separate. *) | CopyToCache of { source: preg, dest: preg, kind: moveKind } (* Remove items from the stack. Added during translation phase. *) | ResetStackPtr of { numWords: int, preserveCC: bool } (* Store a value into the stack. *) | StoreToStack of { source: argument, container: stackLocn, field: int, stackOffset: int } (* Tag a value by shifting and setting the tag bit. *) | TagValue of { source: preg, dest: preg, isSigned: bool, opSize: opSize } (* Shift a value to remove the tag bit. The cache is used if this is untagging a value that has previously been tagged. *) | UntagValue of { source: preg, dest: preg, isSigned: bool, cache: preg option, opSize: opSize } (* This provides the LEA instruction which can be used for various sorts of arithmetic. The base register is optional in this case. *) | LoadEffectiveAddress of { base: preg option, offset: int, index: memoryIndex, dest: preg, opSize: opSize } (* Shift a word by an amount that can either be a constant or a register. *) | ShiftOperation of { shift: shiftType, resultReg: preg, operand: preg, shiftAmount: argument, ccRef: ccRef, opSize: opSize } (* Multiplication. We can use signed multiplication for both fixed precision and word (unsigned) multiplication. There are various forms of the instruction including a three-operand version. *) | Multiplication of { resultReg: preg, operand1: preg, operand2: argument, ccRef: ccRef, opSize: opSize } (* Division. This takes a register pair, always RDX:RAX, divides it by the operand register and puts the quotient in RAX and remainder in RDX. At the preg level we represent all of these by pRegs. The divisor can be either a register or a memory location. *) | Division of { isSigned: bool, dividend: preg, divisor: argument, quotient: preg, remainder: preg, opSize: opSize } (* Atomic exchange and addition. This is executed with a lock prefix and is used for atomic increment and decrement for mutexes. Before the operation the source contains an increment. After the operation the source contains the old value of the destination and the destination has been updated with its old value added to the increment. The destination is actually the word pointed at by "base". *) | AtomicExchangeAndAdd of { base: preg, source: preg } (* Create a "box" of a single-word "byte" cell and store the source into it. This can be implemented using AllocateMemoryOperation but the idea is to allow the transform layer to recognise when a value is being boxed and then unboxed and remove unnecessary allocation. *) | BoxValue of { boxKind: boxKind, source: preg, dest: preg, saveRegs: preg list } (* Compare two vectors of bytes and set the condition code on the result. In general vec1Addr and vec2Addr will be pointers inside memory cells so have to be untagged registers. *) | CompareByteVectors of { vec1Addr: preg, vec2Addr: preg, length: preg, ccRef: ccRef } (* Move a block of bytes (isByteMove true) or words (isByteMove false). The length is the number of items (bytes or words) to move. *) | BlockMove of { srcAddr: preg, destAddr: preg, length: preg, isByteMove: bool } (* Floating point comparison. *) | X87Compare of { arg1: preg, arg2: argument, isDouble: bool, ccRef: ccRef } (* Floating point comparison. *) | SSE2Compare of { arg1: preg, arg2: argument, isDouble: bool, ccRef: ccRef } (* The X87 FP unit does not generate condition codes directly. We have to load the cc into RAX and test it there. *) | X87FPGetCondition of { ccRef: ccRef, dest: preg } (* Binary floating point operations on the X87. *) | X87FPArith of { opc: fpOps, resultReg: preg, arg1: preg, arg2: argument, isDouble: bool } (* Floating point operations: negate and set sign positive. *) | X87FPUnaryOps of { fpOp: fpUnaryOps, dest: preg, source: preg } (* Load a fixed point value as a floating point value. *) | X87Float of { dest: preg, source: argument } (* Load a fixed point value as a floating point value. *) | SSE2Float of { dest: preg, source: argument } (* Binary floating point operations using SSE2 instructions. *) | SSE2FPUnary of { opc: sse2UnaryOps, resultReg: preg, source: argument } (* Binary floating point operations using SSE2 instructions. *) | SSE2FPBinary of { opc: sse2BinaryOps, resultReg: preg, arg1: preg, arg2: argument } (* Tag a 32-bit floating point value. This is tagged by shifting left 32-bits and then setting the bottom bit. This allows memory operands to be untagged simply by loading the high-order word. *) | TagFloat of { source: preg, dest: preg } (* Untag a 32-bit floating point value into a XMM register. If the source is in memory we just need to load the high-order word. *) | UntagFloat of { source: argument, dest: preg, cache: preg option } (* Get and set the control registers. These all have to work through memory but it's simpler to assume they work through registers. *) | GetSSE2ControlReg of { dest: preg } | SetSSE2ControlReg of { source: preg } | GetX87ControlReg of { dest: preg } | SetX87ControlReg of { source: preg } (* Convert a floating point value to an integer. *) | X87RealToInt of { source: preg, dest: preg } (* Convert a floating point value to an integer. *) | SSE2RealToInt of { source: argument, dest: preg, isDouble: bool, isTruncate: bool } (* Sign extend a 32-bit value to 64-bits. Not included in LoadArgument because that assumes that if we have the result in a register we can simply reuse the register. *) | SignExtend32To64 of { source: argument, dest: preg } (* Destinations at the end of a basic block. *) and controlFlow = (* Unconditional branch to a label - should be a merge point. *) Unconditional of int (* Conditional branch. Jumps to trueJump if the condional is true, falseJump if false. *) | Conditional of { ccRef: ccRef, condition: branchOps, trueJump: int, falseJump: int } (* Exit - the last instruction of the block is a return, raise or tailcall. *) | ExitCode (* Indexed case - this branches to one of a number of labels *) | IndexedBr of int list (* Set up a handler. This doesn't cause an immediate branch but the state at the start of the handler is the state at this point. *) | SetHandler of { handler: int, continue: int } (* Unconditional branch to a handler. If an exception is raised explicitly within the scope of a handler. *) | UnconditionalHandle of int (* Conditional branch to a handler. Occurs if there is a call to a function within the scope of a handler. It may jump to the handler. *) | ConditionalHandle of { handler: int, continue: int } and basicBlock = BasicBlock of { block: x86ICode list, flow: controlFlow } (* Return the list of blocks that are the immediate successor of this. *) fun successorBlocks(Unconditional l) = [l] | successorBlocks(Conditional{trueJump, falseJump, ...}) = [trueJump, falseJump] | successorBlocks ExitCode = [] | successorBlocks(IndexedBr cases) = cases | successorBlocks(SetHandler{handler, continue, ...}) = [handler, continue] (* We only need "handler" in SetHandler because we may have a handler that is never actually jumped to. *) | successorBlocks(UnconditionalHandle handler) = [handler] | successorBlocks(ConditionalHandle{handler, continue, ...}) = [handler, continue] datatype destinations = RegDest of reg | StackDest of int local fun printReg(PReg i, stream) = stream("R" ^ Int.toString i) and printCC(CcRef ccRef, stream) = stream ("CC" ^ Int.toString ccRef) fun printIndex(NoMemIndex, _) = () | printIndex(MemIndex1 i, stream) = (stream "["; printReg(i, stream); stream "*1]") | printIndex(MemIndex2 i, stream) = (stream "["; printReg(i, stream); stream "*2]") | printIndex(MemIndex4 i, stream) = (stream "["; printReg(i, stream); stream "*4]") | printIndex(MemIndex8 i, stream) = (stream "["; printReg(i, stream); stream "*8]") | printIndex(ObjectIndex, stream) = stream "[objectindex]" fun printStackLoc(StackLoc{size, rno}, stream) = (stream "S"; stream(Int.toString rno); stream "("; stream(Int.toString size); stream ")") fun printOpsize(OpSize32, stream) = stream "32" | printOpsize(OpSize64, stream) = stream "64" fun printArg(RegisterArgument reg, stream) = printReg(reg, stream) | printArg(AddressConstant m, stream) = stream(stringOfWord m) | printArg(IntegerConstant i, stream) = stream(LargeInt.toString i) | printArg(MemoryLocation{base, offset, index, cache, ...}, stream) = ( stream(Int.toString offset ^ "("); printReg(base, stream); stream ")"; printIndex(index, stream); case cache of NONE => () | SOME r => (stream " cache "; printReg(r, stream)) ) | printArg(StackLocation{wordOffset, container, field, cache, ...}, stream) = ( printStackLoc(container, stream); stream " + "; stream(Int.toString field); stream " ("; stream(Int.toString wordOffset); stream ")"; case cache of NONE => () | SOME r => (stream " cache "; printReg(r, stream)) ) | printArg(ContainerAddr{stackOffset, container}, stream) = ( stream "@"; printStackLoc(container, stream); stream " ("; stream(Int.toString stackOffset); stream ")" ) fun printSaves([], _) = () | printSaves([areg], stream) = printReg(areg, stream) | printSaves(areg::more, stream) = (printReg(areg, stream); stream ","; printSaves(more, stream)) fun printKind(Move64Bit, stream) = stream "64Bit" | printKind(MoveByte, stream) = stream "Byte" | printKind(Move16Bit, stream) = stream "16Bit" | printKind(Move32Bit, stream) = stream "32Bit" | printKind(MoveFloat, stream) = stream "Float" | printKind(MoveDouble, stream) = stream "Double"; fun printICode(LoadArgument{source, dest, kind}, stream) = ( stream "\tLoad"; printKind(kind, stream); stream "\t"; printArg(source, stream); stream " => "; printReg(dest, stream) ) | printICode(StoreArgument{source, base, offset, index, kind, ...}, stream) = ( case kind of Move64Bit => stream "\tStore64Bit\t" | MoveByte => stream "\tStoreByte\t" | Move16Bit => stream "\tStore16Bit\t" | Move32Bit => stream "\tStore32Bit\t" | MoveFloat => stream "\tStoreFloat\t" | MoveDouble => stream "\tStoreDouble\t"; printArg(source, stream); stream " => "; stream(Int.toString offset ^ "("); printReg(base, stream); stream ")"; printIndex(index, stream) ) | printICode(LoadMemReg { offset, dest}, stream) = ( stream "\tLoadMemReg\t"; stream(Int.toString offset); stream " => "; printReg(dest, stream) ) | printICode(BeginFunction {regArgs, stackArgs}, stream) = ( stream "\tBeginFunction\t"; List.app(fn (arg, r) => (stream(regRepr r); stream "="; printReg(arg, stream); stream " ")) regArgs; List.app(fn s => printStackLoc(s, stream)) stackArgs ) | printICode(FunctionCall{callKind, regArgs, stackArgs, dest, realDest, saveRegs}, stream) = ( stream "\tFunctionCall\t"; case callKind of Recursive => stream "recursive " | ConstantCode m => (stream(stringOfWord m); stream " ") - | FullCall => () - | DirectReg r => (stream(regRepr(GenReg r)); stream " "); + | FullCall => (); List.app(fn (arg, r) => (stream(regRepr r); stream "="; printArg(arg, stream); stream " ")) regArgs; List.app(fn arg => (stream "p="; printArg(arg, stream); stream " ")) stackArgs; stream "=> "; printReg(dest, stream); stream "="; stream(regRepr realDest); stream " save="; printSaves(saveRegs, stream) ) | printICode(TailRecursiveCall{callKind, regArgs, stackArgs, stackAdjust, currStackSize, workReg}, stream) = ( stream "\tTailCall\t"; case callKind of Recursive => stream "recursive " | ConstantCode m => (stream(stringOfWord m); stream " ") - | FullCall => () - | DirectReg r => (stream(regRepr(GenReg r)); stream " "); + | FullCall => (); List.app(fn (arg, r) => (stream(regRepr r); stream "="; printArg(arg, stream); stream " ")) regArgs; List.app(fn {src, stack} => (stream (Int.toString stack); stream "<="; printArg(src, stream); stream " ")) stackArgs; stream "adjust="; stream(Int.toString stackAdjust); stream "stackSize="; stream(Int.toString currStackSize); stream " work reg="; printReg(workReg, stream) ) | printICode(AllocateMemoryOperation{size, flags, dest, saveRegs}, stream) = ( stream "\tAllocateMemory\t"; stream(concat["s=", Int.toString size, ",f=", Word8.toString flags, " => "]); printReg(dest, stream); stream " save="; printSaves(saveRegs, stream) ) | printICode(AllocateMemoryVariable{size, dest, saveRegs}, stream) = ( stream "\tAllocateMemory\t"; stream "s="; printReg(size, stream); stream " => "; printReg(dest, stream); stream " save="; printSaves(saveRegs, stream) ) | printICode(InitialiseMem{size, addr, init}, stream) = ( stream "\tInitialiseMem\t"; stream "s="; printReg(size, stream); stream ",i="; printReg(init, stream); stream ",a="; printReg(addr, stream) ) | printICode(InitialisationComplete, stream) = stream "\tInitComplete" | printICode(BeginLoop, stream) = stream "\tBeginLoop" | printICode(JumpLoop{regArgs, stackArgs, checkInterrupt, workReg, ... }, stream) = ( stream "\tJumpLoop\t"; List.app( fn (source, loopReg) => (printReg(loopReg, stream); stream "="; printArg(source, stream); stream " ") ) regArgs; List.app( fn (source, stack, stackLocn) => (printStackLoc(stackLocn, stream); stream("(sp" ^ Int.toString stack); stream ")="; printArg(source, stream); stream " ") ) stackArgs; case checkInterrupt of NONE => () | SOME saveRegs => (stream " Check:save="; printSaves(saveRegs, stream)); case workReg of NONE => () | SOME r => (stream " work reg="; printReg(r, stream)) ) | printICode(RaiseExceptionPacket{packetReg}, stream) = (stream "\tRaise\t"; printReg(packetReg, stream)) | printICode(ReserveContainer{size, container}, stream) = (stream "\tReserveContainer\t"; stream(Int.toString size); stream " => "; printStackLoc(container, stream)) | printICode(IndexedCaseOperation{testReg, workReg}, stream) = ( stream "\tIndexedCase\t"; stream "test="; printReg(testReg, stream); stream "work="; printReg(workReg, stream) ) | printICode(LockMutable{addr}, stream) = (stream "\tLockMutable\t"; printReg(addr, stream)) | printICode(WordComparison{arg1, arg2, ccRef, opSize, ...}, stream) = ( stream "\tWordComparison"; printOpsize(opSize, stream); stream "\t"; printReg(arg1, stream); stream ","; printArg(arg2, stream); stream " => "; printCC(ccRef, stream) ) | printICode(CompareLiteral{arg1, arg2, opSize, ccRef, ...}, stream) = ( stream "\tCompareLiteral"; printOpsize(opSize, stream); stream "\t"; printArg(arg1, stream); stream ","; stream(LargeInt.toString arg2); stream " => "; printCC(ccRef, stream) ) | printICode(CompareByteMem{arg1={base, offset, index, ...}, arg2, ccRef,...}, stream) = ( stream "\tCompareByteMem\t"; stream(Int.toString offset ^ "("); printReg(base, stream); stream ")"; printIndex(index, stream); stream ","; stream(Word8.toString arg2); stream " => "; printCC(ccRef, stream) ) | printICode(PushExceptionHandler{workReg }, stream) = ( stream "\tPushExcHandler\twith "; printReg(workReg, stream) ) | printICode(PopExceptionHandler{workReg}, stream) = ( stream "\tPopExceptionHandler\t"; stream "with "; printReg(workReg, stream) ) | printICode(BeginHandler{packetReg, workReg}, stream) = ( stream "\tBeginHandler\t"; printReg(packetReg, stream); stream " with "; printReg(workReg, stream) ) | printICode(ReturnResultFromFunction{resultReg, realReg, numStackArgs}, stream) = ( stream "\tReturnFromFunction\t"; printReg(resultReg, stream); stream "="; stream(regRepr realReg); stream("," ^ Int.toString numStackArgs) ) | printICode(ArithmeticFunction{oper, resultReg, operand1, operand2, ccRef, opSize, ...}, stream) = ( case oper of ADD => stream "\tAdd" | OR => stream "\tOrBits" | AND => stream "\tAndBits" | SUB => stream "\tSubtract" | XOR => stream "\tExclusiveOrBits" | CMP => stream "\tCompare"; printOpsize(opSize, stream); stream "\t"; printReg(operand1, stream); stream ","; printArg(operand2, stream); stream " => "; printReg(resultReg, stream); stream " => "; printCC(ccRef, stream) ) | printICode(TestTagBit{arg, ccRef, ...}, stream) = (stream "\tTestTagBit\t"; printArg(arg, stream); stream " => "; printCC(ccRef, stream)) | printICode(PushValue{arg, container}, stream) = (stream "\tPushValue\t"; printArg(arg, stream); stream " => "; printStackLoc(container, stream)) | printICode(CopyToCache{source, dest, kind}, stream) = (stream "\tCopyToCache"; printKind(kind, stream); stream "\t"; printReg(source, stream); stream " => "; printReg(dest, stream)) | printICode(ResetStackPtr{numWords, preserveCC}, stream) = ( stream "\tResetStackPtr\t"; stream(Int.toString numWords); if preserveCC then stream " preserve CC" else () ) | printICode(StoreToStack{source, container, field, stackOffset}, stream) = ( stream "\tStoreToStack\t"; printArg(source, stream); stream " => "; printStackLoc(container, stream); stream "+"; stream (Int.toString field); stream "("; stream(Int.toString stackOffset); stream ")" ) | printICode(TagValue{source, dest, opSize, ...}, stream) = ( stream "\tTagValue"; printOpsize(opSize, stream); stream "\t"; printReg(source, stream); stream " => "; printReg(dest, stream) ) | printICode(UntagValue{source, dest, isSigned, cache, opSize}, stream) = ( stream "\tUntag"; stream(if isSigned then "Signed" else "Unsigned"); printOpsize(opSize, stream); stream "\t"; printReg(source, stream); stream " => "; printReg(dest, stream); case cache of NONE => () | SOME c => (stream " cache "; printReg(c, stream)) ) | printICode(LoadEffectiveAddress{base, offset, index, dest, opSize}, stream) = ( stream "\tLoadEffectiveAddr"; printOpsize(opSize, stream); stream "\t"; stream(Int.toString offset ^ "("); case base of NONE => stream "_" | SOME b => printReg(b, stream); stream ")"; printIndex(index, stream); stream " => "; printReg(dest, stream) ) | printICode(ShiftOperation{shift, resultReg, operand, shiftAmount, ccRef, opSize, ...}, stream) = ( case shift of SHL => stream "\tShiftLeft" | SHR => stream "\tShiftRLogical" | SAR => stream "\tShiftRArith"; printOpsize(opSize, stream); stream "\t"; printReg(operand, stream); stream ","; printArg(shiftAmount, stream); stream " => "; printReg(resultReg, stream); stream " => "; printCC(ccRef, stream) ) | printICode(Multiplication{resultReg, operand1, operand2, ccRef, opSize, ...}, stream) = ( stream "\tMultiplication"; printOpsize(opSize, stream); stream "\t"; printReg(operand1, stream); stream ","; printArg(operand2, stream); stream " => "; printReg(resultReg, stream); stream " => "; printCC(ccRef, stream) ) | printICode(Division{isSigned, dividend, divisor, quotient, remainder, opSize}, stream) = ( stream "\tDivision"; stream(if isSigned then "Signed\t" else "Unsigned\t"); printOpsize(opSize, stream); stream "\t"; printReg(dividend, stream); stream " by "; printArg(divisor, stream); stream " => "; printReg(quotient, stream); stream " rem "; printReg(remainder, stream) ) | printICode(AtomicExchangeAndAdd{base, source}, stream) = ( stream "\tAtomicExchangeAdd\t"; stream "addr=0("; printReg(base, stream); stream "),with="; printReg(source, stream) ) | printICode(BoxValue{boxKind, source, dest, saveRegs}, stream) = ( stream( case boxKind of BoxLargeWord => "\tBoxLarge\t" | BoxX87Double => "\tBoxX87Double\t" | BoxX87Float => "\tBoxX87Float\t" | BoxSSE2Double => "\tBoxSSE2Double\t" | BoxSSE2Float => "\tBoxSSE2Float\t" ); printReg(source, stream); stream " => "; printReg(dest, stream); stream " save="; printSaves(saveRegs, stream) ) | printICode(CompareByteVectors{vec1Addr, vec2Addr, length, ccRef, ...}, stream) = ( stream "\tCompareByteVectors\t"; printReg(vec1Addr, stream); stream ","; printReg(vec2Addr, stream); stream ","; printReg(length, stream); stream " => "; printCC(ccRef, stream) ) | printICode(BlockMove{srcAddr, destAddr, length, isByteMove}, stream) = ( stream(if isByteMove then "\tBlockByteMove\t" else "\tBlockWordMove\t"); stream "src="; printReg(srcAddr, stream); stream ",dest="; printReg(destAddr, stream); stream ",len="; printReg(length, stream) ) | printICode(X87Compare{arg1, arg2, isDouble, ccRef, ...}, stream) = ( stream "\tX87Compare"; stream(if isDouble then "D\t" else "S\t"); printReg(arg1, stream); stream ","; printArg(arg2, stream); stream " => "; printCC(ccRef, stream) ) | printICode(SSE2Compare{arg1, arg2, isDouble, ccRef, ...}, stream) = ( stream "\tSSE2Compare"; stream(if isDouble then "D\t" else "S\t"); printReg(arg1, stream); stream ","; printArg(arg2, stream); stream " => "; printCC(ccRef, stream) ) | printICode(X87FPGetCondition{dest, ccRef, ...}, stream) = (stream "\tX87FPGetCondition\t=> "; printReg(dest, stream); stream " => "; printCC(ccRef, stream)) | printICode(X87FPArith{opc, resultReg, arg1, arg2, isDouble}, stream) = ( case opc of FADD => stream "\tX87FPAdd" | FMUL => stream "\tX87FPMul" | FCOM => stream "\tX87FPCompare" | FCOMP => stream "\tX87FPComparePop" | FSUB => stream "\tX87FPSub" | FSUBR => stream "\tX87FPRevSub" | FDIV => stream "\tX87FPDiv" | FDIVR => stream "\tX87FPRevDiv"; if isDouble then stream "D\t" else stream "S\t"; printReg(arg1, stream); stream ","; printArg(arg2, stream); stream " => "; printReg(resultReg, stream) ) | printICode(X87FPUnaryOps{fpOp, dest, source}, stream) = ( case fpOp of FABS => stream "\tX87FPAbs\t" | FCHS => stream "\tX87FPNegate\t" | FLD1 => stream "\tX87FPLoad1\t" | FLDZ => stream "\tX87FPLoad0\t"; printReg(source, stream); stream " => "; printReg(dest, stream) ) | printICode(X87Float{dest, source}, stream) = (stream "\tX87Float\t"; printArg(source, stream); stream " => "; printReg(dest, stream)) | printICode(SSE2Float{dest, source}, stream) = (stream "\tSSE2Float\t"; printArg(source, stream); stream " => "; printReg(dest, stream)) | printICode(SSE2FPUnary{opc, resultReg, source}, stream) = ( case opc of SSE2UDoubleToFloat => stream "\tSSE2UDoubleToFloat\t" | SSE2UFloatToDouble => stream "\tSSE2UFloatToDouble\t"; printArg(source, stream); stream " => "; printReg(resultReg, stream) ) | printICode(SSE2FPBinary{opc, resultReg, arg1, arg2}, stream) = ( case opc of SSE2BAddDouble => stream "\tSSE2BAddDouble\t" | SSE2BSubDouble => stream "\tSSE2BSubDouble\t" | SSE2BMulDouble => stream "\tSSE2BMulDouble\t" | SSE2BDivDouble => stream "\tSSE2BDivDouble\t" | SSE2BAddSingle => stream "\tSSE2BAddSingle\t" | SSE2BSubSingle => stream "\tSSE2BSubSingle\t" | SSE2BMulSingle => stream "\tSSE2BMulSingle\t" | SSE2BDivSingle => stream "\tSSE2BDivSingle\t" | SSE2BXor => stream "\tSSE2BXor\t" | SSE2BAnd => stream "\tSSE2BAnd\t"; printReg(arg1, stream); stream ","; printArg(arg2, stream); stream " => "; printReg(resultReg, stream) ) | printICode(TagFloat{source, dest, ...}, stream) = (stream "\tTagFloat\t"; printReg(source, stream); stream " => "; printReg(dest, stream)) | printICode(UntagFloat{source, dest, cache}, stream) = ( stream "\tUntagFloat\t"; printArg(source, stream); stream " => "; printReg(dest, stream); case cache of NONE => () | SOME c => (stream " cache "; printReg(c, stream)) ) | printICode(GetSSE2ControlReg{dest}, stream) = (stream "\tGetSSE2ControlReg\t"; printReg(dest, stream)) | printICode(SetSSE2ControlReg{source}, stream) = (stream "\tSetSSE2ControlReg\t"; printReg(source, stream)) | printICode(GetX87ControlReg{dest}, stream) = (stream "\tGetX87ControlReg\t"; printReg(dest, stream)) | printICode(SetX87ControlReg{source}, stream) = (stream "\tSetX87ControlReg\t"; printReg(source, stream)) | printICode(X87RealToInt{source, dest}, stream) = (stream "\tX87RealToInt\t"; printReg(source, stream); stream " => "; printReg(dest, stream)) | printICode(SSE2RealToInt{source, dest, isDouble, isTruncate}, stream) = ( stream "\tSSE2RealToInt"; if isTruncate then stream "Trunc" else (); if isDouble then stream "D\t" else stream "S\t"; printArg(source, stream); stream " => "; printReg(dest, stream) ) | printICode(SignExtend32To64{source, dest}, stream) = (stream "\tSignExtend32To64\t"; printArg(source, stream); stream " => "; printReg(dest, stream)) and printCondition(JO, stream) = stream "Overflow" | printCondition(JNO, stream) = stream "NoOverflow" | printCondition(JE, stream) = stream "Equal" | printCondition(JNE, stream) = stream "NotEqual" | printCondition(JL, stream) = stream "LessSigned" | printCondition(JGE, stream) = stream "GeqSigned" | printCondition(JLE, stream) = stream "LeqSigned" | printCondition(JG, stream) = stream "GrtSigned" | printCondition(JB, stream) = stream "LessUnsigned" | printCondition(JNB, stream) = stream "GeqUnsigned" | printCondition(JNA, stream) = stream "LeqUnsigned" | printCondition(JA, stream) = stream "GrtUnsigned" | printCondition(JP, stream) = stream "ParitySet" | printCondition(JNP, stream) = stream "ParityClear" (* Print a basic block. *) fun printBlock stream (blockNo, BasicBlock{block, flow, ...}) = ( (* Put a label on all but the first. *) if blockNo <> 0 then stream("L" ^ Int.toString blockNo ^ ":") else (); List.app (fn icode => (printICode(icode, stream); stream "\n")) block; case flow of Unconditional l => stream("\tJump\tL" ^ Int.toString l ^ "\n") | Conditional {condition, trueJump, falseJump, ccRef, ...} => ( stream "\tJump"; printCondition(condition, stream); stream "\t"; printCC(ccRef, stream); stream " L"; stream (Int.toString trueJump); stream " else L"; stream (Int.toString falseJump); stream "\n" ) | ExitCode => () | IndexedBr _ => () | SetHandler{handler, continue} => stream(concat["\tSetHandler\tH", Int.toString handler, "\n", "\tJump\tL", Int.toString continue, "\n"]) | UnconditionalHandle handler => stream("\tJump\tH" ^ Int.toString handler ^ "\n") | ConditionalHandle{handler, continue} => stream(concat["\tJump\tL", Int.toString continue, " or H", Int.toString handler, "\n"]) ) in fun printICodeAbstract(blockVec, stream) = Vector.appi(printBlock stream) blockVec end (* We frequently just want to know the register. *) fun indexRegister NoMemIndex = NONE | indexRegister (MemIndex1 r) = SOME r | indexRegister (MemIndex2 r) = SOME r | indexRegister (MemIndex4 r) = SOME r | indexRegister (MemIndex8 r) = SOME r | indexRegister ObjectIndex = NONE structure Sharing = struct type genReg = genReg and argument = argument and memoryIndex = memoryIndex and x86ICode = x86ICode and branchOps = branchOps and reg = reg and preg = preg and destinations = destinations and controlFlow = controlFlow and basicBlock = basicBlock and stackLocn = stackLocn and regProperty = regProperty and callKinds = callKinds and arithOp = arithOp and shiftType = shiftType and repOps = repOps and fpOps = fpOps and fpUnaryOps = fpUnaryOps and sse2UnaryOps = sse2UnaryOps and sse2BinaryOps = sse2BinaryOps and ccRef = ccRef and opSize = opSize and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML index 0337bd5a..a41fe3d8 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86ICodeToX86Code.ML @@ -1,2102 +1,2110 @@ (* Copyright David C. J. Matthews 2016-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 *) functor X86ICodeToX86Code( structure X86CODE: X86CODESIG structure X86OPTIMISE: sig type operation type code type operations = operation list type closureRef val generateCode: {code: code, ops: operations, labelCount: int, resultClosure: closureRef } -> unit structure Sharing: sig type operation = operation type code = code type closureRef = closureRef end end structure DEBUG: DEBUGSIG structure ICODE: ICodeSig structure IDENTIFY: X86IDENTIFYREFSSIG structure INTSET: INTSETSIG structure PRETTY: PRETTYSIG structure STRONGLY: sig val stronglyConnectedComponents: {nodeAddress: 'a -> int, arcs: 'a -> int list } -> 'a list -> 'a list list end sharing X86CODE.Sharing = ICODE.Sharing = X86OPTIMISE.Sharing = IDENTIFY.Sharing = INTSET ): X86ICODEGENERATESIG = struct open IDENTIFY open ICODE open X86CODE open Address exception InternalError = Misc.InternalError fun asGenReg(GenReg r) = r | asGenReg _ = raise InternalError "asGenReg" and asFPReg(FPReg r) = r | asFPReg _ = raise InternalError "asFPReg" and asXMMReg(XMMReg r) = r | asXMMReg _ = raise InternalError "asXMMReg" (* tag a short constant *) fun tag c = 2 * c + 1 local val regs = case targetArch of Native32Bit => [edi, esi, edx, ecx, ebx, eax] | Native64Bit => [r14, r13, r12, r11, r10, r9, r8, edi, esi, edx, ecx, ebx, eax] | ObjectId32Bit => [r14, r13, r12, r11, r10, r9, r8, edi, esi, edx, ecx, eax] in val generalRegisters = List.map GenReg regs end fun opSizeToMove OpSize32 = Move32 | opSizeToMove OpSize64 = Move64 fun icodeToX86Code{blocks, functionName, stackRequired, debugSwitches, allocatedRegisters, resultClosure, ...} = let fun argAsGenReg(RegisterArg(GenReg r)) = r | argAsGenReg _ = raise InternalError "argAsGenReg" fun sourceAsGenRegOrMem(RegisterArg(GenReg r)) = RegisterArg r | sourceAsGenRegOrMem(MemoryArg{offset, base=baseReg, index}) = MemoryArg{base=baseReg, offset=offset, index=index} | sourceAsGenRegOrMem(NonAddressConstArg v) = NonAddressConstArg v | sourceAsGenRegOrMem(AddressConstArg v) = AddressConstArg v | sourceAsGenRegOrMem _ = raise InternalError "sourceAsGenRegOrMem" and sourceAsXMMRegOrMem(RegisterArg(XMMReg r)) = RegisterArg r | sourceAsXMMRegOrMem(MemoryArg{offset, base=baseReg, index}) = MemoryArg{base=baseReg, offset=offset, index=index} | sourceAsXMMRegOrMem(NonAddressConstArg v) = NonAddressConstArg v | sourceAsXMMRegOrMem(AddressConstArg v) = AddressConstArg v | sourceAsXMMRegOrMem _ = raise InternalError "sourceAsGenRegOrMem" (* Moves and loads. *) fun llLoadArgument({ source, dest=GenReg destReg, kind=Move64Bit}, code) = Move { source=sourceAsGenRegOrMem source, destination=RegisterArg destReg, moveSize=Move64 } :: code | llLoadArgument({ source=MemoryArg mLoc, dest=GenReg destReg, kind=MoveByte}, code) = (* Load from memory. *) Move{moveSize=Move8, source=MemoryArg mLoc, destination=RegisterArg destReg} :: code | llLoadArgument({ source=MemoryArg mLoc, dest=GenReg destReg, kind=Move16Bit}, code) = (* Load from memory. *) Move{moveSize=Move16, source=MemoryArg mLoc, destination=RegisterArg destReg} :: code | llLoadArgument({ source, dest=GenReg destReg, kind=Move32Bit}, code) = (* Load from memory. *) Move { source=sourceAsGenRegOrMem source, destination=RegisterArg destReg, moveSize=Move32 } :: code (* Load a floating point value. *) | llLoadArgument({source=MemoryArg{offset, base=baseReg, index}, dest=FPReg fpReg, kind=MoveDouble}, code) = moveToOutputFP(fpReg, FPLoadFromMemory{ address={base=baseReg, offset=offset, index=index}, precision=DoublePrecision } :: code) | llLoadArgument({source=AddressConstArg addrConst, dest=FPReg fpReg, kind=MoveDouble}, code) = moveToOutputFP(fpReg, FPLoadFromConst{ constant= addrConst, precision=DoublePrecision } :: code) | llLoadArgument({source=RegisterArg(FPReg fpSrc), dest=FPReg fpDest, kind=MoveDouble}, code) = (* Moving from one FP reg to another. Even if we are moving from FP0 we still do a load because FPStoreToFPReg adds one to the register number to account for one value on the stack. *) moveToOutputFP(fpDest, FPLoadFromFPReg{source=fpSrc, lastRef=false} :: code) (* Load or move from an XMM reg. *) | llLoadArgument({source, dest=XMMReg xmmRegReg, kind=MoveDouble}, code) = XMMArith { opc= SSE2MoveDouble, source=sourceAsXMMRegOrMem source, output=xmmRegReg } :: code (* Load a floating point value. *) | llLoadArgument({source=MemoryArg{offset, base=baseReg, index}, dest=FPReg fpReg, kind=MoveFloat}, code) = moveToOutputFP(fpReg, FPLoadFromMemory{ address={ base=baseReg, offset=offset, index=index }, precision=SinglePrecision } :: code) | llLoadArgument({source=AddressConstArg addrConst, dest=FPReg fpReg, kind=MoveFloat}, code) = moveToOutputFP(fpReg, FPLoadFromConst{ constant= addrConst, precision=SinglePrecision } :: code) (* Load or move from an XMM reg. *) | llLoadArgument({source, dest=XMMReg xmmRegReg, kind=MoveFloat}, code) = XMMArith { opc= SSE2MoveFloat, source=sourceAsXMMRegOrMem source, output=xmmRegReg } :: code (* Any other combinations are not allowed. *) | llLoadArgument _ = raise InternalError "codeGenICode: LoadArgument" (* Unless the destination is FP0 we need to store and pop. *) and moveToOutputFP(fpDest, code) = if fpDest = fp0 then code else FPStoreToFPReg{output=fpDest, andPop=true} :: code (* Store to memory *) fun llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move64Bit} = Move{source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=opSizeToMove OpSize64} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=MoveByte} = Move{moveSize=Move8, source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move16Bit} = Move{moveSize=Move16, source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}} | llStoreArgument{ source=RegisterArg(GenReg sourceReg), base, offset, index, kind=Move32Bit} = Move{source=RegisterArg sourceReg, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=opSizeToMove OpSize32} (* Store a short constant to memory *) | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=Move64Bit} = Move{source=NonAddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=Move64} | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=Move32Bit} = Move{source=NonAddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}, moveSize=Move32} | llStoreArgument{ source=NonAddressConstArg srcValue, base, offset, index, kind=MoveByte} = Move{moveSize=Move8, source=NonAddressConstArg srcValue, destination=MemoryArg{base=base, offset=offset, index=index}} (* Store a long constant to memory *) | llStoreArgument{ source=AddressConstArg srcValue, base, offset, index, kind} = ( (* This Move must be of a polyWord size. *) case (kind, polyWordOpSize) of (Move64Bit, OpSize64) => () | (Move32Bit, OpSize32) => () | _ => raise InternalError "Move of AddressConstArg"; Move{moveSize=opSizeToMove polyWordOpSize, source=AddressConstArg srcValue, destination=MemoryArg {base=base, offset=offset, index=index}} ) (* Store a floating point value. *) | llStoreArgument{source=RegisterArg(FPReg fpReg), offset, base=baseReg, index, kind=MoveDouble} = let val _ = fpReg = fp0 orelse raise InternalError "llStoreArgument: Store FPReg <> fp0" in FPStoreToMemory{ address={ base=baseReg, offset=offset, index=index}, precision=DoublePrecision, andPop=true } end | llStoreArgument{source=RegisterArg(XMMReg xmmRegReg), offset, base=baseReg, index, kind=MoveDouble} = XMMStoreToMemory { toStore=xmmRegReg, address={base=baseReg, offset=offset, index=index}, precision=DoublePrecision } (* Store a floating point value. *) | llStoreArgument{source=RegisterArg(FPReg fpReg), offset, base=baseReg, index, kind=MoveFloat} = let val _ = fpReg = fp0 orelse raise InternalError "llStoreArgument: Store FPReg <> fp0" in FPStoreToMemory{address={ base=baseReg, offset=offset, index=index}, precision=SinglePrecision, andPop=true } end | llStoreArgument{source=RegisterArg(XMMReg xmmRegReg), offset, base=baseReg, index, kind=MoveFloat} = XMMStoreToMemory { toStore=xmmRegReg, address={base=baseReg, offset=offset, index=index}, precision=SinglePrecision } | llStoreArgument _ = raise InternalError "llStoreArgument: StoreArgument" val numBlocks = Vector.length blocks fun getAllocatedReg r = Vector.sub(allocatedRegisters, r) val getAllocatedGenReg = asGenReg o getAllocatedReg and getAllocatedFPReg = asFPReg o getAllocatedReg and getAllocatedXMMReg = asXMMReg o getAllocatedReg fun codeExtIndex NoMemIndex = NoIndex | codeExtIndex(MemIndex1(PReg r)) = Index1(getAllocatedGenReg r) | codeExtIndex(MemIndex2(PReg r)) = Index2(getAllocatedGenReg r) | codeExtIndex(MemIndex4(PReg r)) = Index4(getAllocatedGenReg r) | codeExtIndex(MemIndex8(PReg r)) = Index8(getAllocatedGenReg r) | codeExtIndex ObjectIndex = raise InternalError "codeExtIndex: ObjectIndex" local fun codeExtArgument getReg (RegisterArgument(PReg r)) = RegisterArg(getReg r) | codeExtArgument _ (AddressConstant m) = AddressConstArg m | codeExtArgument _ (IntegerConstant i) = NonAddressConstArg i | codeExtArgument _ (MemoryLocation{base=PReg bReg, offset, index=ObjectIndex, cache=NONE}) = MemoryArg{base=ebx, index=Index4(getAllocatedGenReg bReg), offset=offset} | codeExtArgument _ (MemoryLocation{base=PReg bReg, offset, index, cache=NONE}) = MemoryArg{base=getAllocatedGenReg bReg, offset=offset, index=codeExtIndex index} | codeExtArgument getReg (MemoryLocation{cache=SOME(PReg r), ...}) = RegisterArg(getReg r) | codeExtArgument _ (StackLocation{wordOffset, cache=NONE, ...}) = MemoryArg{base=esp, offset=wordOffset*Word.toInt nativeWordSize, index=NoIndex} | codeExtArgument getReg (StackLocation{cache=SOME(PReg r), ...}) = RegisterArg(getReg r) | codeExtArgument _ (ContainerAddr _) = raise InternalError "codeExtArgument - ContainerAddr" in val codeExtArgument = codeExtArgument getAllocatedReg and codeExtArgumentAsGenReg = codeExtArgument getAllocatedGenReg and codeExtArgumentAsFPReg = codeExtArgument getAllocatedFPReg and codeExtArgumentAsXMMReg = codeExtArgument getAllocatedXMMReg end + fun codeCallKind Recursive = NonAddressConstArg 0 (* Jump to the start *) + | codeCallKind (ConstantCode v) = AddressConstArg v + | codeCallKind FullCall = + ( + case targetArch of + ObjectId32Bit => MemoryArg{base=ebx, index=Index4 edx, offset=0} + | _ => MemoryArg{base=edx, index=NoIndex, offset=0} + ) + (* Move unless the registers are the same. *) fun moveIfNecessary({src, dst, kind}, code) = if src = dst then code else llLoadArgument({source=RegisterArg src, dest=dst, kind=kind}, code) fun opSizeToIMove OpSize64 = Move64Bit | opSizeToIMove OpSize32 = Move32Bit datatype llsource = StackSource of int | OtherSource of reg regOrMemoryArg fun sourceToX86Code(OtherSource r) = r | sourceToX86Code(StackSource wordOffset) = MemoryArg{base=esp, offset=wordOffset*Word.toInt nativeWordSize, index=NoIndex} local fun indexRegister NoIndex = NONE | indexRegister (Index1 r) = SOME r | indexRegister (Index2 r) = SOME r | indexRegister (Index4 r) = SOME r | indexRegister (Index8 r) = SOME r (* The registers are numbered from 0. Choose values that don't conflict with the stack addresses. *) fun regNo r = ~1 - nReg r type node = {src: llsource, dst: destinations } fun nodeAddress({dst=RegDest r, ...}: node) = regNo r | nodeAddress({dst=StackDest a, ...}) = a fun arcs({src=StackSource wordOffset, ...}: node) = [wordOffset] | arcs{src=OtherSource(RegisterArg r), ...} = [regNo r] | arcs{src=OtherSource(MemoryArg{base, index, ...}), ...} = (case indexRegister index of NONE => [regNo(GenReg base)] | SOME r => [regNo(GenReg base), regNo(GenReg r)]) | arcs _ = [] in val stronglyConnected = STRONGLY.stronglyConnectedComponents { nodeAddress=nodeAddress, arcs=arcs } end (* This is a general function for moving values into registers or to the stack where it is possible that the source values might also be in use as destinations. The stack is used for destinations only for tail recursive calls. *) fun moveMultipleValues(moves, workReg: reg option, code) = let val _ = if List.exists(fn {dst=StackDest _, ...} => true | _ => false) moves andalso not(isSome workReg) then raise InternalError "no work reg" else () fun moveValues ([], code) = code (* We're done. *) | moveValues (arguments, code) = let (* stronglyConnectedComponents does two things. It detects loops where it's not possible to move items without breaking the loop but more importantly it orders the dependencies so that if there are no loops we can load the source and store it in the destination knowing that we won't overwrite anything we might later need. *) val ordered = stronglyConnected arguments fun isFPReg(GenReg _) = false | isFPReg(XMMReg _) = true | isFPReg(FPReg _) = true fun moveEachValue ([], code) = code | moveEachValue ([{dst=RegDest reg, src as OtherSource(RegisterArg r)}] :: rest, code) = (* Source and dest are both regs - only move if they're different. *) if r = reg then moveEachValue(rest, code) else moveEachValue(rest, llLoadArgument({source=sourceToX86Code src, dest=reg, kind=if isFPReg reg then MoveDouble else moveNativeWord}, code)) | moveEachValue ([{dst=RegDest reg, src}] :: rest, code) = (* Load from store or a constant. Have to use movePolyWord if it's an address constant. *) moveEachValue(rest, llLoadArgument({source=sourceToX86Code src, dest=reg, kind=movePolyWord}, code)) | moveEachValue ([{dst=StackDest _, src=OtherSource(MemoryArg _ )}] :: _, _) = raise InternalError "moveEachValue - MemoryArgument" | moveEachValue ([{dst=StackDest addr, src as StackSource wordOffset}] :: rest, code) = (* Copy a stack location - needs a load and store unless the address is the same. *) if addr = wordOffset then moveEachValue(rest, code) else let val workReg = valOf workReg in moveEachValue(rest, llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: llLoadArgument({source=sourceToX86Code src, dest=workReg, kind=moveNativeWord}, code)) end | moveEachValue ([{dst=StackDest addr, src}] :: rest, code) = (* Store from a register or a constant. *) moveEachValue(rest, llStoreArgument{ source=sourceToX86Code src, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: code) | moveEachValue((cycle as first :: _ :: _) :: rest, code) = (* We have a cycle. *) let (* We need to exchange some of the arguments. Doing an exchange here will set the destination with the correct source. However we have to process every subsequent entry with the swapped registers. That may well mean that one of those entries becomes trivial. Using XCHG means that we can move N registers in N-1 exchanges. We also need to rerun stronglyConnectedComponents on at least the rest of this cycle. It's easiest to flatten the rest and do everything. *) (* Try to find either a register-register move or a register-stack move. If not use the first. If there's a stack-register move there will also be a register-stack so we don't need to look for both. *) val {dst=selectDst, src=selectSrc} = case List.find(fn {src=OtherSource(RegisterArg _), dst=RegDest _} => true | _ => false) cycle of SOME found => found | _ => ( case List.find(fn {dst=RegDest _, ...} => true | _ => false) cycle of SOME found => found | NONE => first ) (* This includes this entry but after the swap we'll eliminate it. *) val flattened = List.foldl(fn (a, b) => a @ b) [] (cycle :: rest) val destAsSource = case selectDst of RegDest reg => OtherSource(RegisterArg reg) | StackDest s => StackSource s (* Source is not an equality type. We can't currently handle the situation where the source is a memory location. *) fun match(OtherSource(RegisterArg r1), OtherSource(RegisterArg r2)) = r1 = r2 | match(StackSource s1, StackSource s2) = s1 = s2 | match(OtherSource(MemoryArg _), _) = raise InternalError "moveEachValue: cycle" | match _ = false fun swapSources{src, dst} = if match(src, selectSrc) then {src=destAsSource, dst=dst} else if match(src, destAsSource) then {src=selectSrc, dst=dst} else {src=src, dst=dst} (* Try to use register to register exchange if we can. A register-to-memory exchange involves a bus lock and we'd like to avoid that. *) val exchangeCode = case (selectDst, selectSrc) of (RegDest(GenReg regA), OtherSource(RegisterArg(GenReg regB))) => XChng { reg=regA, arg=RegisterArg regB, opSize=nativeWordOpSize } :: code | (RegDest(XMMReg regA), OtherSource(RegisterArg(XMMReg regB))) => (* This is the only case where we can have a cycle with SSE2 regs. There are various ways of doing it but XORs are probably the easiest. *) XMMArith{opc=SSE2Xor, source=RegisterArg regA, output=regB} :: XMMArith{opc=SSE2Xor, source=RegisterArg regB, output=regA} :: XMMArith{opc=SSE2Xor, source=RegisterArg regA, output=regB} :: code | (RegDest _, OtherSource(RegisterArg _)) => raise InternalError "moveEachValue: invalid register combination" | (RegDest regA, src as StackSource addr) => let val workReg = valOf workReg in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg regA, arg=RegisterArg(asGenReg workReg), opSize=nativeWordOpSize } :: llLoadArgument({source=sourceToX86Code src, dest=workReg, kind=moveNativeWord}, code) end | (StackDest addr, OtherSource(RegisterArg regA)) => let (* This doesn't actually occur because we always find the case above. *) val workReg = valOf workReg in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg regA, arg=RegisterArg (asGenReg workReg), opSize=nativeWordOpSize } :: llLoadArgument({ source=MemoryArg{base=esp, offset=addr*Word.toInt nativeWordSize, index=NoIndex}, dest=workReg, kind=moveNativeWord}, code) end | (StackDest addr1, StackSource addr2) => let val workReg = valOf workReg (* This can still happen if we have argument registers that need to be loaded from stack locations and those argument registers happen to contain the values to be stored into those stack locations. e.g. ebx => S8; eax => S7; S8 => eax; S7 => eax. Eliminating the registers results in a cycle. It may be possible to avoid this by excluding the argument registers (eax; ebx; r8; r9; r10) from holding values in the area to be overwritten. *) in llStoreArgument{source=RegisterArg workReg, base=esp, index=NoIndex, offset = addr1*Word.toInt nativeWordSize, kind=moveNativeWord} :: XChng { reg=asGenReg workReg, arg=MemoryArg{base=esp, offset=addr2*Word.toInt nativeWordSize, index=NoIndex}, opSize=nativeWordOpSize } :: llLoadArgument({ source=MemoryArg{base=esp, offset=addr1*Word.toInt nativeWordSize, index=NoIndex}, dest=workReg, kind=moveNativeWord}, code) end | _ => raise InternalError "moveEachValue: cycle" in moveValues(List.map swapSources flattened, exchangeCode) end | moveEachValue(([]) :: _, _) = (* This should not happen - avoid warning. *) raise InternalError "moveEachValue - empty set" in moveEachValue(ordered, code) end in moveValues(moves, code) end (* Where we have multiple specific registers as either source or destination there is the potential that a destination register if currently in use as a source. *) fun moveMultipleRegisters(regPairList, code) = let val regPairsAsDests = List.map(fn {src, dst} => {src=OtherSource(RegisterArg src), dst=RegDest dst}) regPairList in moveMultipleValues(regPairsAsDests, NONE, code) end val outputLabelCount = ref 0 val blockToLabelMap = Array.array(numBlocks, ~1) fun makeLabel() = Label{labelNo = ! outputLabelCount} before outputLabelCount := !outputLabelCount + 1 fun getBlockLabel blockNo = case Array.sub(blockToLabelMap, blockNo) of ~1 => let val label as Label{labelNo} = makeLabel() val () = Array.update(blockToLabelMap, blockNo, labelNo) in label end | n => Label{labelNo=n} (* The profile object is a single mutable with the F_bytes bit set. *) local val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) fun clear 0w0 = () | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) val () = clear wordSize in val profileObject = toMachineWord v end (* Switch to indicate if we want to trace where live data has been allocated. *) val addAllocatingFunction = DEBUG.getParameter DEBUG.profileAllocationTag debugSwitches = 1 fun llAllocateMemoryOperation ({ size, flags, dest, saveRegs}, code) = let val toReg = asGenReg dest val preserve = saveRegs (* Allocate memory. N.B. Instructions are in reverse order. *) fun allocStore{size, flags, output, preserve} = if targetArch = Native64Bit andalso flags <> 0w0 then [Move{moveSize=Move8, source=NonAddressConstArg(Word8.toLargeInt flags), destination=MemoryArg {offset= ~1, base=output, index=NoIndex}}, Move{source=NonAddressConstArg(LargeInt.fromInt size), destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=output, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, AllocStore{size=size, output=output, saveRegs=preserve}] else let val lengthWord = IntInf.orb(IntInf.fromInt size, IntInf.<<(Word8.toLargeInt flags, 0w24)) in [Move{source=NonAddressConstArg lengthWord, destination=MemoryArg {offset= ~ (Word.toInt wordSize), base=output, index=NoIndex}, moveSize=opSizeToMove polyWordOpSize}, AllocStore{size=size, output=output, saveRegs=preserve}] end val allocCode = (* If we need to add the profile object *) if addAllocatingFunction then allocStore {size=size+1, flags=Word8.orb(flags, Address.F_profile), output=toReg, preserve=preserve} @ [Move{moveSize=opSizeToMove polyWordOpSize, source=AddressConstArg profileObject, destination=MemoryArg {base=toReg, offset=size*Word.toInt wordSize, index=NoIndex}}] else allocStore {size=size, flags=flags, output=toReg, preserve=preserve} (* Convert to an object index if necessary. *) val convertToObjId = if targetArch = ObjectId32Bit then [ ShiftConstant{ shiftType=SHR, output=toReg, shift=0w2, opSize=OpSize64 }, ArithToGenReg{ opc=SUB, output=toReg, source=RegisterArg ebx, opSize=nativeWordOpSize } ] else [] in convertToObjId @ allocCode @ code end (* Check the stack limit "register". This is used both at the start of a function for genuine stack checking but also in a loop to check for an interrupt. We need to save the registers even across an interrupt because it can be used if another thread wants a GC. *) fun testRegAndTrap(reg, entryPt, saveRegs) = let (* Normally we won't have a stack overflow so we will skip the check. *) val skipCheckLab = makeLabel() in (* Need it in reverse order. *) [ JumpLabel skipCheckLab, CallRTS{rtsEntry=entryPt, saveRegs=saveRegs}, ConditionalBranch{test=JNB, label=skipCheckLab}, ArithToGenReg{ opc=CMP, output=reg, source=MemoryArg{offset=memRegStackLimit, base=ebp, index=NoIndex}, opSize=nativeWordOpSize } ] end local val numRegisters = Vector.length allocatedRegisters val uses = Array.array(numRegisters, false) fun used(PReg r) = Array.update(uses, r, true) fun isUsed(PReg r) = Array.sub(uses, r) (* Set the registers used by the sources. This differs from getInstructionState in that we don't set the base register of a memory location to "used" if we can use the cache. *) fun argUses(RegisterArgument rarg) = used rarg | argUses(MemoryLocation { cache=SOME cr, ...}) = used cr | argUses(MemoryLocation { base, index, cache=NONE, ...}) = (used base; indexUses index) | argUses(StackLocation { cache=SOME rarg, ...}) = used rarg | argUses _ = () and indexUses NoMemIndex = () | indexUses(MemIndex1 arg) = used arg | indexUses(MemIndex2 arg) = used arg | indexUses(MemIndex4 arg) = used arg | indexUses(MemIndex8 arg) = used arg | indexUses ObjectIndex = () (* LoadArgument, TagValue, CopyToCache, UntagValue and BoxValue are eliminated if their destination is not used. In that case their source are not used either. *) fun instructionUses(LoadArgument { source, dest, ...}) = if isUsed dest then argUses source else () | instructionUses(StoreArgument{ source, base, index, ...}) = (argUses source; used base; indexUses index) | instructionUses(LoadMemReg _) = () | instructionUses(BeginFunction _) = () | instructionUses(FunctionCall{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app argUses stackArgs) | instructionUses(TailRecursiveCall{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app(argUses o #src) stackArgs) | instructionUses(AllocateMemoryOperation _) = () | instructionUses(AllocateMemoryVariable{size, ...}) = used size | instructionUses(InitialiseMem{size, addr, init}) = (used size; used addr; used init) | instructionUses(InitialisationComplete) = () | instructionUses(BeginLoop) = () | instructionUses(JumpLoop{regArgs, stackArgs, ...}) = (List.app(argUses o #1) regArgs; List.app(argUses o #1) stackArgs) | instructionUses(RaiseExceptionPacket{packetReg}) = used packetReg | instructionUses(ReserveContainer _) = () | instructionUses(IndexedCaseOperation{testReg, ...}) = used testReg | instructionUses(LockMutable{addr}) = used addr | instructionUses(WordComparison{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(CompareLiteral{arg1, ...}) = argUses arg1 | instructionUses(CompareByteMem{arg1={base, index, ...}, ...}) = (used base; indexUses index) | instructionUses(PushExceptionHandler _) = () | instructionUses(PopExceptionHandler _) = () | instructionUses(BeginHandler _) = () | instructionUses(ReturnResultFromFunction{resultReg, ...}) = used resultReg | instructionUses(ArithmeticFunction{operand1, operand2, ...}) = (used operand1; argUses operand2) | instructionUses(TestTagBit{arg, ...}) = argUses arg | instructionUses(PushValue {arg, ...}) = argUses arg | instructionUses(CopyToCache{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(ResetStackPtr _) = () | instructionUses(StoreToStack {source, ...}) = argUses source | instructionUses(TagValue{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(UntagValue{dest, cache=SOME cacheR, ...}) = if isUsed dest then used cacheR else () | instructionUses(UntagValue{source, dest, cache=NONE, ...}) = if isUsed dest then used source else () | instructionUses(LoadEffectiveAddress{base, index, ...}) = (case base of SOME bReg => used bReg | NONE => (); indexUses index) | instructionUses(ShiftOperation{operand, shiftAmount, ...}) = (used operand; argUses shiftAmount) | instructionUses(Multiplication{operand1, operand2, ...}) = (used operand1; argUses operand2) | instructionUses(Division{dividend, divisor, ...}) = (used dividend; argUses divisor) | instructionUses(AtomicExchangeAndAdd{base, source}) = (used base; used source) | instructionUses(BoxValue{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(CompareByteVectors{vec1Addr, vec2Addr, length, ...}) = (used vec1Addr; used vec2Addr; used length) | instructionUses(BlockMove{srcAddr, destAddr, length, ...}) = (used srcAddr; used destAddr; used length) | instructionUses(X87Compare{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(SSE2Compare{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(X87FPGetCondition _) = () | instructionUses(X87FPArith{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(X87FPUnaryOps{source, ...}) = used source | instructionUses(X87Float{source, ...}) = argUses source | instructionUses(SSE2Float{source, ...}) = argUses source | instructionUses(SSE2FPUnary{source, ...}) = argUses source | instructionUses(SSE2FPBinary{arg1, arg2, ...}) = (used arg1; argUses arg2) | instructionUses(TagFloat{source, dest, ...}) = if isUsed dest then used source else () | instructionUses(UntagFloat{dest, cache=SOME cacheR, ...}) = if isUsed dest then used cacheR else () | instructionUses(UntagFloat{source, dest, cache=NONE, ...}) = if isUsed dest then argUses source else () | instructionUses(GetSSE2ControlReg _) = () | instructionUses(SetSSE2ControlReg{source}) = used source | instructionUses(GetX87ControlReg _) = () | instructionUses(SetX87ControlReg{source}) = used source | instructionUses(X87RealToInt{source, ...}) = used source | instructionUses(SSE2RealToInt{source, ...}) = argUses source | instructionUses(SignExtend32To64{source, dest}) = if isUsed dest then argUses source else () (* Depth-first scan. *) val visited = Array.array(numBlocks, false) fun processBlocks blockNo = if Array.sub(visited, blockNo) then () (* Done or currently being done. *) else let val () = Array.update(visited, blockNo, true) val ExtendedBasicBlock { flow, block,...} = Vector.sub(blocks, blockNo) val () = (* Process the dependencies first. *) case flow of ExitCode => () | Unconditional m => processBlocks m | Conditional {trueJump, falseJump, ...} => (processBlocks trueJump; processBlocks falseJump) | IndexedBr cases => List.app processBlocks cases | SetHandler{ handler, continue } => (processBlocks handler; processBlocks continue) | UnconditionalHandle _ => () | ConditionalHandle { continue, ...} => processBlocks continue (* Now this block. *) in List.foldr(fn ({instr, ...}, ()) => instructionUses instr) () block end in val () = processBlocks 0 val isUsed = isUsed end (* Return the register part of a cached item. *) fun decache(StackLocation{cache=SOME r, ...}) = RegisterArgument r | decache(MemoryLocation{cache=SOME r, ...}) = RegisterArgument r | decache arg = arg (* Only get the registers that are actually used. *) val getSaveRegs = List.mapPartial(fn (reg as PReg r) => if isUsed reg then SOME(getAllocatedGenReg r) else NONE) fun codeExtended _ ({instr=LoadArgument{source, dest as PReg dreg, kind}, ...}, code) = if not (isUsed dest) then code else let val realDestReg = getAllocatedReg dreg in case source of RegisterArgument(PReg sreg) => (* Register to register move. Try to use the same register for the source as the destination to eliminate the instruction. *) (* If the source is the same as the destination we don't need to do anything. *) moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=kind}, code) | MemoryLocation{cache=SOME(PReg sreg), ...} => (* This is also a register to register move but because the original load is from memory it could be a byte or short precision value. *) let val moveKind = case kind of Move64Bit => Move64Bit | MoveByte => Move32Bit | Move16Bit => Move32Bit | Move32Bit => Move32Bit | MoveFloat => MoveFloat | MoveDouble => MoveDouble in moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=moveKind}, code) end (* TODO: Isn't this covered by codeExtArgument? It looks like it was added in the 32-in-64 changes. *) | StackLocation{cache=SOME(PReg sreg), ...} => moveIfNecessary({src=getAllocatedReg sreg, dst=realDestReg, kind=kind}, code) | source => (* Loads of constants or from an address. *) llLoadArgument({source=codeExtArgument source, dest=realDestReg, kind=kind}, code) end | codeExtended _ ({instr=StoreArgument{ source, base=PReg bReg, offset, index, kind, ... }, ...}, code) = let val (baseReg, indexVal) = case index of ObjectIndex => (ebx, Index4(getAllocatedGenReg bReg)) | _ => (getAllocatedGenReg bReg, codeExtIndex index) in case (decache source, kind) of (RegisterArgument(PReg sReg), MoveByte) => if targetArch <> Native32Bit then llStoreArgument{ source=codeExtArgument source, base=baseReg, offset=offset, index=indexVal, kind=MoveByte} :: code else (* This is complicated on X86/32. We can't use edi or esi for the store registers. Instead we reserve ecx (see special case in "identify") and use that if we have to. *) let val realStoreReg = getAllocatedReg sReg val (moveCode, storeReg) = if realStoreReg = GenReg edi orelse realStoreReg = GenReg esi then (moveIfNecessary({src=realStoreReg, dst=GenReg ecx, kind=moveNativeWord}, code), GenReg ecx) else (code, realStoreReg) in llStoreArgument{ source=RegisterArg storeReg, base=baseReg, offset=offset, index=indexVal, kind=MoveByte} :: moveCode end | _ => llStoreArgument{ source=codeExtArgument source, base=baseReg, offset=offset, index=indexVal, kind=kind} :: code end | codeExtended _ ({instr=LoadMemReg { offset, dest=PReg pr}, ...}, code) = (* Load from the "memory registers" pointed at by ebp. *) (* Currently only used to load the thread Id which is a Poly word. *) llLoadArgument({source=MemoryArg{base=ebp, offset=offset, index=NoIndex}, dest=getAllocatedReg pr, kind=movePolyWord}, code) | codeExtended _ ({instr=BeginFunction{regArgs, ...}, ...}, code) = let val minStackCheck = 20 val saveRegs = List.mapPartial(fn (_, GenReg r) => SOME r | _ => NONE) regArgs val preludeCode = if stackRequired >= minStackCheck then let (* Compute the necessary amount in edi and compare that. *) val stackByteAdjust = ~ (Word.toInt nativeWordSize) * stackRequired val testEdiCode = testRegAndTrap (edi, StackOverflowCallEx, saveRegs) in (* N.B. In reverse order. *) testEdiCode @ [LoadAddress{output=edi, base=SOME esp, index=NoIndex, offset=stackByteAdjust, opSize=nativeWordOpSize}] end else testRegAndTrap (esp, StackOverflowCall, saveRegs) val usedRegs = List.filter (isUsed o #1) regArgs fun mkPair(PReg pr, rr) = {src=rr,dst=getAllocatedReg pr} val regPairs = List.map mkPair usedRegs in moveMultipleRegisters(regPairs, preludeCode @ code) end | codeExtended _ ({instr=TailRecursiveCall{callKind, regArgs=oRegArgs, stackArgs=oStackArgs, stackAdjust, currStackSize, workReg=PReg wReg}, ...}, code) = let val regArgs = List.map (fn (arg, reg) => (decache arg, reg)) oRegArgs and stackArgs = List.map(fn {src, stack } => {src=decache src, stack=stack}) oStackArgs val workReg = getAllocatedReg wReg (* We must leave stack entries as stack entries for the moment. *) fun codeArg(StackLocation{wordOffset, cache=NONE, ...}) = StackSource wordOffset | codeArg arg = OtherSource(codeExtArgument arg) val extStackArgs = map (fn {stack, src} => {dst=StackDest(stack+currStackSize), src=codeArg src}) stackArgs val extRegArgs = map (fn (a, r) => {src=codeArg a, dst=RegDest r}) regArgs (* Tail recursive calls are complicated because we generally have to overwrite the existing stack. That means storing the arguments in the right order to avoid overwriting a value that we are using for a different argument. *) fun codeTailCall(arguments: {dst: destinations, src: llsource} list, stackAdjust, code) = if stackAdjust < 0 then let (* If the function we're calling takes more arguments on the stack than the current function we will have to extend the stack. Do that by pushing the argument whose offset is at -1. Then adjust all the offsets and repeat. *) val {src=argM1, ...} = valOf(List.find(fn {dst=StackDest ~1, ...} => true | _ => false) arguments) fun renumberArgs [] = [] | renumberArgs ({dst=StackDest ~1, ...} :: args) = renumberArgs args (* Remove the one we've done. *) | renumberArgs ({dst, src} :: args) = let val newDest = case dst of StackDest d => StackDest(d+1) | regDest => regDest val newSrc = case src of StackSource wordOffset => StackSource(wordOffset+1) | other => other in {dst=newDest, src=newSrc} :: renumberArgs args end in codeTailCall(renumberArgs arguments, stackAdjust+1, PushToStack(sourceAsGenRegOrMem(sourceToX86Code argM1)) :: code) end else let val loadArgs = moveMultipleValues(arguments, SOME workReg, code) in if stackAdjust = 0 then loadArgs else ResetStack{numWords=stackAdjust, preserveCC=false} :: loadArgs end in - JumpToFunction callKind :: + JumpAddress(codeCallKind callKind) :: codeTailCall(extStackArgs @ extRegArgs, stackAdjust+currStackSize, code) end | codeExtended _ ({instr=FunctionCall{callKind, regArgs=oRegArgs, stackArgs=oStackArgs, dest=PReg dReg, realDest, saveRegs}, ...}, code) = let val regArgs = List.map (fn (arg, reg) => (decache arg, reg)) oRegArgs and stackArgs = List.map decache oStackArgs val destReg = getAllocatedReg dReg fun pushStackArgs ([], _, code) = code | pushStackArgs (ContainerAddr {stackOffset, ...} ::args, argNum, code) = let val adjustedAddr = stackOffset+argNum (* If there is an offset relative to rsp we need to add this in. *) val addOffset = if adjustedAddr = 0 then [] else [ArithMemConst{opc=ADD, address={offset=0, base=esp, index=NoIndex}, source=LargeInt.fromInt(adjustedAddr*Word.toInt nativeWordSize), opSize=nativeWordOpSize}] in pushStackArgs(args, argNum+1, addOffset @ PushToStack(RegisterArg esp) :: code) end | pushStackArgs (StackLocation {wordOffset, container, field, ...} ::args, argNum, code) = let (* Have to adjust the offsets of stack arguments. *) val adjusted = StackLocation{wordOffset=wordOffset+argNum, container=container, field=field+argNum, cache=NONE} in pushStackArgs(args, argNum+1, PushToStack(codeExtArgumentAsGenReg adjusted) :: code) end | pushStackArgs (arg::args, argNum, code) = pushStackArgs(args, argNum+1, PushToStack(codeExtArgumentAsGenReg arg) :: code) val pushedArgs = pushStackArgs(stackArgs, 0, code (* Initial code *)) (* We have to adjust any stack offset to account for the arguments we've pushed. *) val numStackArgs = List.length stackArgs (* We don't currently allow the arguments to be memory locations and instead force them into registers. That may be simpler especially if we can get the values directly into the required register. *) fun getRegArgs(RegisterArgument(PReg pr), reg) = SOME{dst=reg, src=getAllocatedReg pr} | getRegArgs(StackLocation {cache=SOME(PReg pr), ...}, reg) = SOME{dst=reg, src=getAllocatedReg pr} | getRegArgs(MemoryLocation _, _) = raise InternalError "FunctionCall - MemoryLocation" | getRegArgs _ = NONE val loadRegArgs = moveMultipleRegisters(List.mapPartial getRegArgs regArgs, pushedArgs) (* These are all items we can load without requiring a source register. That includes loading from the stack. *) fun getConstArgs((AddressConstant m, reg), code) = llLoadArgument({source=AddressConstArg m, dest=reg, kind=movePolyWord}, code) | getConstArgs((IntegerConstant i, reg), code) = llLoadArgument({source=NonAddressConstArg i, dest=reg, kind=movePolyWord}, code) | getConstArgs((StackLocation { cache=SOME _, ...}, _), code) = code | getConstArgs((StackLocation { wordOffset, ...}, reg), code) = llLoadArgument({source=MemoryArg{offset=(wordOffset+numStackArgs)*Word.toInt nativeWordSize, base=esp, index=NoIndex}, dest=reg, kind=moveNativeWord}, code) | getConstArgs((ContainerAddr {stackOffset, ...}, reg), code) = if stackOffset+numStackArgs = 0 then llLoadArgument({source=RegisterArg(GenReg esp), dest=reg, kind=moveNativeWord}, code) else LoadAddress{ output=asGenReg reg, offset=(stackOffset+numStackArgs)*Word.toInt nativeWordSize, base=SOME esp, index=NoIndex, opSize=nativeWordOpSize } :: code | getConstArgs((RegisterArgument _, _), code) = code | getConstArgs((MemoryLocation _, _), code) = code val loadConstArgs = List.foldl getConstArgs loadRegArgs regArgs (* Push the registers before the call and pop them afterwards. *) - fun makeSaves([], code) = CallFunction callKind :: code + fun makeSaves([], code) = CallAddress(codeCallKind callKind) :: code | makeSaves(PReg reg::regs, code) = let val areg = getAllocatedGenReg reg val _ = areg = eax andalso raise InternalError "codeExtended: eax in save regs" val _ = if List.exists(fn (_, r) => r = GenReg areg) regArgs then raise InternalError "codeExtended: arg reg in save regs" else () in PopR areg :: makeSaves(regs, PushToStack(RegisterArg areg) :: code) end in moveIfNecessary({dst=destReg, src=realDest, kind=case realDest of GenReg _ => moveNativeWord | _ => MoveDouble}, makeSaves(saveRegs, loadConstArgs)) end | codeExtended _ ({instr=AllocateMemoryOperation{ size, flags, dest=PReg dReg, saveRegs}, ...}, code) = let val preserve = getSaveRegs saveRegs in llAllocateMemoryOperation({ size=size, flags=flags, dest=getAllocatedReg dReg, saveRegs=preserve}, code) end | codeExtended _ ({instr=AllocateMemoryVariable{size=PReg size, dest=PReg dest, saveRegs}, ...}, code) = let (* Simple case - no initialiser. *) val saveRegs = getSaveRegs saveRegs val sReg = getAllocatedGenReg size and dReg = getAllocatedGenReg dest val _ = sReg <> dReg orelse raise InternalError "codeGenICode-AllocateMemoryVariable" val allocCode = [ (* Store it as the length field. *) Move{source=RegisterArg sReg, moveSize=opSizeToMove polyWordOpSize, destination=MemoryArg {base=dReg, offset= ~ (Word.toInt wordSize), index=NoIndex}}, (* Untag the length *) ShiftConstant{ shiftType=SHR, output=sReg, shift=0w1, opSize=polyWordOpSize}, (* Allocate the memory *) AllocStoreVariable{ size=sReg, output=dReg, saveRegs=saveRegs} ] (* Convert to an object index if necessary. *) val convertToObjId = if targetArch = ObjectId32Bit then [ ShiftConstant{ shiftType=SHR, output=dReg, shift=0w2, opSize=OpSize64 }, ArithToGenReg{ opc=SUB, output=dReg, source=RegisterArg ebx, opSize=nativeWordOpSize } ] else [] in convertToObjId @ allocCode @ code end | codeExtended _ ({instr=InitialiseMem{size=PReg sReg, addr=PReg aReg, init=PReg iReg}, ...}, code) = (* We are going to use rep stosl/q to set the memory. That requires the length to be in ecx, the initialiser to be in eax and the destination to be edi. *) RepeatOperation (if polyWordOpSize = OpSize64 then STOS64 else STOS32):: moveIfNecessary({src=getAllocatedReg iReg, dst=GenReg eax, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg aReg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg sReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=InitialisationComplete, ...}, code) = StoreInitialised :: code | codeExtended _ ({instr=BeginLoop, ...}, code) = code | codeExtended _ ({instr=JumpLoop{regArgs, stackArgs, checkInterrupt, workReg}, ...}, code) = let val workReg = Option.map (fn PReg r => getAllocatedReg r) workReg (* TODO: Make the sources and destinations "friends". *) (* We must leave stack entries as stack entries for the moment as with TailCall. *) fun codeArg(StackLocation{wordOffset, ...}) = StackSource wordOffset | codeArg arg = OtherSource(codeExtArgument arg) val extStackArgs = map (fn (src, stack, _) => {dst=StackDest stack, src=codeArg src}) stackArgs val extRegArgs = map (fn (a, PReg r) => {src=codeArg a, dst=RegDest(getAllocatedReg r)}) regArgs val checkCode = case checkInterrupt of NONE => [] | SOME saveRegs => testRegAndTrap (esp, StackOverflowCall, getSaveRegs saveRegs) in checkCode @ moveMultipleValues(extStackArgs @ extRegArgs, workReg, code) end | codeExtended _ ({instr=RaiseExceptionPacket{ packetReg=PReg preg }, ...}, code) = (* We need a work register here. It can be any register other than eax since we don't preserve registers across calls. *) RaiseException { workReg=ecx } :: moveIfNecessary({src=getAllocatedReg preg, dst=GenReg eax, kind=moveNativeWord}, code) | codeExtended _ ({instr=ReserveContainer{size, ...}, ...}, code) = (* The memory must be cleared in case we have a GC. *) List.tabulate(size, fn _ => PushToStack(NonAddressConstArg(tag 0))) @ code | codeExtended {flow} ({instr=IndexedCaseOperation{testReg=PReg tReg, workReg=PReg wReg}, ...}, code) = let val testReg = getAllocatedReg tReg val workReg = getAllocatedReg wReg val _ = testReg <> workReg orelse raise InternalError "IndexedCaseOperation - same registers" val rReg = asGenReg testReg and wReg = asGenReg workReg val _ = rReg <> wReg orelse raise InternalError "IndexedCaseOperation - same registers" (* This should only be within a block with an IndexedBr flow type. *) val cases = case flow of IndexedBr cases => cases | _ => raise InternalError "codeGenICode: IndexedCaseOperation" val caseLabels = map getBlockLabel cases val startJumpTable = makeLabel() (* Compute the jump address. The index is a tagged integer so it is already multiplied by 2. We need to multiply by four to get the correct size. Subtract off the shifted tag. *) val jumpSize = ref JumpSize8 - (* We use JumpToFunction even though we're not actually going to a new function. *) in - JumpTable{cases=caseLabels, jumpSize=jumpSize} :: JumpLabel startJumpTable :: JumpToFunction(DirectReg wReg) :: + JumpTable{cases=caseLabels, jumpSize=jumpSize} :: JumpLabel startJumpTable :: JumpAddress(RegisterArg wReg) :: IndexedJumpCalc{ addrReg=wReg, indexReg=rReg, jumpSize=jumpSize } :: LoadLabelAddress{label=startJumpTable, output=wReg} :: code end | codeExtended _ ({instr=LockMutable{addr=PReg pr}, ...}, code) = let val (bReg, index) = if targetArch = ObjectId32Bit then (ebx, Index4(asGenReg(getAllocatedReg pr))) else (asGenReg(getAllocatedReg pr), NoIndex) in (* Mask off the mutable bit. *) ArithByteMemConst{opc=AND, address={base=bReg, offset= ~1, index=index}, source=0wxff - F_mutable} :: code end | codeExtended _ ({instr=WordComparison{ arg1=PReg pr, arg2, opSize, ... }, ...}, code) = ArithToGenReg {opc=CMP, output=asGenReg(getAllocatedReg pr), source=codeExtArgumentAsGenReg arg2, opSize=opSize} :: code | codeExtended _ ({instr=CompareLiteral{ arg1, arg2, opSize, ... }, ...}, code) = ( case decache arg1 of (* N.B. We MUST decache since we're assuming that the base reg is not used. *) RegisterArgument(PReg pr) => ArithToGenReg {opc=CMP, output=asGenReg(getAllocatedReg pr), source=NonAddressConstArg arg2, opSize=opSize} :: code | MemoryLocation{base=PReg br, offset, index=ObjectIndex, ...} => ArithMemConst{ opc=CMP, address={offset=offset, base=ebx, index=Index4(asGenReg(getAllocatedReg br))}, source=arg2, opSize=opSize } :: code | MemoryLocation{base=PReg br, index, offset, ...} => ArithMemConst{ opc=CMP, address={offset=offset, base=asGenReg(getAllocatedReg br), index=codeExtIndex index}, source=arg2, opSize=opSize } :: code | StackLocation{wordOffset, ...} => ArithMemConst{ opc=CMP, address={offset=wordOffset*Word.toInt nativeWordSize, base=esp, index=NoIndex}, source=arg2, opSize=opSize } :: code | _ => raise InternalError "CompareLiteral" ) | codeExtended _ ({instr=CompareByteMem{ arg1={base=PReg br, offset, index}, arg2, ... }, ...}, code) = let val (bReg, index) = case index of ObjectIndex => (ebx, Index4(asGenReg(getAllocatedReg br))) | _ => (asGenReg(getAllocatedReg br), codeExtIndex index) in ArithByteMemConst{ opc=CMP, address={offset=offset, base=bReg, index=index}, source=arg2 } :: code end (* Set up an exception handler. *) | codeExtended {flow} ({instr=PushExceptionHandler{workReg=PReg hReg}, ...}, code) = let (* Set up an exception handler. *) val workReg=getAllocatedReg hReg (* Although we're pushing this to the stack we need to use LEA on the X86/64 and some arithmetic on the X86/32. We need a work reg for that. *) val handleReg = asGenReg workReg (* This should only be within a block with a SetHandler flow type. *) val handleLabel = case flow of SetHandler{ handler, ...} => handler | _ => raise InternalError "codeGenICode: PushExceptionHandler" val labelRef = getBlockLabel handleLabel (* Set up the handler by pushing the old handler to the stack, pushing the entry point and setting the handler address to the current stack pointer. *) in ( Move{source=RegisterArg esp, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PushToStack(RegisterArg handleReg) :: LoadLabelAddress{ label=labelRef, output=handleReg} :: PushToStack(MemoryArg{base=ebp, offset=memRegHandlerRegister, index=NoIndex}) :: code) end (* Pop an exception handler at the end of a handled section. Executed if no exception has been raised. This removes items from the stack. *) | codeExtended _ ({instr=PopExceptionHandler{workReg=PReg wReg, ...}, ...}, code) = let val workReg = getAllocatedReg wReg val wReg = asGenReg workReg in (* The stack pointer has been adjusted to just above the two words that were stored in PushExceptionHandler. *) ( Move{source=RegisterArg wReg, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PopR wReg :: ResetStack{numWords=1, preserveCC=false} :: code) end (* Start of a handler. Sets the address associated with PushExceptionHandler and provides a register for the packet.*) | codeExtended _ ({instr=BeginHandler{packetReg=PReg pReg, workReg=PReg wReg}, ...}, code) = let (* The exception packet is in rax. *) val realPktReg = getAllocatedReg pReg val realWorkreg = getAllocatedGenReg wReg (* The code here is almost the same as PopExceptionHandler. The only real difference is that PopExceptionHandler needs to pass the result of executing the handled code which could be in any register. This code needs to transmit the exception packet and that is always in rax. *) val beginHandleCode = Move{source=RegisterArg realWorkreg, destination=MemoryArg {offset=memRegHandlerRegister, base=ebp, index=NoIndex}, moveSize=opSizeToMove nativeWordOpSize} :: PopR realWorkreg :: ResetStack{numWords=1, preserveCC=false} :: Move{ source=MemoryArg{base=ebp, offset=memRegHandlerRegister, index=NoIndex}, destination=RegisterArg esp, moveSize=opSizeToMove nativeWordOpSize } :: code in moveIfNecessary({src=GenReg eax, dst=realPktReg, kind=moveNativeWord }, beginHandleCode) end | codeExtended _ ({instr=ReturnResultFromFunction { resultReg=PReg resReg, realReg, numStackArgs }, ...}, code) = let val resultReg = getAllocatedReg resReg (* If for some reason it's not in the right register we have to move it there. *) in ReturnFromFunction numStackArgs :: moveIfNecessary({src=resultReg, dst=realReg, kind=moveNativeWord}, code) end | codeExtended _ ({instr=ArithmeticFunction{oper=SUB, resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = (* Subtraction - this is special because it can only be done one way round. The first argument must be in a register. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg in ArithToGenReg { opc=SUB, output=asGenReg realDestReg, source=codeExtArgumentAsGenReg operand2, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=ArithmeticFunction{oper, resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = ( case decache operand2 of RegisterArgument(PReg op2Reg) => (* Arithmetic operation with both arguments as registers. These operations are all symmetric so we can try to put either argument into the result reg and then do the operation on the other arg. *) let val realDestReg = getAllocatedGenReg resReg val realOp1Reg = getAllocatedGenReg op1Reg and realOp2Reg = getAllocatedGenReg op2Reg val (operandReg, moveInstr) = if realOp1Reg = realDestReg then (realOp2Reg, code) else if realOp2Reg = realDestReg then (realOp1Reg, code) else (realOp2Reg, Move{source=RegisterArg realOp1Reg, destination=RegisterArg realDestReg, moveSize=opSizeToMove opSize} :: code) in ArithToGenReg { opc=oper, output=realDestReg, source=RegisterArg operandReg, opSize=opSize } :: moveInstr end | operand2 => (* Arithmetic operation with the first argument in a register and the second a constant or memory location. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg val op2Arg = codeExtArgumentAsGenReg operand2 (* If we couldn't put it in the result register we have to copy it there. *) in ArithToGenReg { opc=oper, output=asGenReg realDestReg, source=op2Arg, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end ) | codeExtended _ ({instr=TestTagBit{arg, ...}, ...}, code) = TestByteBits{arg=codeExtArgumentAsGenReg arg, bits=0w1} :: code | codeExtended _ ({instr=PushValue {arg, ...}, ...}, code) = PushToStack(codeExtArgumentAsGenReg arg) :: code | codeExtended _ ({instr=CopyToCache{source=PReg sreg, dest as PReg dreg, kind}, ...}, code) = if not (isUsed dest) then code else let val realDestReg = getAllocatedReg dreg (* Get the source register using the current destination as a preference. *) val realSrcReg = getAllocatedReg sreg in (* If the source is the same as the destination we don't need to do anything. *) moveIfNecessary({src=realSrcReg, dst=realDestReg, kind=kind}, code) end | codeExtended _ ({instr=ResetStackPtr {numWords, preserveCC}, ...}, code) = ( numWords >= 0 orelse raise InternalError "codeGenICode: ResetStackPtr - negative offset"; ResetStack{numWords=numWords, preserveCC=preserveCC} :: code ) | codeExtended _ ({instr=StoreToStack{ source, stackOffset, ... }, ...}, code) = llStoreArgument{ source=codeExtArgument source, base=esp, offset=stackOffset*Word.toInt nativeWordSize, index=NoIndex, kind=moveNativeWord} :: code | codeExtended _ ({instr=TagValue{source=PReg srcReg, dest as PReg dReg, opSize, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = asGenReg(getAllocatedReg dReg) val realSReg = asGenReg(getAllocatedReg srcReg) in (* N.B. Using LEA with a base register and an index multiplier of 1 is shorter than using no base register and a multiplier of two. *) (* TODO: If the value we're tagging is a byte or a 16-bit value we can use OpSize32 and possibly save the Rex byte. *) LoadAddress{ output=regResult, offset=1, base=SOME realSReg, index=Index1 realSReg, opSize=opSize } :: code end | codeExtended _ ({instr=UntagValue{dest as PReg dReg, cache=SOME(PReg cacheReg), opSize, ...}, ...}, code) = if not (isUsed dest) then code else moveIfNecessary({src=getAllocatedReg cacheReg, dst=getAllocatedReg dReg, kind=opSizeToIMove opSize}, code) | codeExtended _ ({instr=UntagValue{source=PReg sReg, dest as PReg dReg, isSigned, opSize, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = getAllocatedReg dReg val realSReg = getAllocatedReg sReg in (* For most cases we're going to be using a 32-bit word if this is 32-in-64. The exception is when converting a word to a signed large-word. *) ShiftConstant{ shiftType=if isSigned then SAR else SHR, output=asGenReg regResult, shift=0w1, opSize=opSize } :: moveIfNecessary({src=realSReg, dst=regResult, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=LoadEffectiveAddress{base, offset, index=ObjectIndex, dest=PReg dReg, opSize}, ...}, code) = let val destReg = asGenReg(getAllocatedReg dReg) val bReg = case base of SOME(PReg br) => asGenReg(getAllocatedReg br) | NONE => raise InternalError "LoadEffectiveAddress - ObjectIndex but no base" in LoadAddress{ output=destReg, offset=offset, base=SOME ebx, index=Index4 bReg, opSize=opSize } :: code end | codeExtended _ ({instr=LoadEffectiveAddress{base, offset, index, dest=PReg dReg, opSize}, ...}, code) = let val destReg = asGenReg(getAllocatedReg dReg) val bReg = case base of SOME(PReg br) => SOME(asGenReg(getAllocatedReg br)) | NONE => NONE val indexR = codeExtIndex index in LoadAddress{ output=destReg, offset=offset, base=bReg, index=indexR, opSize=opSize } :: code end | codeExtended _ ({instr=ShiftOperation{shift, resultReg=PReg resReg, operand=PReg operReg, shiftAmount=IntegerConstant i, opSize, ...}, ...}, code) = let val realDestReg = getAllocatedReg resReg val realOpReg = getAllocatedReg operReg in ShiftConstant{ shiftType=shift, output=asGenReg realDestReg, shift=Word8.fromLargeInt i, opSize=opSize } :: moveIfNecessary({src=realOpReg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end | codeExtended _ ({instr=ShiftOperation{shift, resultReg=PReg resReg, operand=PReg operReg, shiftAmount=RegisterArgument(PReg shiftReg), opSize, ...}, ...}, code) = let val realDestReg = getAllocatedReg resReg val realShiftReg = getAllocatedReg shiftReg val realOpReg = getAllocatedReg operReg (* We want the shift in ecx. We may not have got it there but the register should be free. The shift is masked to 5 or 6 bits so we have to check for larger shift values at a higher level.*) in ShiftVariable{ shiftType=shift, output=asGenReg realDestReg, opSize=opSize } :: moveIfNecessary({src=realOpReg, dst=realDestReg, kind=opSizeToIMove opSize}, moveIfNecessary({src=realShiftReg, dst=GenReg ecx, kind=Move32Bit (* < 64*)}, code)) end | codeExtended _ ({instr=ShiftOperation _, ...}, _) = raise InternalError "codeExtended - ShiftOperation" | codeExtended _ ({instr= Multiplication{resultReg=PReg resReg, operand1=PReg op1Reg, operand2, opSize, ...}, ...}, code) = ( case decache operand2 of RegisterArgument(PReg op2Reg) => let (* Treat exactly the same as ArithmeticFunction. *) val realDestReg = getAllocatedGenReg resReg val realOp1Reg = getAllocatedGenReg op1Reg and realOp2Reg = getAllocatedGenReg op2Reg val (operandReg, moveInstr) = if realOp1Reg = realDestReg then (realOp2Reg, code) else if realOp2Reg = realDestReg then (realOp1Reg, code) else (realOp2Reg, Move{source=RegisterArg realOp1Reg, destination=RegisterArg realDestReg, moveSize=opSizeToMove opSize} :: code) in MultiplyR { source=RegisterArg operandReg, output=realDestReg, opSize=opSize } :: moveInstr end | operand2 => (* Multiply operation with the first argument in a register and the second a constant or memory location. *) let val realDestReg = getAllocatedReg resReg val realOp1Reg = getAllocatedReg op1Reg val op2Arg = codeExtArgumentAsGenReg operand2 in MultiplyR { output=asGenReg realDestReg, source=op2Arg, opSize=opSize } :: moveIfNecessary({src=realOp1Reg, dst=realDestReg, kind=opSizeToIMove opSize}, code) end ) | codeExtended _ ({instr=Division{isSigned, dividend=PReg regDivid, divisor, quotient=PReg regQuot, remainder=PReg regRem, opSize}, ...}, code) = let (* TODO: This currently only supports the dividend in a register. LargeWord division will generally load the argument from a box so we could support a memory argument for that case. Word and integer values will always have to be detagged. *) (* Division is specific as to the registers. The dividend must be eax, quotient is eax and the remainder is edx. *) val realDiviReg = getAllocatedReg regDivid val realQuotReg = getAllocatedReg regQuot val realRemReg = getAllocatedReg regRem val divisorArg = codeExtArgument divisor val divisorReg = argAsGenReg divisorArg val _ = divisorReg <> eax andalso divisorReg <> edx orelse raise InternalError "codeGenICode: Division" (* rdx needs to be set to the high order part of the dividend. For signed division that means sign-extending rdx, for unsigned division we clear it. We only need a 32-bit clear since the top 32-bits are cleared anyway. *) val setRDX = if isSigned then SignExtendForDivide opSize else ArithToGenReg{ opc=XOR, output=edx, source=RegisterArg edx, opSize=OpSize32 } in (* We may need to move one or more of the registers although normally that won't be necessary. Almost certainly only either the remainder or the quotient will actually be used. *) moveMultipleRegisters([{src=GenReg eax, dst=realQuotReg}, {src=GenReg edx, dst=realRemReg}], DivideAccR {arg=divisorReg, isSigned=isSigned, opSize=opSize} :: setRDX :: moveIfNecessary({src=realDiviReg, dst=GenReg eax, kind=opSizeToIMove opSize}, code)) end | codeExtended _ ({instr=AtomicExchangeAndAdd{base=PReg bReg, source=PReg sReg}, ...}, code) = let val baseReg = asGenReg (getAllocatedReg bReg) and outReg = asGenReg (getAllocatedReg sReg) val address = if targetArch = ObjectId32Bit then {base=ebx, index=Index4 baseReg, offset=0} else {base=baseReg, index=NoIndex, offset=0} in AtomicXAdd{address=address, output=outReg, opSize=polyWordOpSize} :: code end | codeExtended _ ({instr=BoxValue{boxKind, source=PReg sReg, dest as PReg dReg, saveRegs}, ...}, code) = if not (isUsed dest) then code else let val preserve = getSaveRegs saveRegs val (srcReg, boxSize, moveKind) = case boxKind of BoxLargeWord => (getAllocatedReg sReg, Word.toInt(nativeWordSize div wordSize), moveNativeWord) | BoxX87Double => (getAllocatedReg sReg, Word.toInt(0w8 div wordSize), MoveDouble) | BoxX87Float => (getAllocatedReg sReg, Word.toInt(0w4 div wordSize), MoveFloat) | BoxSSE2Double => (getAllocatedReg sReg, Word.toInt(0w8 div wordSize), MoveDouble) | BoxSSE2Float => (getAllocatedReg sReg, Word.toInt(0w4 div wordSize), MoveFloat) val dstReg = getAllocatedReg dReg val (bReg, index) = if targetArch = ObjectId32Bit then (ebx, Index4(asGenReg dstReg)) else (asGenReg dstReg, NoIndex) in StoreInitialised :: llStoreArgument{ source=RegisterArg srcReg, offset=0, base=bReg, index=index, kind=moveKind} :: llAllocateMemoryOperation({ size=boxSize, flags=0wx1, dest=dstReg, saveRegs=preserve}, code) end | codeExtended _ ({instr=CompareByteVectors{vec1Addr=PReg v1Reg, vec2Addr=PReg v2Reg, length=PReg lReg, ...}, ...}, code) = (* There's a complication here. CompareByteVectors generates REPE CMPSB to compare the vectors but the condition code is only set if CMPSB is executed at least once. If the value in RCX/ECX is zero it will never be executed and the condition code will be unchanged. We want the result to be "equal" in that case so we need to ensure that is the case. It's quite possible that the condition code has just been set by shifting RCX/ECX to remove the tag in which case it will have set "equal" if the value was zero. We use CMP R/ECX,R/ECX which is two bytes in 32-bit. If we knew the length was non-zero (e.g. a constant) we could avoid this. *) RepeatOperation CMPS8 :: ArithToGenReg {opc=CMP, output=ecx, source=RegisterArg ecx, opSize=OpSize32} :: moveIfNecessary({src=getAllocatedReg v1Reg, dst=GenReg esi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg v2Reg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg lReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=BlockMove{srcAddr=PReg sReg, destAddr=PReg dReg, length=PReg lReg, isByteMove}, ...}, code) = (* We may need to move these into the appropriate registers. They have been reserved but it's still possible the values could be in something else. *) RepeatOperation(if isByteMove then MOVS8 else if polyWordOpSize = OpSize64 then MOVS64 else MOVS32) :: moveIfNecessary({src=getAllocatedReg sReg, dst=GenReg esi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg dReg, dst=GenReg edi, kind=moveNativeWord}, moveIfNecessary({src=getAllocatedReg lReg, dst=GenReg ecx, kind=moveNativeWord}, code))) | codeExtended _ ({instr=X87Compare{arg1=PReg argReg, arg2, isDouble, ...}, ...}, code) = let val fpReg = getAllocatedFPReg argReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: CompareFloatingPt not fp0" (* This currently pops the value. *) val precision = if isDouble then DoublePrecision else SinglePrecision in case codeExtArgumentAsFPReg arg2 of RegisterArg fpReg2 => FPArithR{opc=FCOMP, source=fpReg2} :: code | MemoryArg{offset, base=baseReg, index=NoIndex} => FPArithMemory{opc=FCOMP, base=baseReg, offset=offset, precision=precision} :: code | AddressConstArg const => FPArithConst{opc=FCOMP, source = const, precision=precision} :: code | _ => raise InternalError "codeGenICode: CompareFloatingPt: TODO" end | codeExtended _ ({instr=SSE2Compare{arg1=PReg argReg, arg2, isDouble, ...}, ...}, code) = let val xmmReg = getAllocatedXMMReg argReg val arg2Code = codeExtArgumentAsXMMReg arg2 in XMMArith { opc= if isDouble then SSE2CompDouble else SSE2CompSingle, output=xmmReg, source=arg2Code} :: code end | codeExtended _ ({instr=X87FPGetCondition{dest=PReg dReg, ...}, ...}, code) = moveIfNecessary({src=GenReg eax, dst=getAllocatedReg dReg, kind=Move32Bit}, FPStatusToEAX :: code) | codeExtended _ ({instr=X87FPArith{opc, resultReg=PReg resReg, arg1=PReg op1Reg, arg2, isDouble}, ...}, code) = let val realDestReg = getAllocatedFPReg resReg val realOp1Reg = getAllocatedFPReg op1Reg val _ = realDestReg = fp0 orelse raise InternalError "codeGenICode: FloatingPointArith not fp0" val _ = realOp1Reg = fp0 orelse raise InternalError "codeGenICode: FloatingPointArith not fp0" val op2Arg = codeExtArgumentAsFPReg arg2 val precision = if isDouble then DoublePrecision else SinglePrecision in case op2Arg of MemoryArg{offset, base=baseReg, index=NoIndex} => FPArithMemory{opc=opc, base=baseReg, offset=offset, precision=precision} :: code | AddressConstArg const => FPArithConst{opc=opc, source = const, precision=precision} :: code | _ => raise InternalError "codeGenICode: X87FPArith: TODO" end | codeExtended _ ({instr=X87FPUnaryOps{fpOp, dest=PReg resReg, source=PReg op1Reg}, ...}, code) = let val realDestReg = getAllocatedFPReg resReg val realOp1Reg = getAllocatedFPReg op1Reg val _ = realDestReg = fp0 orelse raise InternalError "codeGenICode: X87FPUnaryOps not fp0" val _ = realOp1Reg = fp0 orelse raise InternalError "codeGenICode: X87FPUnaryOps not fp0" in FPUnary fpOp :: code end | codeExtended _ ({instr=X87Float{dest=PReg resReg, source}, ...}, code) = let val intSource = codeExtArgumentAsGenReg source val fpReg = getAllocatedFPReg resReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: FloatFixedInt not fp0" in (* This is complicated. The integer value has to be in memory not in a register so we have to push it to the stack and then make sure it is popped afterwards. Because it is untagged it is unsafe to leave it. *) ResetStack{numWords=1, preserveCC=false} :: FPLoadInt{ base=esp, offset=0, opSize=polyWordOpSize } :: PushToStack intSource :: code end | codeExtended _ ({instr=SSE2Float{dest=PReg resReg, source}, ...}, code) = let val xmmResReg = getAllocatedXMMReg resReg val srcReg = case codeExtArgumentAsGenReg source of RegisterArg srcReg => srcReg | _ => raise InternalError "FloatFixedInt: not reg" in XMMConvertFromInt{ output=xmmResReg, source=srcReg, opSize=polyWordOpSize} :: code end | codeExtended _ ({instr=SSE2FPUnary{opc, resultReg=PReg resReg, source}, ...}, code) = let val realDestReg = getAllocatedXMMReg resReg val opArg = codeExtArgumentAsXMMReg source val sse2Op = case opc of SSE2UDoubleToFloat => SSE2DoubleToFloat | SSE2UFloatToDouble => SSE2FloatToDouble in XMMArith{ opc=sse2Op, output=realDestReg, source=opArg} :: code end | codeExtended _ ({instr=SSE2FPBinary{opc, resultReg=PReg resReg, arg1=PReg op1Reg, arg2}, ...}, code) = let val realDestReg = getAllocatedXMMReg resReg val realOp1Reg = getAllocatedXMMReg op1Reg val op2Arg = codeExtArgumentAsXMMReg arg2 (* xorpd and andpd require 128-bit arguments with 128-bit alignment. *) val _ = case (opc, op2Arg) of (SSE2BXor, RegisterArg _) => () | (SSE2BXor, _) => raise InternalError "codeGenICode - SSE2Xor not in register" | (SSE2BAnd, RegisterArg _) => () | (SSE2BAnd, _) => raise InternalError "codeGenICode - SSE2And not in register" | _ => () val doMove = if realDestReg = realOp1Reg then code else XMMArith { opc=SSE2MoveDouble, source=RegisterArg realOp1Reg, output=realDestReg } :: code val sse2Op = case opc of SSE2BAddDouble => SSE2AddDouble | SSE2BSubDouble => SSE2SubDouble | SSE2BMulDouble => SSE2MulDouble | SSE2BDivDouble => SSE2DivDouble | SSE2BAddSingle => SSE2AddSingle | SSE2BSubSingle => SSE2SubSingle | SSE2BMulSingle => SSE2MulSingle | SSE2BDivSingle => SSE2DivSingle | SSE2BXor => SSE2Xor | SSE2BAnd => SSE2And in XMMArith{ opc=sse2Op, output=realDestReg, source=op2Arg} :: doMove end | codeExtended _ ({instr=TagFloat{source=PReg srcReg, dest as PReg dReg, ...}, ...}, code) = if not (isUsed dest) then code else let val _ = targetArch = Native64Bit orelse raise InternalError "TagFloat: not 64-bit" (* Copy the value from an XMM reg into a general reg and tag it. *) val regResult = asGenReg(getAllocatedReg dReg) val realSReg = getAllocatedXMMReg srcReg in ArithToGenReg { opc=ADD, output=regResult, source=NonAddressConstArg 1, opSize=polyWordOpSize } :: ShiftConstant{ shiftType=SHL, output=regResult, shift=0w32, opSize=OpSize64} :: MoveXMMRegToGenReg { source = realSReg, output = regResult } :: code end | codeExtended _ ({instr=UntagFloat{dest as PReg dReg, cache=SOME(PReg cacheReg), ...}, ...}, code) = if not (isUsed dest) then code else moveIfNecessary({src=getAllocatedReg cacheReg, dst=getAllocatedReg dReg, kind=MoveFloat}, code) | codeExtended _ ({instr=UntagFloat{source, dest as PReg dReg, ...}, ...}, code) = if not (isUsed dest) then code else let val regResult = getAllocatedXMMReg dReg in case codeExtArgumentAsGenReg source of RegisterArg realSReg => XMMShiftRight{ output=regResult, shift=0w4 (* Bytes - not bits *) } :: MoveGenRegToXMMReg {source=realSReg, output=regResult} :: code | MemoryArg{base, offset, index} => (* If the value is in memory we can just load the high order word. *) XMMArith { opc=SSE2MoveFloat, source=MemoryArg{base=base, offset=offset+4, index=index}, output=regResult } :: code | NonAddressConstArg ic => (* Shift down and then load from the non-constant area. *) XMMArith { opc=SSE2MoveFloat, source=NonAddressConstArg(IntInf.~>>(ic, 0w32)), output=regResult } :: code | _ => raise InternalError "UntagFloat - not register or memory" end | codeExtended _ ({instr=GetSSE2ControlReg{dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, get the MXCSR register into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg in PopR regResult :: XMMStoreCSR{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SetSSE2ControlReg{source=PReg sReg}, ...}, code) = let (* This has to work through memory. Push the register to the stack, store the value into the control register and remove it from the stack. *) val sourceReg = getAllocatedGenReg sReg in ResetStack{ numWords=1, preserveCC=false } :: XMMLoadCSR{base=esp, offset=0, index=NoIndex } :: PushToStack(RegisterArg sourceReg) :: code end | codeExtended _ ({instr=GetX87ControlReg{dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, get the X87 control register into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg in PopR regResult :: FPStoreCtrlWord{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SetX87ControlReg{source=PReg sReg}, ...}, code) = let (* This has to work through memory. Push the register to the stack, store the value into the control register and remove it from the stack. *) val sourceReg = getAllocatedGenReg sReg in ResetStack{ numWords=1, preserveCC=false } :: FPLoadCtrlWord{base=esp, offset=0, index=NoIndex } :: PushToStack(RegisterArg sourceReg) :: code end | codeExtended _ ({instr=X87RealToInt{source=PReg sReg, dest=PReg dReg}, ...}, code) = let (* This has to work through memory. Reserve one word on the stack, convert the value into it and pop it to the register. *) val regResult = getAllocatedGenReg dReg val fpReg = getAllocatedFPReg sReg val _ = fpReg = fp0 orelse raise InternalError "codeGenICode: CompareFloatingPt not fp0" (* This currently pops the value. *) in PopR regResult :: FPStoreInt{base=esp, offset=0, index=NoIndex } :: PushToStack(NonAddressConstArg 0) :: code end | codeExtended _ ({instr=SSE2RealToInt{source, dest=PReg dReg, isDouble, isTruncate}, ...}, code) = let (* The source is either an XMM register or memory. *) val regResult = getAllocatedGenReg dReg val opArg = codeExtArgumentAsXMMReg source in XMMStoreInt { source=opArg, precision=if isDouble then DoublePrecision else SinglePrecision, output = regResult, isTruncate=isTruncate } :: code end | codeExtended _ ({instr=SignExtend32To64{source, dest=PReg dReg}, ...}, code) = let val regResult = getAllocatedGenReg dReg val opArg = codeExtArgumentAsGenReg source in Move{moveSize=Move32X, source=opArg, destination=RegisterArg regResult } :: code end val newCode = codeCreate (functionName, profileObject, debugSwitches) local (* processed - set to true when a block has been processed. *) val processed = Array.array(numBlocks, false) fun haveProcessed n = Array.sub(processed, n) (* Find the blocks that reference this one. This isn't essential but allows us to try to generate blocks in the order of the control flow. This in turn may allow us to use short branches rather than long ones. *) val labelRefs = Array.array(numBlocks, []) datatype flowCode = FlowCodeSimple of int | FlowCodeCMove of {code: operation list, trueJump: int, falseJump: int} (* Process this recursively to set the references. If we have unreachable blocks, perhaps because they've been merged, we don't want to include them in the reference counting. This shouldn't happen now that IdentifyReferences removes unreferenced blocks. *) fun setReferences fromLabel toLabel = case Array.sub(labelRefs, toLabel) of [] => (* Not yet visited at all. *) let val ExtendedBasicBlock{ flow, ...} = Vector.sub(blocks, toLabel) val refs = case flow of ExitCode => [] | Unconditional lab => [lab] | Conditional{trueJump, falseJump, ... } => [trueJump, falseJump] | IndexedBr labs => labs | SetHandler { handler, continue } => [handler, continue] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [continue] val () = if fromLabel >= 0 then Array.update(labelRefs, toLabel, [fromLabel]) else () in List.app (setReferences toLabel) refs end | refs => (* We've visiting this at least once. Just add us to the list. *) Array.update(labelRefs, toLabel, fromLabel :: refs) val _ = setReferences 0 0 (* Process the blocks. We keep the "stack" explicit rather than using recursion because this allows us to select both arms of a conditional branch sooner. *) fun genCode(toDo, lastFlow, code) = case List.filter (not o haveProcessed) toDo of [] => let (* There's nothing left to do. We may need to add a final branch to the end. *) val finalBranch = case lastFlow of ExitCode => [] | IndexedBr _ => [] | Unconditional dest => [UncondBranch(getBlockLabel dest)] | Conditional { condition, trueJump, falseJump, ...} => [ UncondBranch(getBlockLabel falseJump), ConditionalBranch{test=condition, label=getBlockLabel trueJump} ] | SetHandler { continue, ...} => [UncondBranch(getBlockLabel continue)] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [UncondBranch(getBlockLabel continue)] in finalBranch @ code (* Done. *) end | stillToDo as head :: _ => let local (* Check the references. If all the sources that lead up to this have already been we won't have any backward jumps. *) fun available dest = List.all haveProcessed (Array.sub(labelRefs, dest)) val continuation = case lastFlow of ExitCode => NONE | IndexedBr _ => NONE (* We could put the last branch in here. *) | Unconditional dest => if not (haveProcessed dest) andalso available dest then SOME(FlowCodeSimple dest) else NONE | Conditional {trueJump, falseJump, condition, ...} => let (* Can we replace this with a SETCC or CMOV? If both arms simply set a register to a value and either return or jump to the same location we can use a SETCC or a CMOV. *) val ExtendedBasicBlock { flow=tFlow, block=tBlock, ...} = Vector.sub(blocks, trueJump) and ExtendedBasicBlock { flow=fFlow, block=fBlock, ...} = Vector.sub(blocks, falseJump) fun cmoveOrSetcc{condition, output, tSource=IntegerConstant trueValue, fSource=IntegerConstant falseValue, kind, code} = let (* Could use SETCC. Only if we can use LEA for multiplication. The result must be tagged so we will always have a multiplier. *) val (multiplier, fValue, testCondition) = if trueValue >= falseValue then (trueValue-falseValue, falseValue, condition) else (falseValue-trueValue, trueValue, invertTest condition) val destReg = asGenReg output in if not (targetArch = Native32Bit andalso (destReg=esi orelse destReg=edi)) (* We can't use Setcc with esi or edi on native 32-bit. *) andalso (multiplier = 2 orelse multiplier = 4 orelse multiplier = 8) (* We're using LEA so can only be multiplying by 2, 4 or 8. *) andalso is32bit fValue (* and we're going to put this in the offset *) then let val effectiveOpSize = (* We can generally use 32-bit LEA except if the result is negative. *) if kind = Move32Bit orelse fValue >= 0 andalso fValue+multiplier <= 0x7fffffff then OpSize32 else OpSize64 val (index, base) = case multiplier of 2 => (Index1 destReg, SOME destReg) | 4 => (Index4 destReg, NONE) | 8 => (Index8 destReg, NONE) | _ => (NoIndex, NONE) (* Try to put the instruction to zero the register before any compare. We can do it provided the register we're going to zero isn't used in the comparison. *) fun checkArg(RegisterArg r) = r <> destReg | checkArg(MemoryArg mem) = checkMem mem | checkArg _ = true and checkMem{base, index=NoIndex, ...} = base <> destReg | checkMem{base, index=Index1 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index2 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index4 index, ...} = base <> destReg andalso index <> destReg | checkMem{base, index=Index8 index, ...} = base <> destReg andalso index <> destReg val zeroReg = ArithToGenReg { opc=XOR, output=destReg, source=RegisterArg destReg, opSize=OpSize32 } fun addXOR [] = NONE | addXOR ((instr as ResetStack _) :: tl) = (* If we can add the XOR before the ResetStack do so. *) Option.map(fn code => instr :: code) (addXOR tl) | addXOR ((instr as ArithToGenReg{output, source, ...}) :: tl) = if output <> destReg andalso checkArg source then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as ArithMemConst{address, ...}) :: tl) = if checkMem address then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as ArithByteMemConst{address, ...}) :: tl) = if checkMem address then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as XMMArith{source=MemoryArg mem, ...}) :: tl) = if checkMem mem then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as XMMArith _) :: tl) = SOME(instr :: zeroReg :: tl) | addXOR ((instr as TestByteBits{arg, ...}) :: tl) = if checkArg arg then SOME(instr :: zeroReg :: tl) else NONE | addXOR ((instr as RepeatOperation CMPS8) :: tl) = (* This uses edi, esi and ecx implicitly *) if destReg <> esi andalso destReg <> edi andalso destReg <> ecx then SOME(instr :: zeroReg :: tl) else NONE (* This seems to be just a conditional jump as a result of testing the condition code twice in Real.== *) | addXOR _ = NONE (* If we can't put the XOR before the instruction we need to either zero it using a move which won't affect the CC or we use MOVZB to extend the byte value to 32/64 bits. *) val loadAddr = LoadAddress{output=destReg, offset=Int.fromLarge fValue, base=base, index=index, opSize=effectiveOpSize} and setCond = SetCondition{output=destReg, test=testCondition} val code = case addXOR code of SOME withXOR => loadAddr :: setCond :: withXOR | NONE => loadAddr :: (* We've already check that we're not using esi/edi on native 32-bits. *) Move{destination=RegisterArg destReg, source=RegisterArg destReg, moveSize=Move8} :: setCond :: code in SOME code end else NONE end (* If either value is a memory location it isn't safe to load it. The base address may not be valid if the condition does not hold. *) | cmoveOrSetcc{tSource=MemoryLocation _, ...} = NONE | cmoveOrSetcc{fSource=MemoryLocation _, ...} = NONE | cmoveOrSetcc{condition, output, tSource, fSource, kind, code} = if targetArch = Native32Bit then NONE (* CMov doesn't work for constants. *) else let val output = asGenReg output val codeTrue = codeExtArgumentAsGenReg tSource and codeFalse = codeExtArgumentAsGenReg fSource val opSize = case kind of Move32Bit => OpSize32 | Move64Bit => OpSize64 | _ => raise InternalError "move size" (* One argument has to be loaded into a register first and the other is conditionally moved. *) val loadFalseCmoveTrue = if (case codeFalse of RegisterArg regFalse => regFalse = output | _ => false) then true (* The false value is already in the right register. *) else if (case codeTrue of RegisterArg regTrue => regTrue = output | _ => false) then false (* The true value is in the right register - have to reverse. *) else if (case codeTrue of NonAddressConstArg _ => true | _ => false) then false (* The true value is a short constant. If we use a CMOV we will have to put that in the non-constant area and use a PC-relative reference. Try to avoid it. *) else true fun cmov{codeLoad, codeMove, condition} = let val load = case codeLoad of RegisterArg regLoad => moveIfNecessary({src=GenReg regLoad, dst=GenReg output, kind=opSizeToIMove opSize}, code) | codeLoad => Move{source=codeLoad, destination=RegisterArg output, moveSize=opSizeToMove opSize} :: code in CondMove{test=condition, output=output, source=codeMove, opSize=opSize} :: load end in if loadFalseCmoveTrue then SOME(cmov{codeLoad=codeFalse, codeMove=codeTrue, condition=condition}) else SOME(cmov{codeLoad=codeTrue, codeMove=codeFalse, condition=invertTest condition}) end val isPossSetCCOrCmov = if not (haveProcessed trueJump) andalso available trueJump andalso not (haveProcessed falseJump) andalso available falseJump then case (tFlow, fFlow, tBlock, fBlock) of (ExitCode, ExitCode, [{instr=LoadArgument{dest=PReg tReg, source=tSource, kind=kindT}, ...}, {instr=ReturnResultFromFunction{resultReg=PReg resReg, realReg, numStackArgs, ...}, ...}], [{instr=LoadArgument{dest=PReg fReg, source=fSource, kind=kindF}, ...}, {instr=ReturnResultFromFunction _, ...}]) => (* The real register for the two sides should both be rax. *) let val realTReg = getAllocatedReg tReg and realFReg = getAllocatedReg fReg in if realTReg = realFReg andalso kindT = kindF andalso (kindT = Move32Bit orelse kindT = Move64Bit) then ( case cmoveOrSetcc{condition=condition, output=realTReg, tSource=tSource, fSource=fSource, kind=kindT, code=code} of SOME code => let val resultReg = getAllocatedReg resReg val code = ReturnFromFunction numStackArgs :: moveIfNecessary({src=resultReg, dst=realReg, kind=moveNativeWord}, code) in SOME{code=code, trueJump=trueJump, falseJump=falseJump} end | NONE => NONE ) else NONE end | (Unconditional tDest, Unconditional fDest, [{instr=LoadArgument{dest=PReg tReg, source=tSource, kind=kindT}, ...}], [{instr=LoadArgument{dest=PReg fReg, source=fSource, kind=kindF}, ...}]) => let val realTReg = getAllocatedReg tReg and realFReg = getAllocatedReg fReg in if tDest = fDest andalso realTReg = realFReg andalso kindT = kindF andalso (kindT = Move32Bit orelse kindT = Move64Bit) then ( case cmoveOrSetcc{condition=condition, output=realTReg, tSource=tSource, fSource=fSource, kind=kindT, code=code} of SOME code => SOME{code=code, trueJump=trueJump, falseJump=falseJump} | NONE => NONE ) else NONE end | _ => NONE else NONE in case isPossSetCCOrCmov of NONE => (* We can usually choose either destination and in nearly all cases it won't matter. The default branch is not to take forward jumps so if there is reason to believe that one branch is more likely we should follow that branch now and leave the other. If we have JO/JNO we assume that overflow is unusual. If one branch raises an exception we assume that that is unusual. *) let val (first, second) = case (condition, Vector.sub(blocks, falseJump)) of (JNO, _) => (trueJump, falseJump) | (_, ExtendedBasicBlock{ flow=ExitCode, block, ...}) => if List.exists(fn{instr=RaiseExceptionPacket _, ...} => true | _ => false) block then (trueJump, falseJump) else (falseJump, trueJump) | _ => (falseJump, trueJump) in if not (haveProcessed first) andalso available first then SOME(FlowCodeSimple first) else if not (haveProcessed second) andalso available second then SOME(FlowCodeSimple second) else NONE end | SOME args => SOME(FlowCodeCMove args) end | SetHandler { continue, ... } => (* We want the continuation if possible. We'll need a branch round the handler so that won't help. *) if not (haveProcessed continue) andalso available continue then SOME(FlowCodeSimple continue) else NONE | UnconditionalHandle _ => NONE | ConditionalHandle _ => NONE in (* First choice - continue the existing block. Second choice - the first item whose sources have all been processed. Third choice - something from the list. *) val picked = case continuation of SOME c => c | NONE => case List.find available stillToDo of SOME c => FlowCodeSimple c | NONE => FlowCodeSimple head end in case picked of FlowCodeSimple picked => let val () = Array.update(processed, picked, true) (* Code to terminate the previous block. *) val startCode = case lastFlow of ExitCode => [] | IndexedBr _ => [] | UnconditionalHandle _ => [] | Unconditional dest => if dest = picked then [] else [UncondBranch(getBlockLabel dest)] | ConditionalHandle { continue, ...} => if continue = picked then [] else [UncondBranch(getBlockLabel continue)] | SetHandler { continue, ... } => if continue = picked then [] else [UncondBranch(getBlockLabel continue)] | Conditional { condition, trueJump, falseJump, ...} => if picked = falseJump (* Usual case. *) then [ConditionalBranch{test=condition, label=getBlockLabel trueJump}] else if picked = trueJump then (* We have a jump to the true condition. Invert the jump. This is more than an optimisation. Because this immediately precedes the true block we're not going to generate a label. *) [ConditionalBranch{test=invertTest condition, label=getBlockLabel falseJump}] else [ UncondBranch(getBlockLabel falseJump), ConditionalBranch{test=condition, label=getBlockLabel trueJump} ] (* Code-generate the body with the code we've done so far at the end. Add a label at the start if necessary. *) local (* If the previous block dropped through to this and this was the only reference then we don't need a label. *) fun onlyJumpingHere (lab: int) = if lab <> picked then false else case Array.sub(labelRefs, picked) of [singleton] => singleton = lab | _ => false val noLabel = case lastFlow of ExitCode => picked = 0 (* Unless this was the first block. *) | Unconditional dest => onlyJumpingHere dest | Conditional { trueJump, falseJump, ...} => onlyJumpingHere trueJump orelse onlyJumpingHere falseJump | IndexedBr _ => false | SetHandler _ => false | UnconditionalHandle _ => false | ConditionalHandle { continue, ...} => onlyJumpingHere continue in val startLabel = if noLabel then [] else [JumpLabel(getBlockLabel picked)] end val ExtendedBasicBlock { flow, block, ...} = Vector.sub(blocks, picked) local fun genCodeBlock(instr, code) = codeExtended {flow=flow} (instr, code) in val bodyCode = List.foldl genCodeBlock (startLabel @ startCode @ code) block end val addSet = case flow of ExitCode => [] | IndexedBr cases => cases | Unconditional dest => [dest] | Conditional {trueJump, falseJump, ...} => [falseJump, trueJump] | SetHandler { handler, continue } => [handler, continue] | UnconditionalHandle _ => [] | ConditionalHandle { continue, ...} => [continue] in genCode(addSet @ stillToDo, flow, bodyCode) end | FlowCodeCMove{code, trueJump, falseJump} => let (* We've generated a conditional move and possibly a return. If the trueJump and falseJump are only ever referenced from this block they're done, otherwise we still need to do them. *) val _ = case Array.sub(labelRefs, trueJump) of [_] => Array.update(processed, trueJump, true) | _ => () val _ = case Array.sub(labelRefs, falseJump) of [_] => Array.update(processed, falseJump, true) | _ => () val ExtendedBasicBlock { flow, ...} = Vector.sub(blocks, trueJump) val addSet = case flow of ExitCode => [] | Unconditional dest => [dest] | _ => raise InternalError "FlowCodeCMove" in genCode(addSet @ stillToDo, flow, code) end end in val ops = genCode([0], ExitCode, []) end in X86OPTIMISE.generateCode{code=newCode, ops=List.rev ops, labelCount= !outputLabelCount, resultClosure=resultClosure} end val nGenRegs = List.length generalRegisters structure Sharing = struct type intSet = intSet and extendedBasicBlock = extendedBasicBlock and regProperty = regProperty and reg = reg and closureRef = closureRef end end; diff --git a/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML b/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML index 786db2e0..8a3641d6 100644 --- a/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML +++ b/mlsource/MLCompiler/CodeTree/X86Code/X86OUTPUTCODE.ML @@ -1,3949 +1,3922 @@ (* - Copyright David C. J. Matthews 1989, 2000, 2009-10, 2012-13, 2015-18 + Copyright David C. J. Matthews 1989, 2000, 2009-10, 2012-13, 2015-19 Based on original code: 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 *) (* Title: Code Generator Routines. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright Cambridge University 1989 *) (* This module contains the code vector and operations to insert code into it. Each procedure is compiled into a separate segment. Initially it is compiled into a fixed size segment, and then copied into a segment of the correct size at the end. This module contains all the definitions of the X86 opCodes and registers. It uses "codeseg" to create and operate on the segment itself. *) functor X86OUTPUTCODE ( structure DEBUG: DEBUGSIG structure PRETTY: PRETTYSIG (* for compilerOutTag *) structure CODE_ARRAY: CODEARRAYSIG ) : X86CODESIG = struct open CODE_ARRAY open DEBUG open Address open Misc (* May be targeted at native 32-bit, native 64-bit or X86/64 with 32-bit words and addresses as object Ids. *) datatype targetArch = Native32Bit | Native64Bit | ObjectId32Bit val targetArch = case PolyML.architecture() of "I386" => Native32Bit | "X86_64" => Native64Bit | "X86_64_32" => ObjectId32Bit | _ => raise InternalError "Unknown target architecture" (* Some checks - *) val () = case (targetArch, wordSize, nativeWordSize) of (Native32Bit, 0w4, 0w4) => () | (Native64Bit, 0w8, 0w8) => () | (ObjectId32Bit, 0w4, 0w8) => () | _ => raise InternalError "Mismatch of architecture and word-length" val hostIsX64 = targetArch <> Native32Bit infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 val op << = Word.<< and op >> = Word.>> val (*op <<+ = LargeWord.<< and *) op >>+ = LargeWord.>> val op <<- = Word8.<< and op >>- = Word8.>> val op orb8 = Word8.orb val op andb8 = Word8.andb val op andb = Word.andb (* and op andbL = LargeWord.andb *) and op orb = Word.orb val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord (*and word8ToWord = Word.fromLargeWord o Word8.toLargeWord*) val exp2_16 = 0x10000 val exp2_31 = 0x80000000: LargeInt.int (* Returns true if this a 32-bit machine or if the constant is within 32-bits. This is exported to the higher levels. N.B. The test for not isX64 avoids a significant overhead with arbitrary precision arithmetic on X86/32. *) fun is32bit v = not hostIsX64 orelse ~exp2_31 <= v andalso v < exp2_31 (* tag a short constant *) fun tag c = 2 * c + 1; fun is8BitL (n: LargeInt.int) = ~ 0x80 <= n andalso n < 0x80 local val shift = if wordSize = 0w4 then 0w2 else if wordSize = 0w8 then 0w3 else raise InternalError "Invalid word size for x86_32 or x86+64" in fun wordsToBytes n = n << shift and bytesToWords n = n >> shift end infix 6 addrPlus addrMinus; (* All indexes into the code vector have type "addrs". This is really a legacy. *) type addrs = Word.word val addrZero = 0w0 (* This is the external label type used when constructing operations. *) datatype label = Label of { labelNo: int } (* Constants which are too large to go inline in the code are put in a list and put at the end of the code. They are arranged so that the garbage collector can find them and change them as necessary. A reference to a constant is treated like a forward reference to a label. *) datatype code = Code of { procName: string, (* Name of the procedure. *) printAssemblyCode:bool, (* Whether to print the code when we finish. *) printStream: string->unit, (* The stream to use *) lowLevelOptimise: bool, (* Whether to do the low-level optimisation pass *) profileObject : machineWord (* The profile object for this code. *) } (* Exported functions *) fun lowLevelOptimise(Code{lowLevelOptimise, ...}) = lowLevelOptimise (* EBP/RBP points to a structure that interfaces to the RTS. These are offsets into that structure. *) val memRegLocalMPointer = 0 (* Not used in 64-bit *) and memRegHandlerRegister = Word.toInt nativeWordSize and memRegLocalMbottom = 2 * Word.toInt nativeWordSize and memRegStackLimit = 3 * Word.toInt nativeWordSize and memRegExceptionPacket = 4 * Word.toInt nativeWordSize and memRegCStackPtr = 6 * Word.toInt nativeWordSize and memRegThreadSelf = 7 * Word.toInt nativeWordSize and memRegStackPtr = 8 * Word.toInt nativeWordSize and memRegHeapOverflowCall = 10 * Word.toInt nativeWordSize and memRegStackOverflowCall = 11 * Word.toInt nativeWordSize and memRegStackOverflowCallEx = 12 * Word.toInt nativeWordSize - - (* This can probably be much smaller now. *) - and memRegSize = if hostIsX64 then 144 else 56 (* Size of area on the stack. *) (* create and initialise a code segment *) fun codeCreate (name : string, profObj, parameters) : code = let val printStream = PRETTY.getSimplePrinter(parameters, []) in Code { procName = name, printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, printStream = printStream, lowLevelOptimise = DEBUG.getParameter DEBUG.lowlevelOptimiseTag parameters, profileObject = profObj } end (* Put 1 unsigned byte at a given offset in the segment. *) fun set8u (b, addr, seg) = byteVecSet (seg, addr, b) (* Put 4 bytes at a given offset in the segment. *) (* b0 is the least significant byte. *) fun set4Bytes (b3, b2, b1, b0, addr, seg) = let val a = addr; in (* Little-endian *) byteVecSet (seg, a, b0); byteVecSet (seg, a + 0w1, b1); byteVecSet (seg, a + 0w2, b2); byteVecSet (seg, a + 0w3, b3) end; (* Put 1 unsigned word at a given offset in the segment. *) fun set32u (ival: LargeWord.word, addr, seg) : unit = let val b3 = Word8.fromLargeWord (ival >>+ 0w24) val b2 = Word8.fromLargeWord (ival >>+ 0w16) val b1 = Word8.fromLargeWord (ival >>+ 0w8) val b0 = Word8.fromLargeWord ival in set4Bytes (b3, b2, b1, b0, addr, seg) end (* Put 1 signed word at a given offset in the segment. *) fun set32s (ival: LargeInt.int, addr, seg) = set32u(LargeWord.fromLargeInt ival, addr, seg) fun byteSigned ival = if ~0x80 <= ival andalso ival < 0x80 then Word8.fromInt ival else raise InternalError "byteSigned: invalid byte" (* Convert a large-word value to a little-endian byte sequence. *) fun largeWordToBytes(_, 0) = [] | largeWordToBytes(ival: LargeWord.word, n) = Word8.fromLargeWord ival :: largeWordToBytes(ival >>+ 0w8, n-1) fun word32Unsigned(ival: LargeWord.word) = largeWordToBytes(ival, 4) fun int32Signed(ival: LargeInt.int) = if is32bit ival then word32Unsigned(LargeWord.fromLargeInt ival) else raise InternalError "int32Signed: invalid word" (* Registers. *) datatype genReg = GeneralReg of Word8.word * bool and fpReg = FloatingPtReg of Word8.word and xmmReg = SSE2Reg of Word8.word datatype reg = GenReg of genReg | FPReg of fpReg | XMMReg of xmmReg (* These are the real registers we have. The AMD extension encodes the additional registers through the REX prefix. *) val eax = GeneralReg (0w0, false) val ecx = GeneralReg (0w1, false) val edx = GeneralReg (0w2, false) val ebx = GeneralReg (0w3, false) val esp = GeneralReg (0w4, false) val ebp = GeneralReg (0w5, false) val esi = GeneralReg (0w6, false) val edi = GeneralReg (0w7, false) val r8 = GeneralReg (0w0, true) val r9 = GeneralReg (0w1, true) val r10 = GeneralReg (0w2, true) val r11 = GeneralReg (0w3, true) val r12 = GeneralReg (0w4, true) val r13 = GeneralReg (0w5, true) val r14 = GeneralReg (0w6, true) val r15 = GeneralReg (0w7, true) (* Floating point "registers". Actually entries on the floating point stack. The X86 has a floating point stack with eight entries. *) val fp0 = FloatingPtReg 0w0 and fp1 = FloatingPtReg 0w1 and fp2 = FloatingPtReg 0w2 and fp3 = FloatingPtReg 0w3 and fp4 = FloatingPtReg 0w4 and fp5 = FloatingPtReg 0w5 and fp6 = FloatingPtReg 0w6 and fp7 = FloatingPtReg 0w7 (* SSE2 Registers. These are used for floating point in 64-bity mode. We only use XMM0-6 because the others are callee save and we don't currently save them. *) val xmm0 = SSE2Reg 0w0 and xmm1 = SSE2Reg 0w1 and xmm2 = SSE2Reg 0w2 and xmm3 = SSE2Reg 0w3 and xmm4 = SSE2Reg 0w4 and xmm5 = SSE2Reg 0w5 and xmm6 = SSE2Reg 0w6 - val regClosure = edx (* Addr. of closure for fn. call goes here. *) - fun getReg (GeneralReg r) = r fun mkReg n = GeneralReg n (* reg.up *) (* The maximum size of the register vectors and masks. Although the X86/32 has a floating point stack with eight entries it's much simpler to treat it as having seven "real" registers. Items are pushed to the stack and then stored and popped into the current location. It may be possible to improve the code by some peephole optimisation. *) val regs = 30 (* Include the X86/64 registers even if this is 32-bit. *) (* The nth register (counting from 0). *) (* Profiling shows that applying the constructors here creates a lot of garbage. Create the entries once and then use vector indexing instead. *) local fun regN i = if i < 8 then GenReg(GeneralReg(Word8.fromInt i, false)) else if i < 16 then GenReg(GeneralReg(Word8.fromInt(i-8), true)) else if i < 23 then FPReg(FloatingPtReg(Word8.fromInt(i-16))) else XMMReg(SSE2Reg(Word8.fromInt(i-23))) val regVec = Vector.tabulate(regs, regN) in fun regN i = Vector.sub(regVec, i) handle Subscript => raise InternalError "Bad register number" end (* The number of the register. *) fun nReg(GenReg(GeneralReg(r, false))) = Word8.toInt r | nReg(GenReg(GeneralReg(r, true))) = Word8.toInt r + 8 | nReg(FPReg(FloatingPtReg r)) = Word8.toInt r + 16 | nReg(XMMReg(SSE2Reg r)) = Word8.toInt r + 23 datatype opsize = SZByte | SZWord | SZDWord | SZQWord (* Default size when printing regs. *) val sz32_64 = if hostIsX64 then SZQWord else SZDWord fun genRegRepr(GeneralReg (0w0, false), SZByte) = "al" | genRegRepr(GeneralReg (0w1, false), SZByte) = "cl" | genRegRepr(GeneralReg (0w2, false), SZByte) = "dl" | genRegRepr(GeneralReg (0w3, false), SZByte) = "bl" | genRegRepr(GeneralReg (0w4, false), SZByte) = "ah" | genRegRepr(GeneralReg (0w5, false), SZByte) = "ch" | genRegRepr(GeneralReg (0w6, false), SZByte) = "sil" (* Assume there's a Rex code that forces low-order reg *) | genRegRepr(GeneralReg (0w7, false), SZByte) = "dil" | genRegRepr(GeneralReg (reg, true), SZByte) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "b" | genRegRepr(GeneralReg (0w0, false), SZDWord) = "eax" | genRegRepr(GeneralReg (0w1, false), SZDWord) = "ecx" | genRegRepr(GeneralReg (0w2, false), SZDWord) = "edx" | genRegRepr(GeneralReg (0w3, false), SZDWord) = "ebx" | genRegRepr(GeneralReg (0w4, false), SZDWord) = "esp" | genRegRepr(GeneralReg (0w5, false), SZDWord) = "ebp" | genRegRepr(GeneralReg (0w6, false), SZDWord) = "esi" | genRegRepr(GeneralReg (0w7, false), SZDWord) = "edi" | genRegRepr(GeneralReg (reg, true), SZDWord) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "d" | genRegRepr(GeneralReg (0w0, false), SZQWord) = "rax" | genRegRepr(GeneralReg (0w1, false), SZQWord) = "rcx" | genRegRepr(GeneralReg (0w2, false), SZQWord) = "rdx" | genRegRepr(GeneralReg (0w3, false), SZQWord) = "rbx" | genRegRepr(GeneralReg (0w4, false), SZQWord) = "rsp" | genRegRepr(GeneralReg (0w5, false), SZQWord) = "rbp" | genRegRepr(GeneralReg (0w6, false), SZQWord) = "rsi" | genRegRepr(GeneralReg (0w7, false), SZQWord) = "rdi" | genRegRepr(GeneralReg (reg, true), SZQWord) = "r" ^ Int.toString(Word8.toInt reg +8) | genRegRepr(GeneralReg (0w0, false), SZWord) = "ax" | genRegRepr(GeneralReg (0w1, false), SZWord) = "cx" | genRegRepr(GeneralReg (0w2, false), SZWord) = "dx" | genRegRepr(GeneralReg (0w3, false), SZWord) = "bx" | genRegRepr(GeneralReg (0w4, false), SZWord) = "sp" | genRegRepr(GeneralReg (0w5, false), SZWord) = "bp" | genRegRepr(GeneralReg (0w6, false), SZWord) = "si" | genRegRepr(GeneralReg (0w7, false), SZWord) = "di" | genRegRepr(GeneralReg (reg, true), SZWord) = "r" ^ Int.toString(Word8.toInt reg +8) ^ "w" | genRegRepr _ = "unknown" (* Suppress warning because word values are not exhaustive. *) and fpRegRepr(FloatingPtReg n) = "fp" ^ Word8.toString n and xmmRegRepr(SSE2Reg n) = "xmm" ^ Word8.toString n fun regRepr(GenReg r) = genRegRepr (r, sz32_64) | regRepr(FPReg r) = fpRegRepr r | regRepr(XMMReg r) = xmmRegRepr r (* Install a pretty printer. This is simply for when this code is being run under the debugger. N.B. We need PolyML.PrettyString here. *) val () = PolyML.addPrettyPrinter(fn _ => fn _ => fn r => PolyML.PrettyString(regRepr r)) datatype argType = ArgGeneral | ArgFP (* Size of operand. OpSize64 is only valid in 64-bit mode. *) datatype opSize = OpSize32 | OpSize64 structure RegSet = struct (* Implement a register set as a bit mask. *) datatype regSet = RegSet of word fun singleton r = RegSet(0w1 << Word.fromInt(nReg r)) fun regSetUnion(RegSet r1, RegSet r2) = RegSet(Word.orb(r1, r2)) fun regSetIntersect(RegSet r1, RegSet r2) = RegSet(Word.andb(r1, r2)) local fun addReg(acc, n) = if n = regs then acc else addReg(regSetUnion(acc, singleton(regN n)), n+1) in val allRegisters = addReg(RegSet 0w0, 0) end val noRegisters = RegSet 0w0 fun inSet(r, rs) = regSetIntersect(singleton r, rs) <> noRegisters fun regSetMinus(RegSet s1, RegSet s2) = RegSet(Word.andb(s1, Word.notb s2)) val listToSet = List.foldl (fn(r, rs) => regSetUnion(singleton r, rs)) noRegisters local val regs = case targetArch of Native32Bit => [eax, ecx, edx, ebx, esi, edi] | Native64Bit => [eax, ecx, edx, ebx, esi, edi, r8, r9, r10, r11, r12, r13, r14] | ObjectId32Bit => [eax, ecx, edx, esi, edi, r8, r9, r10, r11, r12, r13, r14] in val generalRegisters = listToSet(map GenReg regs) end (* The floating point stack. Note that this excludes one item so it is always possible to load a value onto the top of the FP stack. *) val floatingPtRegisters = listToSet(map FPReg [fp0, fp1, fp2, fp3, fp4, fp5, fp6(*, fp7*)]) val sse2Registers = listToSet(map XMMReg [xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6]) fun isAllRegs rs = rs = allRegisters fun setToList (RegSet regSet)= let fun testBit (n, bit, res) = if n = regs then res else testBit(n+1, bit << 0w1, if (regSet andb bit) <> 0w0 then regN n :: res else res) in testBit(0, 0w1, []) end val cardinality = List.length o setToList (* Choose one of the set. This chooses the least value which means that the ordering of the registers is significant. This is a hot-spot so is coded directly with the word operations. *) fun oneOf(RegSet regSet) = let fun find(n, bit) = if n = Word.fromInt regs then raise InternalError "oneOf: empty" else if Word.andb(bit, regSet) <> 0w0 then n else find(n+0w1, Word.<<(bit, 0w1)) in regN(Word.toInt(find(0w0, 0w1))) end fun regSetRepr regSet = let val regs = setToList regSet in "[" ^ String.concatWith "," (List.map regRepr regs) ^ "]" end (* Install a pretty printer for when this code is being debugged. *) val () = PolyML.addPrettyPrinter(fn _ => fn _ => fn r => PolyML.PrettyString(regSetRepr r)) end open RegSet datatype arithOp = ADD | OR (*|ADC | SBB*) | AND | SUB | XOR | CMP fun arithOpToWord ADD = 0w0: Word8.word | arithOpToWord OR = 0w1 | arithOpToWord AND = 0w4 | arithOpToWord SUB = 0w5 | arithOpToWord XOR = 0w6 | arithOpToWord CMP = 0w7 fun arithOpRepr ADD = "Add" | arithOpRepr OR = "Or" | arithOpRepr AND = "And" | arithOpRepr SUB = "Sub" | arithOpRepr XOR = "Xor" | arithOpRepr CMP = "Cmp" datatype shiftType = SHL | SHR | SAR fun shiftTypeToWord SHL = 0w4: Word8.word | shiftTypeToWord SHR = 0w5 | shiftTypeToWord SAR = 0w7 fun shiftTypeRepr SHL = "Shift Left Logical" | shiftTypeRepr SHR = "Shift Right Logical" | shiftTypeRepr SAR = "Shift Right Arithemetic" datatype repOps = CMPS8 | MOVS8 | MOVS32 | STOS8 | STOS32 | MOVS64 | STOS64 fun repOpsToWord CMPS8 = 0wxa6: Word8.word | repOpsToWord MOVS8 = 0wxa4 | repOpsToWord MOVS32 = 0wxa5 | repOpsToWord MOVS64 = 0wxa5 (* Plus Rex.w *) | repOpsToWord STOS8 = 0wxaa | repOpsToWord STOS32 = 0wxab | repOpsToWord STOS64 = 0wxab (* Plus Rex.w *) fun repOpsRepr CMPS8 = "CompareBytes" | repOpsRepr MOVS8 = "MoveBytes" | repOpsRepr MOVS32 = "MoveWords32" | repOpsRepr MOVS64 = "MoveWords64" | repOpsRepr STOS8 = "StoreBytes" | repOpsRepr STOS32 = "StoreWords32" | repOpsRepr STOS64 = "StoreWords64" datatype fpOps = FADD | FMUL | FCOM | FCOMP | FSUB | FSUBR | FDIV | FDIVR fun fpOpToWord FADD = 0w0: Word8.word | fpOpToWord FMUL = 0w1 | fpOpToWord FCOM = 0w2 | fpOpToWord FCOMP = 0w3 | fpOpToWord FSUB = 0w4 | fpOpToWord FSUBR = 0w5 | fpOpToWord FDIV = 0w6 | fpOpToWord FDIVR = 0w7 fun fpOpRepr FADD = "FPAdd" | fpOpRepr FMUL = "FPMultiply" | fpOpRepr FCOM = "FPCompare" | fpOpRepr FCOMP = "FPCompareAndPop" | fpOpRepr FSUB = "FPSubtract" | fpOpRepr FSUBR = "FPReverseSubtract" | fpOpRepr FDIV = "FPDivide" | fpOpRepr FDIVR = "FPReverseDivide" datatype fpUnaryOps = FCHS | FABS | FLD1 | FLDZ fun fpUnaryToWords FCHS = {rm=0w0:Word8.word, nnn=0w4: Word8.word} | fpUnaryToWords FABS = {rm=0w1, nnn=0w4} | fpUnaryToWords FLD1 = {rm=0w0, nnn=0w5} | fpUnaryToWords FLDZ = {rm=0w6, nnn=0w5} fun fpUnaryRepr FCHS = "FPChangeSign" | fpUnaryRepr FABS = "FPAbs" | fpUnaryRepr FLD1 = "FPLoadOne" | fpUnaryRepr FLDZ = "FPLoadZero" datatype branchOps = JO | JNO | JE | JNE | JL | JGE | JLE | JG | JB | JNB | JNA | JA | JP | JNP fun branchOpToWord JO = 0wx0: Word8.word | branchOpToWord JNO = 0wx1 | branchOpToWord JB = 0wx2 | branchOpToWord JNB = 0wx3 | branchOpToWord JE = 0wx4 | branchOpToWord JNE = 0wx5 | branchOpToWord JNA = 0wx6 | branchOpToWord JA = 0wx7 | branchOpToWord JP = 0wxa | branchOpToWord JNP = 0wxb | branchOpToWord JL = 0wxc | branchOpToWord JGE = 0wxd | branchOpToWord JLE = 0wxe | branchOpToWord JG = 0wxf fun branchOpRepr JO = "Overflow" | branchOpRepr JNO = "NotOverflow" | branchOpRepr JE = "Equal" | branchOpRepr JNE = "NotEqual" | branchOpRepr JL = "Less" | branchOpRepr JGE = "GreaterOrEqual" | branchOpRepr JLE = "LessOrEqual" | branchOpRepr JG = "Greater" | branchOpRepr JB = "Before" | branchOpRepr JNB= "NotBefore" | branchOpRepr JNA = "NotAfter" | branchOpRepr JA = "After" | branchOpRepr JP = "Parity" | branchOpRepr JNP = "NoParity" (* Invert a test. This is used if we want to change the sense of a test from jumping if the condition is true to jumping if it is false. *) fun invertTest JE = JNE | invertTest JNE = JE | invertTest JA = JNA | invertTest JB = JNB | invertTest JNA = JA | invertTest JNB = JB | invertTest JL = JGE | invertTest JG = JLE | invertTest JLE = JG | invertTest JGE = JL | invertTest JO = JNO | invertTest JNO = JO | invertTest JP = JNP | invertTest JNP = JP datatype sse2Operations = SSE2MoveDouble | SSE2MoveFloat | SSE2CompDouble | SSE2AddDouble | SSE2SubDouble | SSE2MulDouble | SSE2DivDouble | SSE2Xor | SSE2And | SSE2FloatToDouble | SSE2DoubleToFloat | SSE2CompSingle | SSE2AddSingle | SSE2SubSingle | SSE2MulSingle | SSE2DivSingle fun sse2OpRepr SSE2MoveDouble = "SSE2MoveDouble" | sse2OpRepr SSE2MoveFloat = "SSE2MoveFloat" | sse2OpRepr SSE2CompDouble = "SSE2CompDouble" | sse2OpRepr SSE2AddDouble = "SSE2AddDouble" | sse2OpRepr SSE2SubDouble = "SSE2SubDouble" | sse2OpRepr SSE2MulDouble = "SSE2MulDouble" | sse2OpRepr SSE2DivDouble = "SSE2DivDouble" | sse2OpRepr SSE2Xor = "SSE2Xor" | sse2OpRepr SSE2And = "SSE2And" | sse2OpRepr SSE2CompSingle = "SSE2CompSingle" | sse2OpRepr SSE2AddSingle = "SSE2AddSingle" | sse2OpRepr SSE2SubSingle = "SSE2SubSingle" | sse2OpRepr SSE2MulSingle = "SSE2MulSingle" | sse2OpRepr SSE2DivSingle = "SSE2DivSingle" | sse2OpRepr SSE2FloatToDouble = "SSE2FloatToDouble" | sse2OpRepr SSE2DoubleToFloat = "SSE2DoubleToFloat" (* Primary opCodes. N.B. only opCodes actually used are listed here. If new instruction are added check they will be handled by the run-time system in the event of trap. *) datatype opCode = Group1_8_A32 | Group1_8_A64 | Group1_32_A32 | Group1_32_A64 | Group1_8_a | JMP_8 | JMP_32 | CALL_32 | MOVL_A_R32 | MOVL_A_R64 | MOVL_R_A32 | MOVL_R_A64 | MOVL_R_A16 | MOVB_R_A32 | MOVB_R_A64 of {forceRex: bool} | PUSH_R of Word8.word | POP_R of Word8.word | Group5 | NOP | LEAL32 | LEAL64 | MOVL_32_R of Word8.word | MOVL_64_R of Word8.word | MOVL_32_A32 | MOVL_32_A64 | MOVB_8_A | POP_A | RET | RET_16 | CondJump of branchOps | CondJump32 of branchOps | SetCC of branchOps | Arith32 of arithOp * Word8.word | Arith64 of arithOp * Word8.word | Group3_A32 | Group3_A64 | Group3_a | Group2_8_A32 | Group2_8_A64 | Group2_CL_A32 | Group2_CL_A64 | Group2_1_A32 | Group2_1_A64 | PUSH_8 | PUSH_32 | TEST_ACC8 | LOCK_XADD32 | LOCK_XADD64 | FPESC of Word8.word | XCHNG32 | XCHNG64 | REP (* Rep prefix *) | MOVZB32 (* Needs escape code. *) | MOVZW32 (* Needs escape code. *) | IMUL32 (* Needs escape code. *) | IMUL64 (* Needs escape code. *) | SSE2StoreSingle (* movss with memory destination - needs escape sequence. *) | SSE2StoreDouble (* movsd with memory destination - needs escape sequence. *) | CQO_CDQ32 (* Sign extend before divide.. *) | CQO_CDQ64 (* Sign extend before divide.. *) | SSE2Ops of sse2Operations (* SSE2 instructions. *) | CVTSI2SD32 | CVTSI2SD64 | HLT (* End of code marker. *) | IMUL_C8_32 | IMUL_C8_64 | IMUL_C32_32 | IMUL_C32_64 | MOVDFromXMM (* move 32 bit value from XMM to general reg. *) | MOVQToXMM (* move 64 bit value from general reg.to XMM *) | PSRLDQ (* Shift XMM register *) | LDSTMXCSR | CVTSD2SI32 (* Double to 32-bit int *) | CVTSD2SI64 (* Double to 64-bit int *) | CVTSS2SI32 (* Single to 32-bit int *) | CVTSS2SI64 (* Single to 64-bit int *) | CVTTSD2SI32 (* Double to 32-bit int - truncate towards zero *) | CVTTSD2SI64 (* Double to 64-bit int - truncate towards zero *) | CVTTSS2SI32 (* Single to 32-bit int - truncate towards zero *) | CVTTSS2SI64 (* Single to 64-bit int - truncate towards zero *) | MOVSXD | CMOV32 of branchOps | CMOV64 of branchOps fun opToInt Group1_8_A32 = 0wx83 | opToInt Group1_8_A64 = 0wx83 | opToInt Group1_32_A32 = 0wx81 | opToInt Group1_32_A64 = 0wx81 | opToInt Group1_8_a = 0wx80 | opToInt JMP_8 = 0wxeb | opToInt JMP_32 = 0wxe9 | opToInt CALL_32 = 0wxe8 | opToInt MOVL_A_R32 = 0wx8b | opToInt MOVL_A_R64 = 0wx8b | opToInt MOVL_R_A32 = 0wx89 | opToInt MOVL_R_A64 = 0wx89 | opToInt MOVL_R_A16 = 0wx89 (* Also has an OPSIZE prefix. *) | opToInt MOVB_R_A32 = 0wx88 | opToInt (MOVB_R_A64 _) = 0wx88 | opToInt (PUSH_R reg) = 0wx50 + reg | opToInt (POP_R reg) = 0wx58 + reg | opToInt Group5 = 0wxff | opToInt NOP = 0wx90 | opToInt LEAL32 = 0wx8d | opToInt LEAL64 = 0wx8d | opToInt (MOVL_32_R reg) = 0wxb8 + reg | opToInt (MOVL_64_R reg) = 0wxb8 + reg | opToInt MOVL_32_A32 = 0wxc7 | opToInt MOVL_32_A64 = 0wxc7 | opToInt MOVB_8_A = 0wxc6 | opToInt POP_A = 0wx8f | opToInt RET = 0wxc3 | opToInt RET_16 = 0wxc2 | opToInt (CondJump opc) = 0wx70 + branchOpToWord opc | opToInt (CondJump32 opc) = 0wx80 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (SetCC opc) = 0wx90 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (Arith32 (ao,dw)) = arithOpToWord ao * 0w8 + dw | opToInt (Arith64 (ao,dw)) = arithOpToWord ao * 0w8 + dw | opToInt Group3_A32 = 0wxf7 | opToInt Group3_A64 = 0wxf7 | opToInt Group3_a = 0wxf6 | opToInt Group2_8_A32 = 0wxc1 | opToInt Group2_8_A64 = 0wxc1 | opToInt Group2_1_A32 = 0wxd1 | opToInt Group2_1_A64 = 0wxd1 | opToInt Group2_CL_A32 = 0wxd3 | opToInt Group2_CL_A64 = 0wxd3 | opToInt PUSH_8 = 0wx6a | opToInt PUSH_32 = 0wx68 | opToInt TEST_ACC8 = 0wxa8 | opToInt LOCK_XADD32 = 0wxC1 (* Needs lock and escape prefixes. *) | opToInt LOCK_XADD64 = 0wxC1 (* Needs lock and escape prefixes. *) | opToInt (FPESC n) = 0wxD8 orb8 n | opToInt XCHNG32 = 0wx87 | opToInt XCHNG64 = 0wx87 | opToInt REP = 0wxf3 | opToInt MOVZB32 = 0wxb6 (* Needs escape code. *) | opToInt MOVZW32 = 0wxb7 (* Needs escape code. *) | opToInt IMUL32 = 0wxaf (* Needs escape code. *) | opToInt IMUL64 = 0wxaf (* Needs escape code. *) | opToInt SSE2StoreSingle = 0wx11 (* Needs F3 0F escape. *) | opToInt SSE2StoreDouble = 0wx11 (* Needs F2 0F escape. *) | opToInt CQO_CDQ32 = 0wx99 | opToInt CQO_CDQ64 = 0wx99 | opToInt (SSE2Ops SSE2MoveDouble) = 0wx10 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2MoveFloat) = 0wx10 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2CompDouble) = 0wx2E (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2AddDouble) = 0wx58 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2SubDouble) = 0wx5c (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2MulDouble) = 0wx59 (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2DivDouble) = 0wx5e (* Needs F2 0F escape. *) | opToInt (SSE2Ops SSE2CompSingle) = 0wx2E (* Needs 0F escape. *) | opToInt (SSE2Ops SSE2AddSingle) = 0wx58 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2SubSingle) = 0wx5c (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2MulSingle) = 0wx59 (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2DivSingle) = 0wx5e (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2And) = 0wx54 (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2Xor) = 0wx57 (* Needs 66 0F escape. *) | opToInt (SSE2Ops SSE2FloatToDouble) = 0wx5A (* Needs F3 0F escape. *) | opToInt (SSE2Ops SSE2DoubleToFloat) = 0wx5A (* Needs F2 0F escape. *) | opToInt CVTSI2SD32 = 0wx2a (* Needs F2 0F escape. *) | opToInt CVTSI2SD64 = 0wx2a (* Needs F2 0F escape. *) | opToInt HLT = 0wxf4 | opToInt IMUL_C8_32 = 0wx6b | opToInt IMUL_C8_64 = 0wx6b | opToInt IMUL_C32_32 = 0wx69 | opToInt IMUL_C32_64 = 0wx69 | opToInt MOVDFromXMM = 0wx7e (* Needs 66 0F escape. *) | opToInt MOVQToXMM = 0wx6e (* Needs 66 0F escape. *) | opToInt PSRLDQ = 0wx73 (* Needs 66 0F escape. *) | opToInt LDSTMXCSR = 0wxae (* Needs 0F prefix. *) | opToInt CVTSD2SI32 = 0wx2d (* Needs F2 0F prefix. *) | opToInt CVTSD2SI64 = 0wx2d (* Needs F2 0F prefix and rex.w. *) | opToInt CVTSS2SI32 = 0wx2d (* Needs F3 0F prefix. *) | opToInt CVTSS2SI64 = 0wx2d (* Needs F3 0F prefix and rex.w. *) | opToInt CVTTSD2SI32 = 0wx2c (* Needs F2 0F prefix. *) | opToInt CVTTSD2SI64 = 0wx2c (* Needs F2 0F prefix. *) | opToInt CVTTSS2SI32 = 0wx2c (* Needs F3 0F prefix. *) | opToInt CVTTSS2SI64 = 0wx2c (* Needs F3 0F prefix and rex.w. *) | opToInt MOVSXD = 0wx63 | opToInt (CMOV32 opc) = 0wx40 + branchOpToWord opc (* Needs 0F prefix *) | opToInt (CMOV64 opc) = 0wx40 + branchOpToWord opc (* Needs 0F prefix and rex.w *) datatype mode = Based0 (* mod = 0 *) | Based8 (* mod = 1 *) | Based32 (* mod = 2 *) | Register (* mod = 3 *) ; (* Put together the three fields which make up the mod r/m byte. *) fun modrm (md : mode, rg: Word8.word, rm : Word8.word) : Word8.word = let val _ = if rg > 0w7 then raise InternalError "modrm: bad rg" else () val _ = if rm > 0w7 then raise InternalError "modrm: bad rm" else () val modField: Word8.word = case md of Based0 => 0w0 | Based8 => 0w1 | Based32 => 0w2 | Register => 0w3 in (modField <<- 0w6) orb8 (rg <<- 0w3) orb8 rm end (* REX prefix *) fun rex {w,r,x,b} = 0wx40 orb8 (if w then 0w8 else 0w0) orb8 (if r then 0w4 else 0w0) orb8 (if x then 0w2 else 0w0) orb8 (if b then 0w1 else 0w0) (* The X86 has the option to include an index register and to scale it. *) datatype indexType = NoIndex | Index1 of genReg | Index2 of genReg | Index4 of genReg | Index8 of genReg (* Lock, Opsize and REPNE prefixes come before the REX. *) fun opcodePrefix LOCK_XADD32 = [0wxF0] (* Requires LOCK prefix. *) | opcodePrefix LOCK_XADD64 = [0wxF0] (* Requires LOCK prefix. *) | opcodePrefix MOVL_R_A16 = [0wx66] (* Requires OPSIZE prefix. *) | opcodePrefix SSE2StoreSingle = [0wxf3] | opcodePrefix SSE2StoreDouble = [0wxf2] | opcodePrefix(SSE2Ops SSE2CompDouble) = [0wx66] | opcodePrefix(SSE2Ops SSE2And) = [0wx66] | opcodePrefix(SSE2Ops SSE2Xor) = [0wx66] | opcodePrefix(SSE2Ops SSE2CompSingle) = [] (* No prefix *) | opcodePrefix(SSE2Ops SSE2MoveDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2AddDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2SubDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2MulDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2DivDouble) = [0wxf2] | opcodePrefix(SSE2Ops SSE2DoubleToFloat) = [0wxf2] | opcodePrefix(SSE2Ops SSE2MoveFloat) = [0wxf3] | opcodePrefix(SSE2Ops SSE2AddSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2SubSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2MulSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2DivSingle) = [0wxf3] | opcodePrefix(SSE2Ops SSE2FloatToDouble) = [0wxf3] | opcodePrefix CVTSI2SD32 = [0wxf2] | opcodePrefix CVTSI2SD64 = [0wxf2] | opcodePrefix MOVDFromXMM = [0wx66] | opcodePrefix MOVQToXMM = [0wx66] | opcodePrefix PSRLDQ = [0wx66] | opcodePrefix CVTSD2SI32 = [0wxf2] | opcodePrefix CVTSD2SI64 = [0wxf2] | opcodePrefix CVTSS2SI32 = [0wxf3] | opcodePrefix CVTSS2SI64 = [0wxf3] | opcodePrefix CVTTSD2SI32 = [0wxf2] | opcodePrefix CVTTSD2SI64 = [0wxf2] | opcodePrefix CVTTSS2SI32 = [0wxf3] | opcodePrefix CVTTSS2SI64 = [0wxf3] | opcodePrefix _ = [] (* A few instructions require an escape. Escapes come after the REX. *) fun escapePrefix MOVZB32 = [0wx0f] | escapePrefix MOVZW32 = [0wx0f] | escapePrefix LOCK_XADD32 = [0wx0f] | escapePrefix LOCK_XADD64 = [0wx0f] | escapePrefix IMUL32 = [0wx0f] | escapePrefix IMUL64 = [0wx0f] | escapePrefix(CondJump32 _) = [0wx0f] | escapePrefix(SetCC _) = [0wx0f] | escapePrefix SSE2StoreSingle = [0wx0f] | escapePrefix SSE2StoreDouble = [0wx0f] | escapePrefix(SSE2Ops _) = [0wx0f] | escapePrefix CVTSI2SD32 = [0wx0f] | escapePrefix CVTSI2SD64 = [0wx0f] | escapePrefix MOVDFromXMM = [0wx0f] | escapePrefix MOVQToXMM = [0wx0f] | escapePrefix PSRLDQ = [0wx0f] | escapePrefix LDSTMXCSR = [0wx0f] | escapePrefix CVTSD2SI32 = [0wx0f] | escapePrefix CVTSD2SI64 = [0wx0f] | escapePrefix CVTSS2SI32 = [0wx0f] | escapePrefix CVTSS2SI64 = [0wx0f] | escapePrefix CVTTSD2SI32 = [0wx0f] | escapePrefix CVTTSD2SI64 = [0wx0f] | escapePrefix CVTTSS2SI32 = [0wx0f] | escapePrefix CVTTSS2SI64 = [0wx0f] | escapePrefix(CMOV32 _) = [0wx0f] | escapePrefix(CMOV64 _) = [0wx0f] | escapePrefix _ = [] (* Generate an opCode byte after doing any pending operations. *) fun opCodeBytes(opb:opCode, rx) = let val rexByte = case rx of NONE => [] | SOME rxx => if hostIsX64 then [rex rxx] else raise InternalError "opCodeBytes: rex prefix in 32 bit mode"; in opcodePrefix opb @ rexByte @ escapePrefix opb @ [opToInt opb] end fun rexByte(opb, rrX, rbX, riX) = let (* We need a rex prefix if we need to set the length to 64-bit. *) val need64bit = case opb of Group1_8_A64 => true (* Arithmetic operations - must be 64-bit *) | Group1_32_A64 => true (* Arithmetic operations - must be 64-bit *) | Group2_1_A64 => true (* 1-bit shifts - must be 64-bit *) | Group2_8_A64 => true (* n-bit shifts - must be 64-bit *) | Group2_CL_A64 => true (* Shifts by value in CL *) | Group3_A64 => true (* Test, Not, Mul etc. *) | Arith64 (_, _) => true | MOVL_A_R64 => true (* Needed *) | MOVL_R_A64 => true (* Needed *) | XCHNG64 => true | LEAL64 => true (* Needed to ensure the result is 64-bits *) | MOVL_64_R _ => true (* Needed *) | MOVL_32_A64 => true (* Needed *) | IMUL64 => true (* Needed to ensure the result is 64-bits *) | LOCK_XADD64 => true (* Needed to ensure the result is 64-bits *) | CQO_CDQ64 => true (* It's only CQO if there's a Rex prefix. *) | CVTSI2SD64 => true (* This affects the size of the integer source. *) | IMUL_C8_64 => true | IMUL_C32_64 => true | MOVQToXMM => true | CVTSD2SI64 => true (* This affects the size of the integer source. *) | CVTSS2SI64 => true | CVTTSD2SI64 => true | CVTTSS2SI64 => true | MOVSXD => true | CMOV64 _ => true (* Group5 - We only use 2/4/6 and they don't need prefix *) | _ => false (* If we are using MOVB_R_A with SIL or DIL we need to force a REX prefix. That's only possible in 64-bit mode. This also applies with Test and SetCC but they are dealt with elsewhere. *) val forceRex = case opb of MOVB_R_A64 {forceRex=true} => true (* This is allowed in X86/64 but not in X86/32. *) | _ => false in if need64bit orelse rrX orelse rbX orelse riX orelse forceRex then [rex{w=need64bit, r=rrX, b=rbX, x = riX}] else [] end (* Register/register operation. *) fun opReg(opb:opCode, (*dest*)GeneralReg(rrC, rrX), (*source*)GeneralReg(rbC, rbX)) = let val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, rrX, rbX, false) val esc = escapePrefix opb (* Generate the ESCAPE code if needed. *) val opc = opToInt opb val mdrm = modrm(Register, rrC, rbC) in pref @ rex @ esc @ [opc, mdrm] end (* Operations on a register where the second "register" is actually an operation code. *) fun opRegPlus2(opb:opCode, rd: genReg, op2: Word8.word) = let val (rrC, rrX) = getReg rd val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, false, rrX, false) val opc = opToInt opb val mdrm = modrm(Register, op2, rrC) in pref @ rex @ [opc, mdrm] end local (* General instruction form with modrm and optional sib bytes. rb is an option since the base register may be omitted. This is used with LEA to tag integers. *) fun opIndexedGen (opb:opCode, offset: LargeInt.int, rb: genReg option, ri: indexType, (rrC, rrX)) = let (* Base encoding. (Based0, 0w5) means "no base" so if we need ebp as the base we have to use Based8 at least. *) val (offsetCode, rbC, rbX) = case rb of NONE => (Based0, 0w5 (* no base register *), false) | SOME rb => let val (rbC, rbX) = getReg rb val base = if offset = 0 andalso rbC <> 0wx5 (* Can't use ebp with Based0 *) then Based0 (* no disp field *) else if is8BitL offset then Based8 (* use 8-bit disp field *) else Based32 (* use 32-bit disp field *) in (base, rbC, rbX) end (* Index coding. esp can't be used as an index so (0w4, false) means "no index". But r12 (0w4, true) CAN be. *) val ((riC, riX), scaleFactor) = case ri of NoIndex => ((0w4, false), 0w0) | Index1 i => (getReg i, 0w0) | Index2 i => (getReg i, 0w1) | Index4 i => (getReg i, 0w2) | Index8 i => (getReg i, 0w3) (* If the base register is esp or r12 we have to use a sib byte even if there's no index. That's because 0w4 as a base register means "there's a SIB byte". *) val modRmAndOptionalSib = if rbC = 0w4 (* Code for esp and r12 *) orelse riC <> 0w4 orelse riX then let val mdrm = modrm(offsetCode, rrC, 0w4 (* s-i-b *)) val sibByte = (scaleFactor <<- 0w6) orb8 (riC <<- 0w3) orb8 rbC in [mdrm, sibByte] end else [modrm(offsetCode, rrC, rbC)] (* Generate the disp field (if any) *) val dispField = case (offsetCode, rb) of (Based8, _) => [Word8.fromLargeInt offset] | (Based32, _) => int32Signed offset | (_, NONE) => (* 32 bit absolute used as base *) int32Signed offset | _ => [] in opcodePrefix opb @ rexByte(opb, rrX, rbX, riX) @ escapePrefix opb @ opToInt opb :: modRmAndOptionalSib @ dispField end in fun opEA(opb, offset, rb, r) = opIndexedGen(opb, offset, SOME rb, NoIndex, getReg r) (* Generate a opcode plus a second modrm byte but where the "register" field in the modrm byte is actually a code. *) and opPlus2(opb, offset, rb, op2) = opIndexedGen(opb, offset, SOME rb, NoIndex, (op2, false)) and opIndexedPlus2(opb, offset, rb, ri, op2) = opIndexedGen(opb, offset, SOME rb, ri, (op2, false)) fun opIndexed (opb, offset, rb, ri, rd) = opIndexedGen(opb, offset, rb, ri, getReg rd) fun opAddress(opb, offset, rb, ri, rd) = opIndexedGen (opb, offset, SOME rb, ri, getReg rd) and mMXAddress(opb, offset, rb, ri, SSE2Reg rrC) = opIndexedGen(opb, offset, SOME rb, ri, (rrC, false)) and opAddressPlus2(opb, offset, rb, ri, op2) = opIndexedGen(opb, offset, SOME rb, ri, (op2, false)) end (* An operation with an operand that needs to go in the constant area, or in the case of native 32-bit, where the constant is stored in an object and the address of the object is inline. This just puts in the instruction and the address. The details of the constant are dealt with in putConst. *) fun opConstantOperand(opb, (*dest*)GeneralReg(rrC, rrX)) = let val pref = opcodePrefix opb (* Any opsize or lock prefix. *) val rex = rexByte(opb, rrX, false, false) val esc = escapePrefix opb (* Generate the ESCAPE code if needed. *) val opc = opToInt opb val mdrm = modrm(Based0, rrC, 0w5 (* PC-relative or absolute *)) in pref @ rex @ esc @ [opc, mdrm] @ int32Signed(tag 0) end fun immediateOperand (opn: arithOp, rd: genReg, imm: LargeInt.int, opSize) = if is8BitL imm then (* Can use one byte immediate *) opRegPlus2(case opSize of OpSize64 => Group1_8_A64 | OpSize32 => Group1_8_A32, rd, arithOpToWord opn) @ [Word8.fromLargeInt imm] else if is32bit imm then (* Need 32 bit immediate. *) opRegPlus2(case opSize of OpSize64 => Group1_32_A64 | OpSize32 => Group1_32_A32, rd, arithOpToWord opn) @ int32Signed imm else (* It won't fit in the immediate; put it in the non-address area. *) let val opc = case opSize of OpSize64 => Arith64 | OpSize32 => Arith32 in opConstantOperand(opc(opn, 0w3 (* r/m to reg *)), rd) end fun arithOpReg(opn: arithOp, rd: genReg, rs: genReg, opIs64) = opReg ((if opIs64 then Arith64 else Arith32) (opn, 0w3 (* r/m to reg *)), rd, rs) type handlerLab = addrs ref - datatype callKinds = - Recursive (* The function calls itself. *) - | ConstantCode of machineWord (* A function that doesn't need a closure *) - | FullCall (* Full closure call *) - | DirectReg of genReg (* Currently used within ForeignCall to call the RTS *) - fun floatingPtOp{escape, md, nnn, rm} = opCodeBytes(FPESC escape, NONE) @ [(md <<- 0w6) orb8 (nnn <<- 0w3) orb8 rm] datatype trapEntries = StackOverflowCall | StackOverflowCallEx | HeapOverflowCall (* RTS call. We need to save any registers that may contain addresses to the stack. All the registers are preserved but not seen by the GC. *) fun rtsCall(rtsEntry, regSet) = let val entry = case rtsEntry of StackOverflowCall => memRegStackOverflowCall | StackOverflowCallEx => memRegStackOverflowCallEx | HeapOverflowCall => memRegHeapOverflowCall val regSet = List.foldl(fn (r, a) => (0w1 << Word.fromInt(nReg(GenReg r))) orb a) 0w0 regSet val callInstr = opPlus2(Group5, LargeInt.fromInt entry, ebp, 0w2 (* call *)) val regSetInstr = if regSet >= 0w256 then [0wxca, (* This is actually a FAR RETURN *) wordToWord8 regSet, (* Low byte*) wordToWord8 (regSet >> 0w8) (* High byte*)] else if regSet <> 0w0 then [0wxcd, (* This is actually INT n *) wordToWord8 regSet] else [] in callInstr @ regSetInstr end (* Operations. *) type cases = word * label type memoryAddress = { base: genReg, offset: int, index: indexType } datatype 'reg regOrMemoryArg = RegisterArg of 'reg | MemoryArg of memoryAddress | NonAddressConstArg of LargeInt.int | AddressConstArg of machineWord datatype moveSize = Move64 | Move32 | Move8 | Move16 | Move32X and fpSize = SinglePrecision | DoublePrecision datatype operation = Move of { source: genReg regOrMemoryArg, destination: genReg regOrMemoryArg, moveSize: moveSize } | PushToStack of genReg regOrMemoryArg | PopR of genReg | ArithToGenReg of { opc: arithOp, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } | ArithMemConst of { opc: arithOp, address: memoryAddress, source: LargeInt.int, opSize: opSize } | ArithMemLongConst of { opc: arithOp, address: memoryAddress, source: machineWord } | ArithByteMemConst of { opc: arithOp, address: memoryAddress, source: Word8.word } | ShiftConstant of { shiftType: shiftType, output: genReg, shift: Word8.word, opSize: opSize } | ShiftVariable of { shiftType: shiftType, output: genReg, opSize: opSize } (* Shift amount is in ecx *) | ConditionalBranch of { test: branchOps, label: label } | SetCondition of { output: genReg, test: branchOps } | LoadAddress of { output: genReg, offset: int, base: genReg option, index: indexType, opSize: opSize } | TestByteBits of { arg: genReg regOrMemoryArg, bits: Word8.word } | CallRTS of {rtsEntry: trapEntries, saveRegs: genReg list } | AllocStore of { size: int, output: genReg, saveRegs: genReg list } | AllocStoreVariable of { size: genReg, output: genReg, saveRegs: genReg list } | StoreInitialised - | CallFunction of callKinds - | JumpToFunction of callKinds + | CallAddress of genReg regOrMemoryArg + | JumpAddress of genReg regOrMemoryArg | ReturnFromFunction of int | RaiseException of { workReg: genReg } | UncondBranch of label | ResetStack of { numWords: int, preserveCC: bool } | JumpLabel of label | LoadLabelAddress of { label: label, output: genReg } | RepeatOperation of repOps | DivideAccR of {arg: genReg, isSigned: bool, opSize: opSize } | DivideAccM of {base: genReg, offset: int, isSigned: bool, opSize: opSize } | AtomicXAdd of {address: memoryAddress, output: genReg, opSize: opSize } | FPLoadFromMemory of { address: memoryAddress, precision: fpSize } | FPLoadFromFPReg of { source: fpReg, lastRef: bool } | FPLoadFromConst of { constant: machineWord, precision: fpSize } | FPStoreToFPReg of { output: fpReg, andPop: bool } | FPStoreToMemory of { address: memoryAddress, precision: fpSize, andPop: bool } | FPArithR of { opc: fpOps, source: fpReg } | FPArithConst of { opc: fpOps, source: machineWord, precision: fpSize } | FPArithMemory of { opc: fpOps, base: genReg, offset: int, precision: fpSize } | FPUnary of fpUnaryOps | FPStatusToEAX | FPLoadInt of { base: genReg, offset: int, opSize: opSize } | FPFree of fpReg | MultiplyR of { source: genReg regOrMemoryArg, output: genReg, opSize: opSize } | XMMArith of { opc: sse2Operations, source: xmmReg regOrMemoryArg, output: xmmReg } | XMMStoreToMemory of { toStore: xmmReg, address: memoryAddress, precision: fpSize } | XMMConvertFromInt of { source: genReg, output: xmmReg, opSize: opSize } | SignExtendForDivide of opSize | XChng of { reg: genReg, arg: genReg regOrMemoryArg, opSize: opSize } | Negative of { output: genReg, opSize: opSize } | JumpTable of { cases: label list, jumpSize: jumpSize ref } | IndexedJumpCalc of { addrReg: genReg, indexReg: genReg, jumpSize: jumpSize ref } | MoveXMMRegToGenReg of { source: xmmReg, output: genReg } | MoveGenRegToXMMReg of { source: genReg, output: xmmReg } | XMMShiftRight of { output: xmmReg, shift: Word8.word } | FPLoadCtrlWord of memoryAddress (* Load FP control word. *) | FPStoreCtrlWord of memoryAddress (* Store FP control word. *) | XMMLoadCSR of memoryAddress (* Load combined control/status word. *) | XMMStoreCSR of memoryAddress (* Store combined control/status word. *) | FPStoreInt of memoryAddress | XMMStoreInt of { source: xmmReg regOrMemoryArg, output: genReg, precision: fpSize, isTruncate: bool } | CondMove of { test: branchOps, output: genReg, source: genReg regOrMemoryArg, opSize: opSize } and jumpSize = JumpSize2 | JumpSize8 type operations = operation list fun printOperation(operation, stream) = let fun printGReg r = stream(genRegRepr(r, sz32_64)) val printFPReg = stream o fpRegRepr and printXMMReg = stream o xmmRegRepr fun printBaseOffset(b, x, i) = ( stream(Int.toString i); stream "("; printGReg b; stream ")"; case x of NoIndex => () | Index1 x => (stream "["; printGReg x; stream "]") | Index2 x => (stream "["; printGReg x; stream "*2]") | Index4 x => (stream "["; printGReg x; stream "*4]") | Index8 x => (stream "["; printGReg x; stream "*8]") ) fun printMemAddress({ base, offset, index }) = printBaseOffset(base, index, offset) fun printRegOrMemoryArg printReg (RegisterArg r) = printReg r | printRegOrMemoryArg _ (MemoryArg{ base, offset, index }) = printBaseOffset(base, index, offset) | printRegOrMemoryArg _ (NonAddressConstArg c) = stream(LargeInt.toString c) | printRegOrMemoryArg _ (AddressConstArg c) = stream(Address.stringOfWord c) - fun printCallKind Recursive = stream "Recursive" - | printCallKind (ConstantCode w) = (stream "code="; stream(stringOfWord w)) - | printCallKind FullCall = stream "via ClosureReg" - | printCallKind (DirectReg reg) = printGReg reg - fun printOpSize OpSize32 = "32" | printOpSize OpSize64 = "64" in case operation of Move { source, destination, moveSize } => ( case moveSize of Move64 => stream "Move64 " | Move32 => stream "Move32 " | Move8 => stream "Move8 " | Move16 => stream "Move16 " | Move32X => stream "Move32X "; printRegOrMemoryArg printGReg destination; stream " <= "; printRegOrMemoryArg printGReg source ) | ArithToGenReg { opc, output, source, opSize } => (stream (arithOpRepr opc); stream "RR"; stream(printOpSize opSize); stream " "; printGReg output; stream " <= "; printRegOrMemoryArg printGReg source ) | ArithMemConst { opc, address, source, opSize } => ( stream (arithOpRepr opc); stream "MC"; stream(printOpSize opSize); stream " "; printMemAddress address; stream " "; stream(LargeInt.toString source) ) | ArithMemLongConst { opc, address, source } => ( stream (arithOpRepr opc ^ "MC "); printMemAddress address; stream " <= "; stream(Address.stringOfWord source) ) | ArithByteMemConst { opc, address, source } => ( stream (arithOpRepr opc); stream "MC8"; stream " "; printMemAddress address; stream " "; stream(Word8.toString source) ) | ShiftConstant { shiftType, output, shift, opSize } => ( stream(shiftTypeRepr shiftType); stream(printOpSize opSize); stream " "; printGReg output; stream " by "; stream(Word8.toString shift) ) | ShiftVariable { shiftType, output, opSize } => (* Shift amount is in ecx *) ( stream(shiftTypeRepr shiftType); stream(printOpSize opSize); stream " "; printGReg output; stream " by ECX" ) | ConditionalBranch { test, label=Label{labelNo, ...} } => ( stream "Jump"; stream(branchOpRepr test); stream " L"; stream(Int.toString labelNo) ) | SetCondition { output, test } => ( stream "SetCC"; stream(branchOpRepr test); stream " => "; printGReg output ) | PushToStack source => (stream "Push "; printRegOrMemoryArg printGReg source) | PopR dest => (stream "PopR "; printGReg dest) | LoadAddress{ output, offset, base, index, opSize } => ( stream "LoadAddress"; stream(printOpSize opSize); stream " "; case base of NONE => () | SOME r => (printGReg r; stream " + "); stream(Int.toString offset); case index of NoIndex => () | Index1 x => (stream " + "; printGReg x) | Index2 x => (stream " + "; printGReg x; stream "*2 ") | Index4 x => (stream " + "; printGReg x; stream "*4 ") | Index8 x => (stream " + "; printGReg x; stream "*8 "); stream " => "; printGReg output ) | TestByteBits { arg, bits } => ( stream "TestByteBits "; printRegOrMemoryArg printGReg arg; stream " 0x"; stream(Word8.toString bits) ) | CallRTS {rtsEntry, ...} => ( stream "CallRTS "; case rtsEntry of StackOverflowCall => stream "StackOverflowCall" | HeapOverflowCall => stream "HeapOverflow" | StackOverflowCallEx => stream "StackOverflowCallEx" ) | AllocStore { size, output, ... } => (stream "AllocStore "; stream(Int.toString size); stream " => "; printGReg output ) | AllocStoreVariable { output, size, ...} => (stream "AllocStoreVariable "; printGReg size; stream " => "; printGReg output ) | StoreInitialised => stream "StoreInitialised" - | CallFunction callKind => (stream "CallFunction "; printCallKind callKind) - - | JumpToFunction callKind => (stream "JumpToFunction "; printCallKind callKind) + | CallAddress source => (stream "CallAddress "; printRegOrMemoryArg printGReg source) + | JumpAddress source => (stream "JumpAddress "; printRegOrMemoryArg printGReg source) | ReturnFromFunction argsToRemove => (stream "ReturnFromFunction "; stream(Int.toString argsToRemove)) | RaiseException { workReg } => (stream "RaiseException "; printGReg workReg) | UncondBranch(Label{labelNo, ...})=> (stream "UncondBranch L"; stream(Int.toString labelNo)) | ResetStack{numWords, preserveCC} => (stream "ResetStack "; stream(Int.toString numWords); if preserveCC then stream " preserve CC" else ()) | JumpLabel(Label{labelNo, ...}) => (stream "L"; stream(Int.toString labelNo); stream ":") | LoadLabelAddress{ label=Label{labelNo, ...}, output } => (stream "LoadLabelAddress L"; stream(Int.toString labelNo); stream "=>"; printGReg output) | RepeatOperation repOp => (stream "Repeat "; stream(repOpsRepr repOp)) | DivideAccR{arg, isSigned, opSize} => ( stream(if isSigned then "DivideSigned" else "DivideUnsigned"); stream(printOpSize opSize); stream " "; printGReg arg) | DivideAccM{base, offset, isSigned, opSize} => ( stream(if isSigned then "DivideSigned" else "DivideUnsigned"); stream(printOpSize opSize); stream " "; printBaseOffset(base, NoIndex, offset)) | AtomicXAdd{address, output, opSize} => (stream "LockedXAdd"; stream(printOpSize opSize); printMemAddress address; stream " <=> "; printGReg output) | FPLoadFromMemory{address, precision=DoublePrecision} => (stream "FPLoadDouble "; printMemAddress address) | FPLoadFromMemory{address, precision=SinglePrecision} => (stream "FPLoadSingle "; printMemAddress address) | FPLoadFromFPReg {source, lastRef} => (stream "FPLoad "; printFPReg source; if lastRef then stream " (LAST)" else()) | FPLoadFromConst{constant, precision} => ( case precision of DoublePrecision => stream "FPLoadD " | SinglePrecision => stream "FPLoadS"; stream(Address.stringOfWord constant) ) | FPStoreToFPReg{ output, andPop } => (if andPop then stream "FPStoreAndPop => " else stream "FPStore => "; printFPReg output) | FPStoreToMemory{ address, precision=DoublePrecision, andPop: bool } => ( if andPop then stream "FPStoreDoubleAndPop => " else stream "FPStoreDouble => "; printMemAddress address ) | FPStoreToMemory{ address, precision=SinglePrecision, andPop: bool } => ( if andPop then stream "FPStoreSingleAndPop => " else stream "FPStoreSingle => "; printMemAddress address ) | FPArithR{ opc, source } => (stream(fpOpRepr opc); stream " "; printFPReg source) | FPArithConst{ opc, source, precision } => (stream(fpOpRepr opc); case precision of DoublePrecision => stream "D " | SinglePrecision => stream "S "; stream(Address.stringOfWord source)) | FPArithMemory{ opc, base, offset, precision } => (stream(fpOpRepr opc); case precision of DoublePrecision => stream "D " | SinglePrecision => stream "S "; printBaseOffset(base, NoIndex, offset)) | FPUnary opc => stream(fpUnaryRepr opc) | FPStatusToEAX => (stream "FPStatus "; printGReg eax) | FPLoadInt { base, offset, opSize} => (stream "FPLoadInt"; stream(printOpSize opSize); stream " "; printBaseOffset(base, NoIndex, offset)) | FPFree reg => (stream "FPFree "; printFPReg reg) | MultiplyR {source, output, opSize } => (stream "MultiplyR"; stream(printOpSize opSize); stream " "; printRegOrMemoryArg printGReg source; stream " *=>"; printGReg output) | XMMArith { opc, source, output } => ( stream (sse2OpRepr opc ^ "RM "); printXMMReg output; stream " <= "; printRegOrMemoryArg printXMMReg source ) | XMMStoreToMemory { toStore, address, precision=DoublePrecision } => ( stream "MoveDouble "; printXMMReg toStore; stream " => "; printMemAddress address ) | XMMStoreToMemory { toStore, address, precision=SinglePrecision } => ( stream "MoveSingle "; printXMMReg toStore; stream " => "; printMemAddress address ) | XMMConvertFromInt { source, output, opSize } => ( stream "ConvertFromInt "; stream(printOpSize opSize); stream " "; printGReg source; stream " => "; printXMMReg output ) | SignExtendForDivide opSize => ( stream "SignExtendForDivide"; stream(printOpSize opSize) ) | XChng { reg, arg, opSize } => (stream "XChng"; stream(printOpSize opSize); stream " "; printGReg reg; stream " <=> "; printRegOrMemoryArg printGReg arg) | Negative { output, opSize } => (stream "Negative"; stream(printOpSize opSize); stream " "; printGReg output) | JumpTable{cases, ...} => List.app(fn(Label{labelNo, ...}) => (stream "UncondBranch L"; stream(Int.toString labelNo); stream "\n")) cases | IndexedJumpCalc { addrReg, indexReg, jumpSize=ref jumpSize } => ( stream "IndexedJumpCalc "; printGReg addrReg; stream " += "; printGReg indexReg; print (case jumpSize of JumpSize2 => " * 2" | JumpSize8 => " * 8 ") ) | MoveXMMRegToGenReg { source, output } => ( stream "MoveXMMRegToGenReg "; printXMMReg source; stream " => "; printGReg output ) | MoveGenRegToXMMReg { source, output } => ( stream "MoveGenRegToXMMReg "; printGReg source; stream " => "; printXMMReg output ) | XMMShiftRight { output, shift } => ( stream "XMMShiftRight "; printXMMReg output; stream " by "; stream(Word8.toString shift) ) | FPLoadCtrlWord address => ( stream "FPLoadCtrlWord "; stream " => "; printMemAddress address ) | FPStoreCtrlWord address => ( stream "FPStoreCtrlWord "; stream " <= "; printMemAddress address ) | XMMLoadCSR address => ( stream "XMMLoadCSR "; stream " => "; printMemAddress address ) | XMMStoreCSR address => ( stream "XMMStoreCSR "; stream " <= "; printMemAddress address ) | FPStoreInt address => ( stream "FPStoreInt "; stream " <= "; printMemAddress address ) | XMMStoreInt{ source, output, precision, isTruncate } => ( stream "XMMStoreInt"; case precision of SinglePrecision => stream "Single" | DoublePrecision => stream "Double"; if isTruncate then stream "Truncate " else stream " "; printGReg output; stream " <= "; printRegOrMemoryArg printXMMReg source ) | CondMove { test, output, source, opSize } => ( stream "CondMove"; stream(branchOpRepr test); stream(printOpSize opSize); printGReg output; stream " <= "; printRegOrMemoryArg printGReg source ) ; stream "\n" end datatype implement = ImplementGeneral | ImplementLiteral of machineWord fun printLowLevelCode(ops, Code{printAssemblyCode, printStream, procName, ...}) = if printAssemblyCode then ( if procName = "" (* No name *) then printStream "?" else printStream procName; printStream ":\n"; List.app(fn i => printOperation(i, printStream)) ops; printStream "\n" ) else () (* val opLen = if isX64 then OpSize64 else OpSize32 *) (* Code generate a list of operations. The list is in reverse order i.e. last instruction first. *) fun codeGenerate ops = let fun cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move64 }) = (* Move from one general register to another. N.B. Because we're using the "store" version of the Move the source and output are reversed. *) opReg(MOVL_R_A64, source, output) | cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move32 }) = opReg(MOVL_R_A32, source, output) | cgOp(Move{ source=NonAddressConstArg source, destination=RegisterArg output, moveSize=Move64}) = if targetArch <> Native32Bit then ( (* N.B. There is related code in getConstant that deals with PC-relative values and also checks the range of constants that need to be in the constant area. *) if source >= 0 andalso source < 0x100000000 then (* Unsigned 32 bits. We can use a 32-bit instruction to set the value because it will zero extend to 64-bits. This may also allow us to save a rex byte. *) let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ word32Unsigned(LargeWord.fromLargeInt source) end else if source >= ~0x80000000 andalso source < 0 then (* Signed 32-bits. *) (* This is not scanned in 64-bit mode because 32-bit values aren't big enough to contain addresses. *) opRegPlus2(MOVL_32_A64, output, 0w0) @ int32Signed source else (* Too big for 32-bits; put it in the non-word area. *) opConstantOperand(MOVL_A_R64, output) ) else (* 32-bit mode. *) ( (* The RTS scans for possible addresses in MOV instructions so we can only use MOV if this is a tagged value. If it isn't we have to use something else such as XOR/ADD. In particular this is used before LOCK XADD for atomic inc/dec. We expect Move to preserve the CC so shouldn't use anything that affects it. There was a previous comment that said that using LEA wasn't a good idea. Perhaps because it takes 6 bytes. *) if source mod 2 = 0 then opIndexed(LEAL32, source, NONE, NoIndex, output) else let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ int32Signed source end ) | cgOp(Move{ source=NonAddressConstArg source, destination=RegisterArg output, moveSize=Move32}) = if targetArch <> Native32Bit then ( (* N.B. There is related code in getConstant that deals with PC-relative values and also checks the range of constants that need to be in the constant area. *) if source >= 0 andalso source < 0x100000000 then (* Unsigned 32 bits. We can use a 32-bit instruction to set the value because it will zero extend to 64-bits. This may also allow us to save a rex byte. *) let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ word32Unsigned(LargeWord.fromLargeInt source) end else if source >= ~0x80000000 andalso source < 0 then (* Signed 32-bits. *) (* This is not scanned in 64-bit mode because 32-bit values aren't big enough to contain addresses. *) opRegPlus2(MOVL_32_A64, output, 0w0) @ int32Signed source else (* Too big for 32-bits; put it in the non-word area. *) opConstantOperand(MOVL_A_R64, output) ) else (* 32-bit mode. *) ( (* The RTS scans for possible addresses in MOV instructions so we can only use MOV if this is a tagged value. If it isn't we have to use something else such as XOR/ADD. In particular this is used before LOCK XADD for atomic inc/dec. We expect Move to preserve the CC so shouldn't use anything that affects it. There was a previous comment that said that using LEA wasn't a good idea. Perhaps because it takes 6 bytes. *) if source mod 2 = 0 then opIndexed(LEAL32, source, NONE, NoIndex, output) else let val (rc, rx) = getReg output val opb = opCodeBytes(MOVL_32_R rc, if rx then SOME{w=false, r=false, b=rx, x=false} else NONE) in opb @ int32Signed source end ) | cgOp(Move{ source=AddressConstArg _, destination=RegisterArg output, moveSize=Move64 }) = ( (* The constant area is currently PolyWords. That means we MUST use a 32-bit load in 32-in-64. *) targetArch = Native64Bit orelse raise InternalError "Move64 in 32-bit"; (* Put address constants in the constant area. *) opConstantOperand(MOVL_A_R64, output) ) | cgOp(Move{ source=AddressConstArg _, destination=RegisterArg output, moveSize=Move32 }) = ( case targetArch of Native64Bit => raise InternalError "Move32 - AddressConstArg" | ObjectId32Bit => (* Put address constants in the constant area. *) (* The constant area is currently PolyWords. That means we MUST use a 32-bit load in 32-in-64. *) opConstantOperand(MOVL_A_R32, output) | Native32Bit => (* Immediate constant *) let val (rc, _) = getReg output in opCodeBytes(MOVL_32_R rc, NONE) @ int32Signed(tag 0) end ) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move32 }) = opAddress(MOVL_A_R32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move64 }) = opAddress(MOVL_A_R64, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=MemoryArg{base, offset, index}, destination=RegisterArg output, moveSize=Move8 }) = (* We don't need a REX.W bit here because the top 32-bits of a 64-bit register will always be zeroed. *) opAddress(MOVZB32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{source=RegisterArg source, destination=RegisterArg output, moveSize=Move8 }) = let (* Zero extend an 8-bit value in a register to 32/64 bits. *) val (rrC, rrX) = getReg output val (rbC, rbX) = getReg source (* We don't need a REX.W bit here because the top 32-bits of a 64-bit register will always be zeroed but we may need a REX byte if we're using esi or edi. *) val rexByte = if rrC < 0w4 andalso not rrX andalso not rbX then NONE else if hostIsX64 then SOME {w=false, r=rrX, b=rbX, x=false} else raise InternalError "Move8 with esi/edi" in opCodeBytes(MOVZB32, rexByte) @ [modrm(Register, rrC, rbC)] end | cgOp(Move{moveSize=Move16, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* Likewise *) opAddress(MOVZW32, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move32X, source=RegisterArg source, destination=RegisterArg output }) = (* We should have a REX.W bit here. *) opReg(MOVSXD, output, source) | cgOp(Move{moveSize=Move32X, source=MemoryArg{base, offset, index}, destination=RegisterArg output }) = (* We should have a REX.W bit here. *) opAddress(MOVSXD, LargeInt.fromInt offset, base, index, output) | cgOp(Move{moveSize=Move32X, ...}) = raise InternalError "cgOp: LoadNonWord Size32Bit" | cgOp(LoadAddress{ offset, base, index, output, opSize }) = (* This provides a mixture of addition and multiplication in a single instruction. *) opIndexed(case opSize of OpSize64 => LEAL64 | OpSize32 => LEAL32, LargeInt.fromInt offset, base, index, output) | cgOp(ArithToGenReg{ opc, output, source=RegisterArg source, opSize }) = arithOpReg (opc, output, source, opSize=OpSize64) | cgOp(ArithToGenReg{ opc, output, source=NonAddressConstArg source, opSize }) = let (* On the X86/32 we use CMP with literal sources to compare with an address and the RTS searches for them in the code. Any non-address constant must be tagged. Most will be but we might want to use this to compare with the contents of a LargeWord value. *) val _ = if hostIsX64 orelse is8BitL source orelse opc <> CMP orelse IntInf.andb(source, 1) = 1 then () else raise InternalError "CMP with constant that looks like an address" in immediateOperand(opc, output, source, opSize) end | cgOp(ArithToGenReg{ opc, output, source=AddressConstArg _, opSize }) = (* This is only used for opc=CMP to compare addresses for equality. *) if hostIsX64 then (* We use this in 32-in-64 as well as native 64-bit. *) opConstantOperand( (case opSize of OpSize64 => Arith64 | OpSize32 => Arith32) (opc, 0w3), output) else let val (rc, _) = getReg output val opb = opCodeBytes(Group1_32_A32 (* group1, 32 bit immediate *), NONE) val mdrm = modrm(Register, arithOpToWord opc, rc) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp(ArithToGenReg{ opc, output, source=MemoryArg{offset, base, index}, opSize }) = opAddress((case opSize of OpSize64 => Arith64 | OpSize32 => Arith32) (opc, 0w3), LargeInt.fromInt offset, base, index, output) | cgOp(ArithByteMemConst{ opc, address={offset, base, index}, source }) = opIndexedPlus2(Group1_8_a (* group1, 8 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ [source] | cgOp(ArithMemConst{ opc, address={offset, base, index}, source, opSize }) = if is8BitL source then (* Can use one byte immediate *) opIndexedPlus2(case opSize of OpSize64 => Group1_8_A64 | OpSize32 => Group1_8_A32 (* group1, 8 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ [Word8.fromLargeInt source] else (* Need 32 bit immediate. *) opIndexedPlus2(case opSize of OpSize64 => Group1_32_A64 | OpSize32 => Group1_32_A32(* group1, 32 bit immediate *), LargeInt.fromInt offset, base, index, arithOpToWord opc) @ int32Signed source | cgOp(ArithMemLongConst{ opc, address={offset, base, index}, ... }) = (* Currently this is always a comparison. It is only valid in 32-bit mode because the constant is only 32-bits. *) if hostIsX64 then raise InternalError "ArithMemLongConst in 64-bit mode" else let val opb = opIndexedPlus2 (Group1_32_A32, LargeInt.fromInt offset, base, index, arithOpToWord opc) in opb @ int32Signed(tag 0) end | cgOp(ShiftConstant { shiftType, output, shift, opSize }) = if shift = 0w1 then opRegPlus2(case opSize of OpSize64 => Group2_1_A64 | OpSize32 => Group2_1_A32, output, shiftTypeToWord shiftType) else opRegPlus2(case opSize of OpSize64 => Group2_8_A64 | OpSize32 => Group2_8_A32, output, shiftTypeToWord shiftType) @ [shift] | cgOp(ShiftVariable { shiftType, output, opSize }) = opRegPlus2(case opSize of OpSize64 => Group2_CL_A64 | OpSize32 => Group2_CL_A32, output, shiftTypeToWord shiftType) | cgOp(TestByteBits{arg=RegisterArg reg, bits}) = let (* Test the bottom bit and jump depending on its value. This is used for tag tests in arbitrary precision operations and also for testing for short/long values. *) val (regNum, rx) = getReg reg in if reg = eax then (* Special instruction for testing accumulator. Can use an 8-bit test. *) opCodeBytes(TEST_ACC8, NONE) @ [bits] else if hostIsX64 then let (* We can use a REX code to force it to always use the low order byte. *) val opb = opCodeBytes(Group3_a, if rx orelse regNum >= 0w4 then SOME{w=false, r=false, b=rx, x=false} else NONE) val mdrm = modrm (Register, 0w0 (* test *), regNum) in opb @ [mdrm, bits] end else if reg = ebx orelse reg = ecx orelse reg = edx (* can we use an 8-bit test? *) then (* Yes. The register value refers to low-order byte. *) let val opb = opCodeBytes(Group3_a, NONE) val mdrm = modrm(Register, 0w0 (* test *), regNum) in opb @ [mdrm, bits] end else let val opb = opCodeBytes(Group3_A32, NONE) val mdrm = modrm (Register, 0w0 (* test *), regNum) in opb @ mdrm :: word32Unsigned(Word8.toLarge bits) end end | cgOp(TestByteBits{arg=MemoryArg{base, offset, index}, bits}) = (* Test the tag bit and set the condition code. *) opIndexedPlus2(Group3_a, LargeInt.fromInt offset, base, index, 0w0 (* test *)) @ [ bits] | cgOp(TestByteBits _) = raise InternalError "cgOp: TestByteBits" | cgOp(ConditionalBranch{ test=opc, ... }) = opCodeBytes(CondJump32 opc, NONE) @ word32Unsigned 0w0 | cgOp(SetCondition{ output, test}) = let val (rrC, rx) = getReg output (* In 64-bit mode we can specify the low-order byte of RSI/RDI but we must use a REX prefix. This isn't possible in 32-bit mode. *) in if hostIsX64 orelse rrC < 0w4 then let val opb = opCodeBytes(SetCC test, if rx orelse rrC >= 0w4 then SOME{w=false, r=false, b=rx, x=false} else NONE) val mdrm = modrm (Register, 0w0, rrC) in opb @ [mdrm] end else raise InternalError "High byte register" end | cgOp(CallRTS{rtsEntry, saveRegs}) = rtsCall(rtsEntry, saveRegs) | cgOp(RepeatOperation repOp) = let (* We don't explicitly clear the direction flag. Should that be done? *) val opb = opCodeBytes(REP, NONE) (* Put in a rex prefix to force 64-bit mode. *) val optRex = if case repOp of STOS64 => true | MOVS64 => true | _ => false then [rex{w=true, r=false, b=false, x=false}] else [] val repOp = repOpsToWord repOp in opb @ optRex @ [repOp] end | cgOp(DivideAccR{arg, isSigned, opSize}) = opRegPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, arg, if isSigned then 0w7 else 0w6) | cgOp(DivideAccM{base, offset, isSigned, opSize}) = opPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, LargeInt.fromInt offset, base, if isSigned then 0w7 else 0w6) | cgOp(AtomicXAdd{address={offset, base, index}, output, opSize}) = (* Locked exchange-and-add. We need the lock prefix before the REX prefix. *) opAddress(case opSize of OpSize64 => LOCK_XADD64 | OpSize32 => LOCK_XADD32, LargeInt.fromInt offset, base, index, output) | cgOp(PushToStack(RegisterArg reg)) = let val (rc, rx) = getReg reg in (* Always 64-bit but a REX prefix may be needed for the register. *) opCodeBytes(PUSH_R rc, if rx then SOME{w=false, b = true, x=false, r = false } else NONE) end | cgOp(PushToStack(MemoryArg{base, offset, index})) = opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w6 (* push *)) | cgOp(PushToStack(NonAddressConstArg constnt)) = if is8BitL constnt then opCodeBytes(PUSH_8, NONE) @ [Word8.fromLargeInt constnt] else if is32bit constnt then opCodeBytes(PUSH_32, NONE) @ int32Signed constnt else (* It won't fit in the immediate; put it in the non-address area. *) let val opb = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w6 (* push *), 0w5 (* PC rel *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp(PushToStack(AddressConstArg _)) = ( case targetArch of Native64Bit => (* Put it in the constant area. *) let val opb = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w6 (* push *), 0w5 (* PC rel *)); in opb @ [mdrm] @ int32Signed(tag 0) end | Native32Bit => opCodeBytes(PUSH_32, NONE) @ int32Signed(tag 0) | ObjectId32Bit => (* We can't do this. The constant area contains 32-bit quantities and 32-bit literals are sign-extended rather than zero-extended. *) raise InternalError "PushToStack:AddressConstArg" ) | cgOp(PopR reg ) = let val (rc, rx) = getReg reg in (* Always 64-bit but a REX prefix may be needed for the register. Because the register is encoded in the instruction the rex bit for the register is b not r. *) opCodeBytes(POP_R rc, if rx then SOME{w=false, b = true, x=false, r = false } else NONE) end | cgOp(Move{source=RegisterArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move64}) = opAddress(MOVL_R_A64, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{source=RegisterArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move32}) = opAddress(MOVL_R_A32, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move64 }) = ( (* Short constant. In 32-bit mode this is scanned as a possible address. That means we can't have an untagged constant in it. That's not a problem in 64-bit mode. There's a special check for using this to set the length word on newly allocated memory. *) targetArch <> Native32Bit orelse toStore = 0 orelse toStore mod 2 = 1 orelse offset = ~ (Word.toInt wordSize) orelse raise InternalError "cgOp: StoreConstToMemory not tagged"; opAddressPlus2(MOVL_32_A64, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed toStore ) | cgOp(Move{source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}, moveSize=Move32 }) = ( (* Short constant. In 32-bit mode this is scanned as a possible address. That means we can't have an untagged constant in it. That's not a problem in 64-bit mode. There's a special check for using this to set the length word on newly allocated memory. *) targetArch <> Native32Bit orelse toStore = 0 orelse toStore mod 2 = 1 orelse offset = ~ (Word.toInt wordSize) orelse raise InternalError "cgOp: StoreConstToMemory not tagged"; opAddressPlus2(MOVL_32_A32, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed toStore ) | cgOp(Move{source=AddressConstArg _, destination=MemoryArg{offset, base, index}, moveSize=Move32}) = (* This is not used for addresses even in 32-in-64. We don't scan for addresses after MOVL_32_A. *) if targetArch <> Native32Bit then raise InternalError "StoreLongConstToMemory in 64-bit mode" else opAddressPlus2(MOVL_32_A32, LargeInt.fromInt offset, base, index, 0w0) @ int32Signed (tag 0) | cgOp(Move{source=AddressConstArg _, destination=MemoryArg _, ...}) = raise InternalError "cgOp: Move - AddressConstArg => MemoryArg" | cgOp(Move{ moveSize = Move8, source=RegisterArg toStore, destination=MemoryArg{offset, base, index} }) = let val (rrC, _) = getReg toStore (* In 64-bit mode we can specify the low-order byte of RSI/RDI but we must use a REX prefix. This isn't possible in 32-bit mode. *) val opcode = if hostIsX64 then MOVB_R_A64{forceRex= rrC >= 0w4} else if rrC < 0w4 then MOVB_R_A32 else raise InternalError "High byte register" in opAddress(opcode, LargeInt.fromInt offset, base, index, toStore) end | cgOp(Move{ moveSize = Move16, source=RegisterArg toStore, destination=MemoryArg{offset, base, index}}) = opAddress(MOVL_R_A16, LargeInt.fromInt offset, base, index, toStore) | cgOp(Move{ moveSize = Move8, source=NonAddressConstArg toStore, destination=MemoryArg{offset, base, index}}) = opAddressPlus2(MOVB_8_A, LargeInt.fromInt offset, base, index, 0w0) @ [Word8.fromLargeInt toStore] | cgOp(Move _) = raise InternalError "Move: Unimplemented arguments" (* Allocation is dealt with by expanding the code. *) | cgOp(AllocStore _) = raise InternalError "cgOp: AllocStore" | cgOp(AllocStoreVariable _) = raise InternalError "cgOp: AllocStoreVariable" | cgOp StoreInitialised = raise InternalError "cgOp: StoreInitialised" - | cgOp(CallFunction Recursive) = (* Call to the start of the code. Offset is patched in later. *) + | cgOp(CallAddress(NonAddressConstArg _)) = (* Call to the start of the code. Offset is patched in later. *) opCodeBytes (CALL_32, NONE) @ int32Signed 0 - - | cgOp(CallFunction FullCall) = - (* Indirect call to the address held in the first word of the closure. *) - ( - case targetArch of - ObjectId32Bit => opAddressPlus2(Group5, 0, ebx, Index4 regClosure, 0w2 (* call *)) - | _ => opAddressPlus2(Group5, 0, regClosure, NoIndex, 0w2 (* call *)) - ) - | cgOp(CallFunction(ConstantCode _)) = + | cgOp(CallAddress(AddressConstArg _)) = if targetArch = Native64Bit then let val opc = opCodeBytes(Group5, NONE) val mdrm = modrm(Based0, 0w2 (* call *), 0w5 (* PC rel *)) in opc @ [mdrm] @ int32Signed(tag 0) end (* Because this is a relative branch we need to point this at itself. Until it is set to the relative offset of the destination it needs to contain an address within the code and this could be the last instruction. *) else opCodeBytes (CALL_32, NONE) @ int32Signed ~5 - | cgOp(CallFunction(DirectReg reg)) = opRegPlus2(Group5, reg, 0w2 (* call *)) + | cgOp(CallAddress(RegisterArg reg)) = opRegPlus2(Group5, reg, 0w2 (* call *)) + + | cgOp(CallAddress(MemoryArg{base, offset, index})) = + opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w2 (* call *)) - | cgOp(JumpToFunction Recursive) = + | cgOp(JumpAddress(NonAddressConstArg _)) = (* Jump to the start of the current function. Offset is patched in later. *) opCodeBytes (JMP_32, NONE) @ int32Signed 0 - - | cgOp(JumpToFunction FullCall) = - ( - case targetArch of - ObjectId32Bit => opAddressPlus2(Group5, 0, ebx, Index4 regClosure, 0w4 (* jmp *)) - | _ => opAddressPlus2(Group5, 0, regClosure, NoIndex, 0w4 (* jmp *)) - ) - | cgOp(JumpToFunction (ConstantCode _)) = + | cgOp(JumpAddress (AddressConstArg _)) = if targetArch = Native64Bit then let val opb = opCodeBytes (Group5, NONE) val mdrm = modrm(Based0, 0w4 (* jmp *), 0w5 (* PC rel *)) in opb @ [mdrm] @ int32Signed(tag 0) end else opCodeBytes (JMP_32, NONE) @ int32Signed ~5 (* As with Call. *) - | cgOp(JumpToFunction (DirectReg reg)) = + | cgOp(JumpAddress (RegisterArg reg)) = (* Used as part of indexed case - not for entering a function. *) opRegPlus2(Group5, reg, 0w4 (* jmp *)) + + | cgOp(JumpAddress(MemoryArg{base, offset, index})) = + opAddressPlus2(Group5, LargeInt.fromInt offset, base, index, 0w4 (* jmp *)) | cgOp(ReturnFromFunction args) = if args = 0 then opCodeBytes(RET, NONE) else let val offset = Word.fromInt args * nativeWordSize in opCodeBytes(RET_16, NONE) @ [wordToWord8 offset, wordToWord8(offset >> 0w8)] end | cgOp (RaiseException { workReg }) = opEA(if hostIsX64 then MOVL_A_R64 else MOVL_A_R32, LargeInt.fromInt memRegHandlerRegister, ebp, workReg) @ opAddressPlus2(Group5, 0, workReg, NoIndex, 0w4 (* jmp *)) | cgOp(UncondBranch _) = opToInt JMP_32 :: word32Unsigned 0w0 | cgOp(ResetStack{numWords, preserveCC}) = let val bytes = Word.toLargeInt(Word.fromInt numWords * nativeWordSize) in (* If we don't need to preserve the CC across the reset we use ADD since it's shorter. *) if preserveCC then opEA(if hostIsX64 then LEAL64 else LEAL32, bytes, esp, esp) else immediateOperand(ADD, esp, bytes, if hostIsX64 then OpSize64 else OpSize32) end | cgOp(JumpLabel _) = [] (* No code. *) | cgOp(LoadLabelAddress{ output, ... }) = (* Load the address of a label. Used when setting up an exception handler or in indexed cases. *) (* On X86/64 we can use pc-relative addressing to set the start of the handler. On X86/32 we have to load the address of the start of the code and add an offset. *) if hostIsX64 then opConstantOperand(LEAL64, output) else let val (rc, _) = getReg output in opCodeBytes(MOVL_32_R rc , NONE) @ int32Signed(tag 0) @ opRegPlus2(Group1_32_A32, output, arithOpToWord ADD) @ int32Signed 0 end | cgOp (FPLoadFromMemory {address={ base, offset, index }, precision}) = let val loadInstr = case precision of DoublePrecision => FPESC 0w5 | SinglePrecision => FPESC 0w1 in opAddressPlus2(loadInstr, LargeInt.fromInt offset, base, index, 0wx0) end | cgOp (FPLoadFromFPReg{source=FloatingPtReg fp, ...}) = (* Assume there's nothing currently on the stack. *) floatingPtOp({escape=0w1, md=0w3, nnn=0w0, rm= fp + 0w0}) (* FLD ST(r1) *) | cgOp (FPLoadFromConst {precision, ...} ) = (* The real constant here is actually the address of a memory object. FLD takes the address as the argument and in 32-bit mode we use an absolute address. In 64-bit mode we need to put the constant at the end of the code segment and use PC-relative addressing which happens to be encoded in the same way. There are special cases for zero and one but it's probably too much work to detect them. *) let val esc = case precision of SinglePrecision => 0w1 | DoublePrecision => 0w5 val opb = opCodeBytes(FPESC esc, NONE) (* FLD [Constant] *) val mdrm = modrm (Based0, 0w0, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (FPStoreToFPReg{ output=FloatingPtReg dest, andPop }) = (* Assume there's one item on the stack. *) floatingPtOp({escape=0w5, md=0w3, nnn=if andPop then 0wx3 else 0wx2, rm = dest+0w1(* One item *)}) (* FSTP ST(n+1) *) | cgOp (FPStoreToMemory{address={ base, offset, index}, precision, andPop }) = let val storeInstr = case precision of DoublePrecision => FPESC 0w5 | SinglePrecision => FPESC 0w1 val subInstr = if andPop then 0wx3 else 0wx2 in opAddressPlus2(storeInstr, LargeInt.fromInt offset, base, index, subInstr) end | cgOp (FPArithR{ opc, source = FloatingPtReg src}) = floatingPtOp({escape=0w0, md=0w3, nnn=fpOpToWord opc, rm=src + 0w1 (* One item already there *)}) | cgOp (FPArithConst{ opc, precision, ... }) = (* See comment on FPLoadFromConst *) let val fpesc = case precision of DoublePrecision => 0w4 | SinglePrecision => 0w0 val opb = opCodeBytes(FPESC fpesc, NONE) (* FADD etc [constnt] *) val mdrm = modrm (Based0, fpOpToWord opc, 0w5 (* constant address *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (FPArithMemory{ opc, base, offset, precision }) = let val fpesc = case precision of DoublePrecision => 0w4 | SinglePrecision => 0w0 in opPlus2(FPESC fpesc, LargeInt.fromInt offset, base, fpOpToWord opc) (* FADD/FMUL etc [r2] *) end | cgOp (FPUnary opc ) = let val {rm, nnn} = fpUnaryToWords opc in floatingPtOp({escape=0w1, md=0w3, nnn=nnn, rm=rm}) (* FCHS etc *) end | cgOp (FPStatusToEAX ) = opCodeBytes(FPESC 0w7, NONE) @ [0wxe0] (* FNSTSW AX *) | cgOp (FPFree(FloatingPtReg reg)) = floatingPtOp({escape=0w5, md=0w3, nnn=0w0, rm=reg}) (* FFREE FP(n) *) | cgOp (FPLoadInt{base, offset, opSize=OpSize64}) = (* fildl (esp) in 32-bit mode or fildq (esp) in 64-bit mode. *) opPlus2(FPESC 0w7, LargeInt.fromInt offset, base, 0w5) | cgOp (FPLoadInt{base, offset, opSize=OpSize32}) = (* fildl (esp) in 32-bit mode or fildq (esp) in 64-bit mode. *) opPlus2(FPESC 0w3, LargeInt.fromInt offset, base, 0w0) | cgOp (MultiplyR {source=RegisterArg srcReg, output, opSize}) = (* We use the 0F AF form of IMUL rather than the Group3 MUL or IMUL because the former allows us to specify the destination register. The Group3 forms produce double length results in RAX:RDX/EAX:EDX but we only ever want the low-order half. *) opReg(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32 (* 2 byte opcode *), output, srcReg) | cgOp (MultiplyR {source=MemoryArg{base, offset, index}, output, opSize}) = (* This may be used for large-word multiplication. *) opAddress(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32 (* 2 byte opcode *), LargeInt.fromInt offset, base, index, output) | cgOp(MultiplyR {source=NonAddressConstArg constnt, output, opSize}) = (* If the constant is an 8-bit or 32-bit value we are actually using a three-operand instruction where the argument can be a register or memory and the destination register does not need to be the same as the source. *) if is8BitL constnt then opReg(case opSize of OpSize64 => IMUL_C8_64 | OpSize32 => IMUL_C8_32, output, output) @ [Word8.fromLargeInt constnt] else if is32bit constnt then opReg(case opSize of OpSize64 => IMUL_C32_64 | OpSize32 => IMUL_C32_32, output, output) @ int32Signed constnt else opConstantOperand(case opSize of OpSize64 => IMUL64 | OpSize32 => IMUL32, output) | cgOp(MultiplyR {source=AddressConstArg _, ...}) = raise InternalError "Multiply - address constant" | cgOp (XMMArith { opc, source=MemoryArg{base, offset, index}, output }) = mMXAddress(SSE2Ops opc, LargeInt.fromInt offset, base, index, output) | cgOp (XMMArith { opc, source=AddressConstArg _, output=SSE2Reg rrC }) = let (* The real constant here is actually the address of an 8-byte memory object. In 32-bit mode we put this address into the code and retain this memory object. In 64-bit mode we copy the real value out of the memory object into the non-address constant area and use PC-relative addressing. These happen to be encoded the same way. *) val opb = opCodeBytes(SSE2Ops opc, NONE) val mdrm = modrm (Based0, rrC, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (XMMArith { opc, source=RegisterArg(SSE2Reg rrS), output=SSE2Reg rrC }) = let val oper = SSE2Ops opc val pref = opcodePrefix oper val esc = escapePrefix oper val opc = opToInt oper val mdrm = modrm(Register, rrC, rrS) in pref @ esc @ [opc, mdrm] end | cgOp (XMMArith { opc, source=NonAddressConstArg _, output=SSE2Reg rrC }) = let val _ = hostIsX64 orelse raise InternalError "XMMArith-NonAddressConstArg in 32-bit mode" (* This is currently used for 32-bit float arguments but can equally be used for 64-bit values since the actual argument will always be put in the 64-bit constant area. *) val opb = opCodeBytes(SSE2Ops opc, NONE) val mdrm = modrm (Based0, rrC, 0w5 (* constant address/PC-relative *)) in opb @ [mdrm] @ int32Signed(tag 0) end | cgOp (XMMStoreToMemory { toStore, address={base, offset, index}, precision }) = let val oper = case precision of DoublePrecision => SSE2StoreDouble | SinglePrecision => SSE2StoreSingle in mMXAddress(oper, LargeInt.fromInt offset, base, index, toStore) end | cgOp (XMMConvertFromInt { source, output=SSE2Reg rrC, opSize }) = let (* The source is a general register and the output a XMM register. *) (* TODO: The source can be a memory location. *) val (rbC, rbX) = getReg source val oper = case opSize of OpSize64 => CVTSI2SD64 | OpSize32 => CVTSI2SD32 in (* This is a special case with both an XMM and general register. *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp (SignExtendForDivide OpSize64) = opCodeBytes(CQO_CDQ64, SOME {w=true, r=false, b=false, x=false}) | cgOp (SignExtendForDivide OpSize32) = opCodeBytes(CQO_CDQ32, NONE) | cgOp (XChng { reg, arg=RegisterArg regY, opSize }) = opReg(case opSize of OpSize64 => XCHNG64 | OpSize32 => XCHNG32, reg, regY) | cgOp (XChng { reg, arg=MemoryArg{offset, base, index}, opSize }) = opAddress(case opSize of OpSize64 => XCHNG64 | OpSize32 => XCHNG32, LargeInt.fromInt offset, base, index, reg) | cgOp (XChng _) = raise InternalError "cgOp: XChng" | cgOp (Negative {output, opSize}) = opRegPlus2(case opSize of OpSize64 => Group3_A64 | OpSize32 => Group3_A32, output, 0w3 (* neg *)) | cgOp (JumpTable{cases, jumpSize=ref jumpSize}) = let val _ = jumpSize = JumpSize8 orelse raise InternalError "cgOp: JumpTable" (* Make one jump for each case and pad it 8 bytes with Nops. *) fun makeJump (_, l) = opToInt JMP_32 :: word32Unsigned 0w0 @ [opToInt NOP, opToInt NOP, opToInt NOP] @ l in List.foldl makeJump [] cases end | cgOp(IndexedJumpCalc{ addrReg, indexReg, jumpSize=ref jumpSize }) = ( jumpSize = JumpSize8 orelse raise InternalError "cgOp: IndexedJumpCalc"; (* Should currently be JumpSize8 which requires a multiplier of 4 and 4 to be subtracted to remove the shifted tag. *) opAddress(if hostIsX64 then LEAL64 else LEAL32, ~4, addrReg, Index4 indexReg, addrReg) ) | cgOp(MoveXMMRegToGenReg { source=SSE2Reg rrC, output }) = let (* The source is a XMM register and the output a general register. *) val (rbC, rbX) = getReg output val oper = MOVDFromXMM in (* This is a special case with both an XMM and general register. *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp(MoveGenRegToXMMReg { source, output=SSE2Reg rrC }) = let (* The source is a general register and the output a XMM register. *) val (rbC, rbX) = getReg source val oper = MOVQToXMM in (* This is a special case with both an XMM and general register. *) (* This needs to move the whole 64-bit value. TODO: This is inconsistent with MoveXMMRegToGenReg *) opcodePrefix oper @ rexByte(oper, false, rbX, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rrC, rbC)] end | cgOp(XMMShiftRight { output=SSE2Reg rrC, shift }) = let val oper = PSRLDQ in opcodePrefix oper @ escapePrefix oper @ [opToInt oper, modrm(Register, 0w3, rrC), shift] end | cgOp(FPLoadCtrlWord {base, offset, index}) = opIndexedPlus2(FPESC 0w1, LargeInt.fromInt offset, base, index, 0w5) | cgOp(FPStoreCtrlWord {base, offset, index}) = opIndexedPlus2(FPESC 0w1, LargeInt.fromInt offset, base, index, 0w7) | cgOp(XMMLoadCSR {base, offset, index}) = opIndexedPlus2(LDSTMXCSR, LargeInt.fromInt offset, base, index, 0w2) | cgOp(XMMStoreCSR {base, offset, index}) = opIndexedPlus2(LDSTMXCSR, LargeInt.fromInt offset, base, index, 0w3) | cgOp(FPStoreInt {base, offset, index}) = (* fistp dword ptr [esp] in 32-bit mode or fistp qword ptr [rsp] in 64-bit mode. *) if hostIsX64 then opIndexedPlus2(FPESC 0w7, LargeInt.fromInt offset, base, index, 0w7) else opIndexedPlus2(FPESC 0w3, LargeInt.fromInt offset, base, index, 0w3) | cgOp(XMMStoreInt {source, output, precision, isTruncate}) = let (* The destination is a general register. The source is an XMM register or memory. *) val (rbC, rbX) = getReg output val oper = case (hostIsX64, precision, isTruncate) of (false, DoublePrecision, false) => CVTSD2SI32 | (true, DoublePrecision, false) => CVTSD2SI64 | (false, SinglePrecision, false) => CVTSS2SI32 | (true, SinglePrecision, false) => CVTSS2SI64 | (false, DoublePrecision, true) => CVTTSD2SI32 | (true, DoublePrecision, true) => CVTTSD2SI64 | (false, SinglePrecision, true) => CVTTSS2SI32 | (true, SinglePrecision, true) => CVTTSS2SI64 in case source of MemoryArg{base, offset, index} => opAddress(oper, LargeInt.fromInt offset, base, index, output) | RegisterArg(SSE2Reg rrS) => opcodePrefix oper @ rexByte(oper, rbX, false, false) @ escapePrefix oper @ [opToInt oper, modrm(Register, rbC, rrS)] | _ => raise InternalError "XMMStoreInt: Not register or memory" end | cgOp(CondMove { test, output, source=RegisterArg source, opSize=OpSize32 }) = opReg(CMOV32 test, output, source) | cgOp(CondMove { test, output, source=RegisterArg source, opSize=OpSize64 }) = opReg(CMOV64 test, output, source) | cgOp(CondMove { test, output, source=NonAddressConstArg _, opSize }) = ( (* We currently support only native-64 bit and put the constant in the non-address constant area. These are 64-bit values both in native 64-bit and in 32-in-64. To support it in 32-bit mode we'd have to put the constant in a single-word object and put its absolute address into the code. *) targetArch <> Native32Bit orelse raise InternalError "CondMove: constant in 32-bit mode"; opConstantOperand((case opSize of OpSize32 => CMOV32 | OpSize64 => CMOV64) test, output) ) | cgOp(CondMove { test, output, source=AddressConstArg _, opSize=OpSize64 }) = (* An address constant. The opSize must match the size of a polyWord since the value it going into the constant area. *) ( targetArch = Native64Bit orelse raise InternalError "CondMove: AddressConstArg"; opConstantOperand(CMOV64 test, output) ) | cgOp(CondMove { test, output, source=AddressConstArg _, opSize=OpSize32 }) = ( (* We only support address constants in 32-in-64. *) targetArch = ObjectId32Bit orelse raise InternalError "CondMove: AddressConstArg"; opConstantOperand(CMOV32 test, output) ) | cgOp(CondMove { test, output, source=MemoryArg{base, offset, index}, opSize=OpSize32 }) = opAddress(CMOV32 test, LargeInt.fromInt offset, base, index, output) | cgOp(CondMove { test, output, source=MemoryArg{base, offset, index}, opSize=OpSize64 }) = opAddress(CMOV64 test, LargeInt.fromInt offset, base, index, output) in List.rev(List.foldl (fn (c, list) => Word8Vector.fromList(cgOp c) :: list) [] ops) end (* General function to process the code. ic is the byte counter within the original code. *) fun foldCode foldFn n (ops, byteList) = let fun doFold(oper :: operList, bytes :: byteList, ic, acc) = doFold(operList, byteList, ic + Word.fromInt(Word8Vector.length bytes), foldFn(oper, bytes, ic, acc)) | doFold(_, _, _, n) = n in doFold(ops, byteList, 0w0, n) end (* Go through the code and update branch and similar instructions with the destinations of the branches. Long branches are converted to short where possible and the code is reprocessed. That might repeat if the effect of shorting one branch allows another to be shortened. *) fun fixupLabels(ops, bytesList, labelCount) = let (* Label array - initialise to 0wxff... . Every label should be defined but just in case, this is more likely to be detected in int32Signed. *) val labelArray = Array.array(labelCount, ~ 0w1) (* First pass - Set the addresses of labels. *) fun setLabelAddresses(oper :: operList, bytes :: byteList, ic) = ( case oper of JumpLabel(Label{labelNo, ...}) => Array.update(labelArray, labelNo, ic) | _ => (); setLabelAddresses(operList, byteList, ic + Word.fromInt(Word8Vector.length bytes)) ) | setLabelAddresses(_, _, ic) = ic (* Return the length of the code. *) fun fixup32(destination, bytes, ic) = let val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in Word8VectorSlice.concat[ Word8VectorSlice.slice(bytes, 0, SOME(brLength-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt diff))) ] end fun fixupAddress(UncondBranch(Label{labelNo, ...}), bytes, ic, list) = let val destination = Array.sub(labelArray, labelNo) val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in if brLength = 2 then (* It's a short branch. Take the original operand and set the relative offset. *) Word8Vector.fromList [opToInt JMP_8, byteSigned diff] :: list else if brLength <> 5 then raise InternalError "fixupAddress" else (* 32-bit offset. If it will fit in a byte we can use a short branch. If this is a reverse branch we can actually use values up to -131 here because we've calculated using the end of the long branch. *) if diff <= 127 andalso diff >= ~(128 + 3) then Word8Vector.fromList [opToInt JMP_8, 0w0 (* Fixed on next pass *)] :: list else Word8Vector.fromList(opToInt JMP_32 :: int32Signed(LargeInt.fromInt diff)) :: list end | fixupAddress(ConditionalBranch{label=Label{labelNo, ...}, test, ...}, bytes, ic, list) = let val destination = Array.sub(labelArray, labelNo) val brLength = Word8Vector.length bytes (* The offset is relative to the end of the branch instruction. *) val diff = Word.toInt destination - Word.toInt ic - brLength in if brLength = 2 then (* It's a short branch. Take the original operand and set the relative offset. *) Word8Vector.fromList [opToInt(CondJump test), byteSigned diff] :: list else if brLength <> 6 then raise InternalError "fixupAddress" else if diff <= 127 andalso diff >= ~(128+4) then Word8Vector.fromList[opToInt(CondJump test), 0w0 (* Fixed on next pass *)] :: list else Word8Vector.fromList(opCodeBytes(CondJump32 test, NONE) @ int32Signed(LargeInt.fromInt diff)) :: list end | fixupAddress(LoadLabelAddress{ label=Label{labelNo, ...}, ... }, brCode, ic, list) = let val destination = Array.sub(labelArray, labelNo) in if hostIsX64 then (* This is a relative offset on the X86/64. *) fixup32(destination, brCode, ic) :: list else (* On X86/32 the address is relative to the start of the code so we simply put in the destination address. *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(Word8Vector.length brCode-4)), Word8VectorSlice.full(Word8Vector.fromList(int32Signed(Word.toLargeInt destination)))] :: list end | fixupAddress(JumpTable{cases, jumpSize as ref JumpSize8}, brCode: Word8Vector.vector, ic, list) = let (* Each branch is a 32-bit jump padded up to 8 bytes. *) fun processCase(Label{labelNo, ...} :: cases, offset, ic) = fixup32(Array.sub(labelArray, labelNo), Word8VectorSlice.vector(Word8VectorSlice.slice(brCode, offset, SOME 5)), ic) :: Word8VectorSlice.vector(Word8VectorSlice.slice(brCode, offset+5, SOME 3)) :: processCase(cases, offset+8, ic+0w8) | processCase _ = [] (* Could we use short branches? If all of the branches were short the table would be smaller so the offsets we use would be less. Ignore backwards branches - could only occur if we have linked labels in a loop. *) val newStartOfCode = ic + Word.fromInt(List.length cases * 6) fun tryShort(Label{labelNo, ...} :: cases, ic) = let val destination = Array.sub(labelArray, labelNo) in if destination > ic + 0w2 andalso destination - ic - 0w2 < 0w127 then tryShort(cases, ic+0w2) else false end | tryShort _ = true val newCases = if tryShort(cases, newStartOfCode) then ( jumpSize := JumpSize2; (* Generate a short branch table. *) List.map(fn _ => Word8Vector.fromList [opToInt JMP_8, 0w0 (* Fixed on next pass *)]) cases ) else processCase(cases, 0, ic) in Word8Vector.concat newCases :: list end | fixupAddress(JumpTable{cases, jumpSize=ref JumpSize2}, _, ic, list) = let (* Each branch is a short jump. *) fun processCase(Label{labelNo, ...} :: cases, offset, ic) = let val destination = Array.sub(labelArray, labelNo) val brLength = 2 val diff = Word.toInt destination - Word.toInt ic - brLength in Word8Vector.fromList[opToInt JMP_8, byteSigned diff] :: processCase(cases, offset+2, ic+0w2) end | processCase _ = [] in Word8Vector.concat(processCase(cases, 0, ic)) :: list end (* If we've shortened a jump table we have to change the indexing. *) | fixupAddress(IndexedJumpCalc{ addrReg, indexReg, jumpSize=ref JumpSize2 }, _, _, list) = (* On x86/32 it might be shorter to use DEC addrReg; ADD addrReg, indexReg. *) Word8Vector.fromList(opAddress(if hostIsX64 then LEAL64 else LEAL32, ~1, addrReg, Index1 indexReg, addrReg)) :: list - | fixupAddress(CallFunction Recursive, brCode, ic, list) = + | fixupAddress(CallAddress(NonAddressConstArg _), brCode, ic, list) = let val brLen = Word8Vector.length brCode in (* Call to the start of the code. Offset is -(bytes to start). *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(brLen-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt(~(Word.toInt ic+brLen))))) ] :: list end - | fixupAddress(JumpToFunction Recursive, brCode, ic, list) = + | fixupAddress(JumpAddress(NonAddressConstArg _), brCode, ic, list) = let val brLen = Word8Vector.length brCode in (* Call to the start of the code. Offset is -(bytes to start). *) Word8VectorSlice.concat[ Word8VectorSlice.slice(brCode, 0, SOME(brLen-4)), (* The original opcode. *) Word8VectorSlice.full(Word8Vector.fromList(int32Signed(LargeInt.fromInt(~(Word.toInt ic+brLen))))) ] :: list end | fixupAddress(_, bytes, _, list) = bytes :: list fun reprocess(bytesList, lastCodeSize) = let val fixedList = List.rev(foldCode fixupAddress [] (ops, bytesList)) val newCodeSize = setLabelAddresses(ops, fixedList, 0w0) in if newCodeSize = lastCodeSize then (fixedList, lastCodeSize) else if newCodeSize > lastCodeSize then raise InternalError "reprocess - size increased" else reprocess(fixedList, newCodeSize) end in reprocess(bytesList, setLabelAddresses(ops, bytesList, 0w0)) end (* The handling of constants generally differs between 32- and 64-bits. In 32-bits we put all constants inline and the GC processes the code to find the addresss. For real values the "constant" is actually the address of the boxed real value. In 64-bit mode inline constants were used with the MOV instruction but this has now been removed. All constants are stored in one of two areas at the end of the code segment. Non-addresses, including the actual values of reals, are stored in the non-address area and addresses go in the address area. Only the latter is scanned by the GC. The address area is also used in 32-bit mode but only has the address of the function name and the address of the profile ref in it. *) datatype inline32constants = SelfAddress (* The address of the start of the code - inline absolute address 32-bit only *) | InlineAbsoluteAddress of machineWord (* An address in the code: 32-bit only *) | InlineRelativeAddress of machineWord (* A relative address: 32-bit only. *) local (* Turn an integer constant into an 8-byte vector. *) fun intConst ival = LargeWord.fromLargeInt ival (* Copy a real constant from memory into an 8-byte vector. *) fun realConst c = let val cAsAddr = toAddress c (* This may be a boxed real or, in 32-in-64 mode, a boxed float. *) val cLength = length cAsAddr * wordSize val _ = ((cLength = 0w8 orelse cLength = 0w4) andalso flags cAsAddr = F_bytes) orelse raise InternalError "realConst: Not a real number" fun getBytes(i, a) = if i = 0w0 then a else getBytes(i-0w1, a*0w256 + Word8.toLargeWord(loadByte(cAsAddr, i-0w1))) in getBytes(cLength, 0w0) end fun getConstant(Move{ source=NonAddressConstArg source, moveSize=Move32, ...}, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then ( if source >= ~0x80000000 andalso source < 0x100000000 then (* Signed or unsigned 32-bits. *) (inl, addr, na) else (* Too big for 32-bits. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) ) else (inl, addr, na) (* 32-bit mode. The constant will always be inline even if we've had to use LEA r,c *) | getConstant(Move{ source=NonAddressConstArg source, moveSize=Move64, ...}, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then ( if source >= ~0x80000000 andalso source < 0x100000000 then (* Signed or unsigned 32-bits. *) (inl, addr, na) else (* Too big for 32-bits. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) ) else (inl, addr, na) (* 32-bit mode. The constant will always be inline even if we've had to use XOR r,r; ADD r,c *) | getConstant(Move{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - wordSize, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(ArithToGenReg{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if is32bit source then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) | getConstant(ArithToGenReg{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(ArithMemLongConst{ source, ... }, bytes, ic, (inl, addr, na)) = (* 32-bit only. *) ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(PushToStack(NonAddressConstArg constnt), bytes, ic, (inl, addr, na)) = if is32bit constnt then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst constnt) :: na) | getConstant(PushToStack(AddressConstArg constnt), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, constnt) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constnt) :: inl, addr, na) - | getConstant(CallFunction(ConstantCode w), bytes, ic, (inl, addr, na)) = + | getConstant(CallAddress(AddressConstArg w), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, w) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineRelativeAddress w) :: inl, addr, na) - | getConstant(JumpToFunction(ConstantCode w), bytes, ic, (inl, addr, na)) = + | getConstant(JumpAddress(AddressConstArg w), bytes, ic, (inl, addr, na)) = if targetArch = Native64Bit then (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, w) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineRelativeAddress w) :: inl, addr, na) | getConstant(LoadLabelAddress _, _, ic, (inl, addr, na)) = (* We need the address of the code itself but it's in the first of a pair of instructions. *) if hostIsX64 then (inl, addr, na) else ((ic + 0w1, SelfAddress) :: inl, addr, na) | getConstant(FPLoadFromConst{constant, ...}, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst constant) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constant) :: inl, addr, na) | getConstant(FPArithConst{ source, ... }, bytes, ic, (inl, addr, na)) = if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst source) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(XMMArith { source=AddressConstArg constVal, ... }, bytes, ic, (inl, addr, na)) = (* Real.real constant or, with 32-bit words, a Real32.real constant. *) if hostIsX64 then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, realConst constVal) :: na) else ((ic + Word.fromInt(Word8Vector.length bytes) - 0w4, InlineAbsoluteAddress constVal) :: inl, addr, na) | getConstant(XMMArith { source=NonAddressConstArg constVal, ... }, bytes, ic, (inl, addr, na)) = (* Real32.real constant in native 64-bit. *) (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst constVal) :: na) | getConstant(MultiplyR{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if is32bit source then (inl, addr, na) else (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) | getConstant(CondMove{ source=NonAddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (inl, addr, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, intConst source) :: na) else (inl, addr, na) (* 32-bit mode. The constant will always be inline. *) | getConstant(CondMove{ source=AddressConstArg source, ... }, bytes, ic, (inl, addr, na)) = if targetArch <> Native32Bit then (* Address constants go in the constant area. *) (inl, (ic + Word.fromInt(Word8Vector.length bytes) - 0w4, source) :: addr, na) else ((ic + Word.fromInt(Word8Vector.length bytes) - wordSize, InlineAbsoluteAddress source) :: inl, addr, na) | getConstant(_, _, _, l) = l in val getConstants = foldCode getConstant ([], [], []) end (* It is convenient to have AllocStore and AllocStoreVariable as primitives at the higher level but at this point it's better to expand them into their basic instructions. *) fun expandComplexOperations(instrs, oldLabelCount) = let val labelCount = ref oldLabelCount fun mkLabel() = Label{labelNo= !labelCount} before labelCount := !labelCount + 1 (* On X86/64 the local pointer is in r15. On X86/32 it's in memRegs. *) val localPointer = if hostIsX64 then RegisterArg r15 else MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex} val nativeWordOpSize = if hostIsX64 then OpSize64 else OpSize32 fun allocStoreCommonCode (resultReg, isVarAlloc, regSaveSet: genReg list) = let val compare = ArithToGenReg{opc=CMP, output=resultReg, source=MemoryArg{base=ebp, offset=memRegLocalMbottom, index=NoIndex}, opSize=nativeWordOpSize} (* Normally we won't have run out of store so we want the default branch prediction to skip the test here. However doing that involves adding an extra branch which lengthens the code so it's probably not worth while. *) (* Just checking against the lower limit can fail in the situation where the heap pointer is at the low end of the address range and the store required is so large that the subtraction results in a negative number. In that case it will be > (unsigned) lower_limit so in addition we have to check that the result is < (unsigned) heap_pointer. This actually happened on Windows with X86-64. In theory this can happen with fixed-size allocations as well as variable allocations but in practice fixed-size allocations are going to be small enough that it's not a problem. *) val destLabel = mkLabel() val branches = if isVarAlloc then let val extraLabel = mkLabel() in [ConditionalBranch{test=JB, label=extraLabel}, ArithToGenReg{opc=CMP, output=resultReg, source=localPointer, opSize=nativeWordOpSize}, ConditionalBranch{test=JB, label=destLabel}, JumpLabel extraLabel] end else [ConditionalBranch{test=JNB, label=destLabel}] val callRts = CallRTS{rtsEntry=HeapOverflowCall, saveRegs=regSaveSet} val fixup = JumpLabel destLabel (* Update the heap pointer now we have the store. This is also used by the RTS in the event of a trap to work out how much store was being allocated. *) val update = if hostIsX64 then Move{source=RegisterArg resultReg, destination=RegisterArg r15, moveSize=Move64} else Move{source=RegisterArg resultReg, destination=MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex}, moveSize=Move32} in compare :: branches @ [callRts, fixup, update] end fun doExpansion([], code, _) = code | doExpansion(AllocStore {size, output, saveRegs} :: instrs, code, inAllocation) = let val _ = inAllocation andalso raise InternalError "doExpansion: Allocation started but not complete" val () = if List.exists (fn r => r = output) saveRegs then raise InternalError "AllocStore: in set" else () val startCode = case targetArch of Native64Bit => let val bytes = (size + 1) * Word.toInt wordSize in [LoadAddress{output=output, offset = ~ bytes, base=SOME r15, index=NoIndex, opSize=OpSize64}] (* TODO: What if it's too big to fit? *) end | Native32Bit => let val bytes = (size + 1) * Word.toInt wordSize in [Move{source=MemoryArg{base=ebp, offset=memRegLocalMPointer, index=NoIndex}, destination=RegisterArg output, moveSize=Move32}, LoadAddress{output=output, offset = ~ bytes, base=SOME output, index=NoIndex, opSize=OpSize32}] end | ObjectId32Bit => let (* We must allocate an even number of words. *) val heapWords = if Int.rem(size, 2) = 1 then size+1 else size+2 val bytes = heapWords * Word.toInt wordSize in [LoadAddress{output=output, offset = ~ bytes, base=SOME r15, index=NoIndex, opSize=OpSize64}] end val resultCode = startCode @ allocStoreCommonCode(output, false, saveRegs) in doExpansion(instrs, (List.rev resultCode) @ code, true) end | doExpansion(AllocStoreVariable {size, output, saveRegs} :: instrs, code, inAllocation) = let (* Allocates memory. The "size" register contains the number of words as a tagged int. *) val _ = inAllocation andalso raise InternalError "doExpansion: Allocation started but not complete" val () = if List.exists (fn r => r = output) saveRegs then raise InternalError "AllocStore: in set" else () (* Negate the length and add it to the current heap pointer. *) (* Compute the number of bytes into dReg. The length in sReg is the number of words as a tagged value so we need to multiply it, add wordSize to include one word for the header then subtract the, multiplied, tag. We use LEA here but want to avoid having an empty base register. *) val _ = size = output andalso raise InternalError "AllocStoreVariable : same register for size and output" val startCode = if wordSize = 0w8 (* 8-byte words *) then [ ArithToGenReg{opc=XOR, output=output, source=RegisterArg output, opSize=OpSize32 (* Rest is zeroed *)}, ArithToGenReg{opc=SUB, output=output, source=RegisterArg size, opSize=OpSize64}, LoadAddress{output=output, base=SOME r15, offset= ~(Word.toInt wordSize-4), index=Index4 output, opSize=OpSize64 } ] else (* 4 byte words *) [ LoadAddress{output=output, base=SOME size, offset=Word.toInt wordSize-2, index=Index1 size, opSize=nativeWordOpSize }, Negative{output=output, opSize=nativeWordOpSize}, ArithToGenReg{opc=ADD, output=output, source=localPointer, opSize=nativeWordOpSize} ] (* If this is 32-in-64 we need to round down to the next 8-byte boundary. *) val roundCode = if targetArch = ObjectId32Bit then [ArithToGenReg{opc=AND, output=output, source=NonAddressConstArg ~8, opSize=OpSize64 }] else [] val resultCode = startCode @ roundCode @ allocStoreCommonCode(output, true, saveRegs) in doExpansion(instrs, (List.rev resultCode) @ code, true) end | doExpansion(StoreInitialised :: instrs, code, _) = doExpansion(instrs, code, false) | doExpansion(instr :: instrs, code, inAlloc) = doExpansion(instrs, instr::code, inAlloc) val expanded = List.rev(doExpansion(instrs, [], false)) in (expanded, !labelCount) end fun printCode (Code{procName, printStream, ...}, seg) = let val print = printStream val ptr = ref 0w0; (* prints a string representation of a number *) fun printValue v = if v < 0 then (print "-"; print(LargeInt.toString (~ v))) else print(LargeInt.toString v) infix 3 +:= ; fun (x +:= y) = (x := !x + (y:word)); fun get16s (a, seg) : int = let val b0 = Word8.toInt (codeVecGet (seg, a)); val b1 = Word8.toInt (codeVecGet (seg, a + 0w1)); val b1' = if b1 >= 0x80 then b1 - 0x100 else b1; in (b1' * 0x100) + b0 end fun get16u(a, seg) : int = Word8.toInt (codeVecGet (seg, a + 0w1)) * 0x100 + Word8.toInt (codeVecGet (seg, a)) (* Get 1 unsigned byte from the given offset in the segment. *) fun get8u (a, seg) : Word8.word = codeVecGet (seg, a); (* Get 1 signed byte from the given offset in the segment. *) fun get8s (a, seg) : int = Word8.toIntX (codeVecGet (seg, a)); (* Get 1 signed 32 bit word from the given offset in the segment. *) fun get32s (a, seg) : LargeInt.int = let val b0 = Word8.toLargeInt (codeVecGet (seg, a)); val b1 = Word8.toLargeInt (codeVecGet (seg, a + 0w1)); val b2 = Word8.toLargeInt (codeVecGet (seg, a + 0w2)); val b3 = Word8.toLargeInt (codeVecGet (seg, a + 0w3)); val b3' = if b3 >= 0x80 then b3 - 0x100 else b3; val topHw = (b3' * 0x100) + b2; val bottomHw = (b1 * 0x100) + b0; in (topHw * exp2_16) + bottomHw end fun get64s (a, seg) : LargeInt.int = let val b0 = Word8.toLargeInt (codeVecGet (seg, a)); val b1 = Word8.toLargeInt (codeVecGet (seg, a + 0w1)); val b2 = Word8.toLargeInt (codeVecGet (seg, a + 0w2)); val b3 = Word8.toLargeInt (codeVecGet (seg, a + 0w3)); val b4 = Word8.toLargeInt (codeVecGet (seg, a + 0w4)); val b5 = Word8.toLargeInt (codeVecGet (seg, a + 0w5)); val b6 = Word8.toLargeInt (codeVecGet (seg, a + 0w6)); val b7 = Word8.toLargeInt (codeVecGet (seg, a + 0w7)); val b7' = if b7 >= 0x80 then b7 - 0x100 else b7; in ((((((((b7' * 0x100 + b6) * 0x100 + b5) * 0x100 + b4) * 0x100 + b3) * 0x100 + b2) * 0x100) + b1) * 0x100) + b0 end fun print32 () = printValue (get32s (!ptr, seg)) before (ptr +:= 0w4) and print64 () = printValue (get64s (!ptr, seg)) before (ptr +:= 0w8) and print16 () = printValue (LargeInt.fromInt(get16s (!ptr, seg)) before (ptr +:= 0w2)) and print8 () = printValue (LargeInt.fromInt(get8s (!ptr, seg)) before (ptr +:= 0w1)) fun printJmp () = let val valu = get8s (!ptr, seg) before ptr +:= 0w1 in print (Word.fmt StringCvt.HEX (Word.fromInt valu + !ptr)) end (* Print an effective address. The register field may designate a general register or an xmm register depending on the instruction. *) fun printEAGeneral printRegister (rex, sz) = let val modrm = codeVecGet (seg, !ptr) val () = ptr +:= 0w1 (* Decode the Rex prefix if present. *) val rexX = (rex andb8 0wx2) <> 0w0 val rexB = (rex andb8 0wx1) <> 0w0 val prefix = case sz of SZByte => "byte ptr " | SZWord => "word ptr " | SZDWord => "dword ptr " | SZQWord => "qword ptr " in case (modrm >>- 0w6, modrm andb8 0w7, hostIsX64) of (0w3, rm, _) => printRegister(rm, rexB, sz) | (md, 0w4, _) => let (* s-i-b present. *) val sib = codeVecGet (seg, !ptr) val () = ptr +:= 0w1 val ss = sib >>- 0w6 val index = (sib >>- 0w3) andb8 0w7 val base = sib andb8 0w7 in print prefix; case (md, base, hostIsX64) of (0w1, _, _) => print8 () | (0w2, _, _) => print32 () | (0w0, 0w5, _) => print32 () (* Absolute in 32-bit mode. PC-relative in 64-bit ?? *) | _ => (); print "["; if md <> 0w0 orelse base <> 0w5 then ( print (genRegRepr (mkReg (base, rexB), sz32_64)); if index = 0w4 then () else print "," ) else (); if index = 0w4 andalso not rexX (* No index. *) then () else print (genRegRepr (mkReg(index, rexX), sz32_64) ^ (if ss = 0w0 then "*1" else if ss = 0w1 then "*2" else if ss = 0w2 then "*4" else "*8")); print "]" end | (0w0, 0w5, false) => (* Absolute address.*) (print prefix; print32 ()) | (0w0, 0w5, _) => (* PC-relative in 64-bit *) (print prefix; print ".+"; print32 ()) | (md, rm, _) => (* register plus offset. *) ( print prefix; if md = 0w1 then print8 () else if md = 0w2 then print32 () else (); print ("[" ^ genRegRepr (mkReg(rm, rexB), sz32_64) ^ "]") ) end (* For most instructions we want to print a general register. *) val printEA = printEAGeneral (fn (rm, rexB, sz) => print (genRegRepr (mkReg(rm, rexB), sz))) and printEAxmm = printEAGeneral (fn (rm, _, _) => print (xmmRegRepr(SSE2Reg rm))) fun printArith opc = print (case opc of 0 => "add " | 1 => "or " | 2 => "adc " | 3 => "sbb " | 4 => "and " | 5 => "sub " | 6 => "xor " | _ => "cmp " ) fun printGvEv (opByte, rex, rexR, sz) = let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in printArith(Word8.toInt((opByte div 0w8) mod 0w8)); print "\t"; print (genRegRepr (mkReg(reg, rexR), sz)); print ","; printEA(rex, sz) end fun printMovCToR (opByte, sz, rexB) = ( print "mov \t"; print(genRegRepr (mkReg (opByte mod 0w8, rexB), sz)); print ","; case sz of SZDWord => print32 () | SZQWord => print64 () | _ => print "???" ) fun printShift (opByte, rex, sz) = let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 4 => "shl " | 5 => "shr " | 7 => "sar " | _ => "???" ); print "\t"; printEA(rex, sz); print ","; if opByte = opToInt Group2_1_A32 then print "1" else if opByte = opToInt Group2_CL_A32 then print "cl" else print8 () end fun printFloat (opByte, rex) = let (* Opcode is in next byte. *) val opByte2 = codeVecGet (seg, !ptr) val nnn = (opByte2 >>- 0w3) andb8 0w7 val escNo = opByte andb8 0wx7 in if (opByte2 andb8 0wxC0) = 0wxC0 then (* mod = 11 *) ( case (escNo, nnn, opByte2 andb8 0wx7 (* modrm *)) of (0w1, 0w4, 0w0) => print "fchs" | (0w1, 0w4, 0w1) => print "fabs" | (0w1, 0w5, 0w6) => print "fldz" | (0w1, 0w5, 0w1) => print "flf1" | (0w7, 0w4, 0w0) => print "fnstsw\tax" | (0w1, 0w5, 0w0) => print "fld1" | (0w1, 0w6, 0w3) => print "fpatan" | (0w1, 0w7, 0w2) => print "fsqrt" | (0w1, 0w7, 0w6) => print "fsin" | (0w1, 0w7, 0w7) => print "fcos" | (0w1, 0w6, 0w7) => print "fincstp" | (0w1, 0w6, 0w6) => print "fdecstp" | (0w3, 0w4, 0w2) => print "fnclex" | (0w5, 0w2, rno) => print ("fst \tst(" ^ Word8.toString rno ^ ")") | (0w5, 0w3, rno) => print ("fstp\tst(" ^ Word8.toString rno ^ ")") | (0w1, 0w0, rno) => print ("fld \tst(" ^ Word8.toString rno ^ ")") | (0w1, 0w1, rno) => print ("fxch\tst(" ^ Word8.toString rno ^ ")") | (0w0, 0w3, rno) => print ("fcomp\tst(" ^ Word8.toString rno ^ ")") | (0w0, 0w0, rno) => print ("fadd\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w1, rno) => print ("fmul\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w4, rno) => print ("fsub\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w5, rno) => print ("fsubr\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w6, rno) => print ("fdiv\tst,st(" ^ Word8.toString rno ^ ")") | (0w0, 0w7, rno) => print ("fdivr\tst,st(" ^ Word8.toString rno ^ ")") | (0w5, 0w0, rno) => print ("ffree\tst(" ^ Word8.toString rno ^ ")") | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)); ptr +:= 0w1 ) else (* mod = 00, 01, 10 *) ( case (escNo, nnn) of (0w0, 0w0) => (print "fadd\t"; printEA(rex, SZDWord)) (* Single precision. *) | (0w0, 0w1) => (print "fmul\t"; printEA(rex, SZDWord)) | (0w0, 0w3) => (print "fcomp\t"; printEA(rex, SZDWord)) | (0w0, 0w4) => (print "fsub\t"; printEA(rex, SZDWord)) | (0w0, 0w5) => (print "fsubr\t"; printEA(rex, SZDWord)) | (0w0, 0w6) => (print "fdiv\t"; printEA(rex, SZDWord)) | (0w0, 0w7) => (print "fdivr\t"; printEA(rex, SZDWord)) | (0w1, 0w0) => (print "fld \t"; printEA(rex, SZDWord)) | (0w1, 0w2) => (print "fst\t"; printEA(rex, SZDWord)) | (0w1, 0w3) => (print "fstp\t"; printEA(rex, SZDWord)) | (0w1, 0w5) => (print "fldcw\t"; printEA(rex, SZWord)) (* Control word is 16 bits *) | (0w1, 0w7) => (print "fstcw\t"; printEA(rex, SZWord)) (* Control word is 16 bits *) | (0w3, 0w0) => (print "fild\t"; printEA(rex, SZDWord)) (* 32-bit int. *) | (0w7, 0w5) => (print "fild\t"; printEA(rex, SZQWord)) (* 64-bit int. *) | (0w3, 0w3) => (print "fistp\t"; printEA(rex, SZDWord)) (* 32-bit int. *) | (0w7, 0w7) => (print "fistp\t"; printEA(rex, SZQWord)) (* 64-bit int. *) | (0w4, 0w0) => (print "fadd\t"; printEA(rex, SZQWord)) (* Double precision. *) | (0w4, 0w1) => (print "fmul\t"; printEA(rex, SZQWord)) | (0w4, 0w3) => (print "fcomp\t"; printEA(rex, SZQWord)) | (0w4, 0w4) => (print "fsub\t"; printEA(rex, SZQWord)) | (0w4, 0w5) => (print "fsubr\t"; printEA(rex, SZQWord)) | (0w4, 0w6) => (print "fdiv\t"; printEA(rex, SZQWord)) | (0w4, 0w7) => (print "fdivr\t"; printEA(rex, SZQWord)) | (0w5, 0w0) => (print "fld \t"; printEA(rex, SZQWord)) | (0w5, 0w2) => (print "fst\t"; printEA(rex, SZQWord)) | (0w5, 0w3) => (print "fstp\t"; printEA(rex, SZQWord)) | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)) ) end fun printJmp32 oper = let val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print oper; print "\t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end fun printMask mask = let val wordMask = Word.fromInt mask fun printAReg n = if n = regs then () else ( if (wordMask andb (0w1 << Word.fromInt n)) <> 0w0 then (print(regRepr(regN n)); print " ") else (); printAReg(n+1) ) in printAReg 0 end in if procName = "" (* No name *) then print "?" else print procName; print ":\n"; while get8u (!ptr, seg) <> 0wxf4 (* HLT. *) do let val () = print (Word.fmt StringCvt.HEX (!ptr)) (* The address in hex. *) val () = print "\t" (* See if we have a lock prefix. *) val () = if get8u (!ptr, seg) = 0wxF0 then (print "lock "; ptr := !ptr + 0w1) else () val legacyPrefix = let val p = get8u (!ptr, seg) in if p = 0wxF2 orelse p = 0wxF3 orelse p = 0wx66 then (ptr := !ptr + 0w1; p) else 0wx0 end (* See if we have a REX byte. *) val rex = let val b = get8u (!ptr, seg); in if b >= 0wx40 andalso b <= 0wx4f then (ptr := !ptr + 0w1; b) else 0w0 end val rexW = (rex andb8 0wx8) <> 0w0 val rexR = (rex andb8 0wx4) <> 0w0 val rexB = (rex andb8 0wx1) <> 0w0 val opByte = get8u (!ptr, seg) before ptr +:= 0w1 val sizeFromRexW = if rexW then SZQWord else SZDWord in case opByte of 0wx03 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx0b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx0f => (* ESCAPE *) let (* Opcode is in next byte. *) val opByte2 = codeVecGet (seg, !ptr) val () = (ptr +:= 0w1) fun printcmov movop = let val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print movop; print "\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end in case legacyPrefix of 0w0 => ( case opByte2 of 0wx2e => let (* ucomiss doesn't have a prefix. *) val nb = codeVecGet (seg, !ptr) val reg = SSE2Reg((nb >>- 0w3) andb8 0w7) in print "ucomiss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) end | 0wx40 => printcmov "cmovo" | 0wx41 => printcmov "cmovno" | 0wx42 => printcmov "cmovb" | 0wx43 => printcmov "cmovnb" | 0wx44 => printcmov "cmove" | 0wx45 => printcmov "cmovne" | 0wx46 => printcmov "cmovna" | 0wx47 => printcmov "cmova" | 0wx48 => printcmov "cmovs" | 0wx49 => printcmov "cmovns" | 0wx4a => printcmov "cmovp" | 0wx4b => printcmov "cmovnp" | 0wx4c => printcmov "cmovl" | 0wx4d => printcmov "cmovge" | 0wx4e => printcmov "cmovle" | 0wx4f => printcmov "cmovg" | 0wxC1 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in (* The address argument comes first in the assembly code. *) print "xadd\t"; printEA (rex, sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wxB6 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movzx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZByte) end | 0wxB7 => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "movzx\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, SZWord) end | 0wxAE => let (* Opcode is determined by the next byte. *) val opByte2 = codeVecGet (seg, !ptr); val nnn = (opByte2 >>- 0w3) andb8 0w7 in case nnn of 0wx2 => (print "ldmxcsr\t"; printEA(rex, SZDWord)) | 0wx3 => (print "stmxcsr\t"; printEA(rex, SZDWord)) | _ => (printValue(Word8.toLargeInt opByte); printValue(Word8.toLargeInt opByte2)) end | 0wxAF => let val nb = codeVecGet (seg, !ptr); val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA (rex, sizeFromRexW) end | 0wx80 => printJmp32 "jo " | 0wx81 => printJmp32 "jno " | 0wx82 => printJmp32 "jb " | 0wx83 => printJmp32 "jnb " | 0wx84 => printJmp32 "je " | 0wx85 => printJmp32 "jne " | 0wx86 => printJmp32 "jna " | 0wx87 => printJmp32 "ja " | 0wx88 => printJmp32 "js " | 0wx89 => printJmp32 "jns " | 0wx8a => printJmp32 "jp " | 0wx8b => printJmp32 "jnp " | 0wx8c => printJmp32 "jl " | 0wx8d => printJmp32 "jge " | 0wx8e => printJmp32 "jle " | 0wx8f => printJmp32 "jg " | 0wx90 => (print "seto\t"; printEA (rex, SZByte)) | 0wx91 => (print "setno\t"; printEA (rex, SZByte)) | 0wx92 => (print "setb\t"; printEA (rex, SZByte)) | 0wx93 => (print "setnb\t"; printEA (rex, SZByte)) | 0wx94 => (print "sete\t"; printEA (rex, SZByte)) | 0wx95 => (print "setne\t"; printEA (rex, SZByte)) | 0wx96 => (print "setna\t"; printEA (rex, SZByte)) | 0wx97 => (print "seta\t"; printEA (rex, SZByte)) | 0wx98 => (print "sets\t"; printEA (rex, SZByte)) | 0wx99 => (print "setns\t"; printEA (rex, SZByte)) | 0wx9a => (print "setp\t"; printEA (rex, SZByte)) | 0wx9b => (print "setnp\t"; printEA (rex, SZByte)) | 0wx9c => (print "setl\t"; printEA (rex, SZByte)) | 0wx9d => (print "setge\t"; printEA (rex, SZByte)) | 0wx9e => (print "setle\t"; printEA (rex, SZByte)) | 0wx9f => (print "setg\t"; printEA (rex, SZByte)) | _ => (print "esc\t"; printValue(Word8.toLargeInt opByte2)) ) | 0wxf2 => (* SSE2 instruction *) let val nb = codeVecGet (seg, !ptr) val rr = (nb >>- 0w3) andb8 0w7 val reg = SSE2Reg rr in case opByte2 of 0wx10 => ( print "movsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx11 => ( print "movsd\t"; printEAxmm(rex, SZQWord); print ","; print(xmmRegRepr reg) ) | 0wx2a => ( print "cvtsi2sd\t"; print(xmmRegRepr reg); print ","; printEA(rex, sizeFromRexW) ) | 0wx2c => ( print "cvttsd2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx2d => ( print "cvtsd2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx58 => ( print "addsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx59 => ( print "mulsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5a => ( print "cvtsd2ss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5c => ( print "subsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx5e => ( print "divsd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | b => (print "F2\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | 0wxf3 => (* SSE2 instruction. *) let val nb = codeVecGet (seg, !ptr) val rr = (nb >>- 0w3) andb8 0w7 val reg = SSE2Reg rr in case opByte2 of 0wx10 => ( print "movss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx11 => ( print "movss\t"; printEAxmm(rex, SZDWord); print ","; print(xmmRegRepr reg) ) | 0wx2c => ( print "cvttss2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx2d => ( print "cvtss2si\t"; print (genRegRepr (mkReg(rr, rexR), sizeFromRexW)); print ","; printEAxmm(rex, sizeFromRexW) ) | 0wx5a => ( print "cvtss2sd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx58 => ( print "addss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx59 => ( print "mulss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx5c => ( print "subss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | 0wx5e => ( print "divss\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZDWord) ) | b => (print "F3\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | 0wx66 => (* SSE2 instruction *) let val nb = codeVecGet (seg, !ptr) val reg = SSE2Reg((nb >>- 0w3) andb8 0w7) in case opByte2 of 0wx2e => ( print "ucomisd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx54 => ( print "andpd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx57 => ( print "xorpd\t"; print(xmmRegRepr reg); print ","; printEAxmm(rex, SZQWord) ) | 0wx6e => ( print (if rexW then "movq\t" else "movd\t"); print(xmmRegRepr reg); print ","; printEA(rex, sizeFromRexW) ) | 0wx7e => ( print (if rexW then "movq\t" else "movd\t"); printEA(rex, sizeFromRexW); print ","; print(xmmRegRepr reg) ) | 0wx73 => ( print "psrldq\t"; printEAxmm(rex, SZQWord); print ","; print8 ()) | b => (print "66\n"; print "0F\n"; print(Word8.fmt StringCvt.HEX b)) end | _ => (print "esc\t"; printValue(Word8.toLargeInt opByte2)) end (* ESCAPE *) | 0wx13 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx1b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx23 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx2b => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx33 => printGvEv (opByte, rex, rexR, sizeFromRexW) | 0wx3b => printGvEv (opByte, rex, rexR, sizeFromRexW) (* Push and Pop. These are 64-bit on X86/64 whether there is REX prefix or not. *) | 0wx50 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx51 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx52 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx53 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx54 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx55 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx56 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx57 => print ("push\t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx58 => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx59 => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5a => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5b => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5c => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5d => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5e => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx5f => print ("pop \t" ^ genRegRepr (mkReg (opByte mod 0w8, rexB), sz32_64)) | 0wx63 => (* MOVSXD. This is ARPL in 32-bit mode but that's never used here. *) let val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "movsxd\t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, SZDWord) end | 0wx68 => (print "push\t"; print32 ()) | 0wx69 => let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print(genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW); print ","; print32 () end | 0wx6a => (print "push\t"; print8 ()) | 0wx6b => let (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "imul\t"; print(genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW); print ","; print8 () end | 0wx70 => (print "jo \t"; printJmp()) | 0wx71 => (print "jno \t"; printJmp()) | 0wx72 => (print "jb \t"; printJmp()) | 0wx73 => (print "jnb \t"; printJmp()) | 0wx74 => (print "je \t"; printJmp()) | 0wx75 => (print "jne \t"; printJmp()) | 0wx76 => (print "jna \t"; printJmp()) | 0wx77 => (print "ja \t"; printJmp()) | 0wx78 => (print "js \t"; printJmp()) | 0wx79 => (print "jns \t"; printJmp()) | 0wx7a => (print "jp \t"; printJmp()) | 0wx7b => (print "jnp \t"; printJmp()) | 0wx7c => (print "jl \t"; printJmp()) | 0wx7d => (print "jge \t"; printJmp()) | 0wx7e => (print "jle \t"; printJmp()) | 0wx7f => (print "jg \t"; printJmp()) | 0wx80 => (* Group1_8_a *) let (* Memory, byte constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, SZByte); print ","; print8 () end | 0wx81 => let (* Memory, 32-bit constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, sizeFromRexW); print ","; print32 () end | 0wx83 => let (* Word memory, 8-bit constant *) (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) in printArith ((nb div 8) mod 8); print "\t"; printEA(rex, sizeFromRexW); print ","; print8 () end | 0wx87 => let (* xchng *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "xchng \t"; printEA(rex, sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wx88 => let (* mov eb,gb i.e a store *) (* Register is in next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)); val reg = (nb div 8) mod 8; in print "mov \t"; printEA(rex, SZByte); print ","; if rexR then print ("r" ^ Int.toString(reg+8) ^ "B") else case reg of 0 => print "al" | 1 => print "cl" | 2 => print "dl" | 3 => print "bl" (* If there is a REX byte these select the low byte of the registers. *) | 4 => print (if rex = 0w0 then "ah" else "sil") | 5 => print (if rex = 0w0 then "ch" else "dil") | 6 => print (if rex = 0w0 then "dh" else "bpl") | 7 => print (if rex = 0w0 then "bh" else "spl") | _ => print ("r" ^ Int.toString reg) end | 0wx89 => let (* mov ev,gv i.e. a store *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "mov \t"; (* This may have an opcode prefix. *) printEA(rex, if legacyPrefix = 0wx66 then SZWord else sizeFromRexW); print ","; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)) end | 0wx8b => let (* mov gv,ev i.e. a load *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "mov \t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end | 0wx8d => let (* lea gv.M *) (* Register is in next byte. *) val nb = codeVecGet (seg, !ptr) val reg = (nb >>- 0w3) andb8 0w7 in print "lea \t"; print (genRegRepr (mkReg(reg, rexR), sizeFromRexW)); print ","; printEA(rex, sizeFromRexW) end | 0wx8f => (print "pop \t"; printEA(rex, sz32_64)) | 0wx90 => print "nop" | 0wx99 => if rexW then print "cqo" else print "cdq" | 0wx9e => print "sahf\n" | 0wxa4 => (if legacyPrefix = 0wxf3 then print "rep " else (); print "movsb") | 0wxa5 => (if legacyPrefix = 0wxf3 then print "rep " else (); print "movsl") | 0wxa6 => (if legacyPrefix = 0wxf3 then print "repe " else (); print "cmpsb") | 0wxa8 => (print "test\tal,"; print8 ()) | 0wxaa => (if legacyPrefix = 0wxf3 then print "rep " else (); print "stosb") | 0wxab => ( if legacyPrefix = 0wxf3 then print "rep " else (); if rexW then print "stosq" else print "stosl" ) | 0wxb8 => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxb9 => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxba => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbb => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbc => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbd => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbe => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxbf => printMovCToR (opByte, sizeFromRexW, rexB) | 0wxc1 => (* Group2_8_A *) printShift (opByte, rex, sizeFromRexW) | 0wxc2 => (print "ret \t"; print16 ()) | 0wxc3 => print "ret" | 0wxc6 => (* move 8-bit constant to memory *) ( print "mov \t"; printEA(rex, SZByte); print ","; print8 () ) | 0wxc7 => (* move 32/64-bit constant to memory *) ( print "mov \t"; printEA(rex, sizeFromRexW); print ","; print32 () ) | 0wxca => (* Register mask *) let val mask = get16u (!ptr, seg) before (ptr +:= 0w2) in print "SAVE\t"; printMask mask end | 0wxcd => (* Register mask *) let val mask = get8u (!ptr, seg) before (ptr +:= 0w1) in print "SAVE\t"; printMask(Word8.toInt mask) end | 0wxd1 => (* Group2_1_A *) printShift (opByte, rex, sizeFromRexW) | 0wxd3 => (* Group2_CL_A *) printShift (opByte, rex, sizeFromRexW) | 0wxd8 => printFloat (opByte, rex) (* Floating point escapes *) | 0wxd9 => printFloat (opByte, rex) | 0wxda => printFloat (opByte, rex) | 0wxdb => printFloat (opByte, rex) | 0wxdc => printFloat (opByte, rex) | 0wxdd => printFloat (opByte, rex) | 0wxde => printFloat (opByte, rex) | 0wxdf => printFloat (opByte, rex) | 0wxe8 => let (* 32-bit relative call. *) val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print "call\t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end | 0wxe9 => let (* 32-bit relative jump. *) val valu = get32s (!ptr, seg) before (ptr +:= 0w4) in print "jmp \t"; print (Word.fmt StringCvt.HEX (!ptr + Word.fromLargeInt valu)) end | 0wxeb => (print "jmp \t"; printJmp()) | 0wxf4 => print "hlt" (* Marker to indicate end-of-code. *) | 0wxf6 => (* Group3_a *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 0 => "test" | 3 => "neg" | _ => "???" ); print "\t"; printEA(rex, SZByte); if opc = 0 then (print ","; print8 ()) else () end | 0wxf7 => (* Group3_A *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 0 => "test" | 3 => "neg " | 4 => "mul " | 5 => "imul" | 6 => "div " | 7 => "idiv" | _ => "???" ); print "\t"; printEA(rex, sizeFromRexW); (* Test has an immediate operand. It's 32-bits even in 64-bit mode. *) if opc = 0 then (print ","; print32 ()) else () end | 0wxff => (* Group5 *) let (* Opcode is determined by next byte. *) val nb = Word8.toInt (codeVecGet (seg, !ptr)) val opc = (nb div 8) mod 8 in print (case opc of 2 => "call" | 4 => "jmp " | 6 => "push" | _ => "???" ); print "\t"; printEA(rex, sz32_64) (* None of the cases we use need a prefix. *) end | _ => print(Word8.fmt StringCvt.HEX opByte); print "\n" end; (* end of while loop *) print "\n" end (* printCode *); (* Although this is used locally it must be defined at the top level otherwise a new RTS function will be compiler every time the containing function is called *) val sortFunction: (machineWord * word) array -> bool = RunCall.rtsCallFast1 "PolySortArrayOfAddresses" (* This actually does the final code-generation. *) fun generateCode {ops=operations, code=cvec as Code{procName, printAssemblyCode, printStream, profileObject, ...}, labelCount, resultClosure} : unit = let val (expanded, newLabelCount) = expandComplexOperations (operations, labelCount) val () = printLowLevelCode(expanded, cvec) local val initialBytesList = codeGenerate expanded in (* Fixup labels and shrink long branches to short. *) val (bytesList, codeSize) = fixupLabels(expanded, initialBytesList, newLabelCount) end local (* Extract the constants and the location of the references from the code. *) val (inlineConstants, addressConstants, nonAddressConstants) = getConstants(expanded, bytesList) (* Sort the non-address constants to remove duplicates. There don't seem to be many in practice. Since we're not actually interested in the order but only sorting to remove duplicates we can use a stripped-down Quicksort. *) fun sort([], out) = out | sort((addr, median) :: tl, out) = partition(median, tl, [addr], [], [], out) and partition(median, [], addrs, less, greater, out) = sort(less, sort(greater, (addrs, median) :: out)) | partition(median, (entry as (addr, value)) :: tl, addrs, less, greater, out) = if value = median then partition(median, tl, addr::addrs, less, greater, out) else if value < median then partition(median, tl, addrs, entry :: less, greater, out) else partition(median, tl, addrs, less, entry :: greater, out) (* Non-address constants. We can't use any ordering on them because a GC could change the values half way through the sort. Instead we use a simple search for a small number of constants and use an RTS call for larger numbers. We want to avoid quadratic cost when there are large numbers. *) val sortedConstants = if List.length addressConstants < 10 then let fun findDups([], out) = out | findDups((addr, value) :: tl, out) = let fun partition(e as (a, v), (eq, neq)) = if PolyML.pointerEq(value, v) then (a :: eq, neq) else (eq, e :: neq) val (eqAddr, neq) = List.foldl partition ([addr], []) tl in findDups(neq, (eqAddr, value) :: out) end in findDups(addressConstants, []) end else let fun swap (a, b) = (b, a) val arrayToSort: (machineWord * word) array = Array.fromList (List.map swap addressConstants) val _ = sortFunction arrayToSort fun makeList((v, a), []) = [([a], v)] | makeList((v, a), l as (aa, vv) :: tl) = if PolyML.pointerEq(v, vv) then (a :: aa, vv) :: tl else ([a], v) :: l in Array.foldl makeList [] arrayToSort end in val inlineConstants = inlineConstants and addressConstants = sortedConstants and nonAddressConstants = sort(nonAddressConstants, []) end (* Get the number of constants that need to be added to the address area. *) val constsInConstArea = List.length addressConstants local (* Add one byte for the HLT and round up to a number of words. *) val endOfCode = (codeSize+nativeWordSize) div nativeWordSize * (nativeWordSize div wordSize) val numOfNonAddrWords = Word.fromInt(List.length nonAddressConstants) (* Each entry in the non-address constant area is 8 bytes. *) val intSize = 0w8 div wordSize in val endOfByteArea = endOfCode + numOfNonAddrWords * intSize (* +4 for function name, register mask (no longer used), profile object and count of constants. *) val segSize = endOfByteArea + Word.fromInt constsInConstArea + 0w4 end (* Create a byte vector and copy the data in. This is a byte area and not scanned by the GC so cannot contain any addresses. *) val byteVec = byteVecMake segSize val ic = ref 0w0 local fun genByte (ival: Word8.word) = set8u (ival, !ic, byteVec) before ic := !ic + 0w1 in fun genBytes l = Word8Vector.app (fn i => genByte i) l val () = List.app (fn b => genBytes b) bytesList val () = genBytes(Word8Vector.fromList(opCodeBytes(HLT, NONE))) (* Marker - this is used by ScanConstants in the RTS. *) end (* Align ic onto a fullword boundary. *) val () = ic := ((!ic + nativeWordSize - 0w1) andb ~nativeWordSize) (* Copy the non-address constants. These are only used in 64-bit mode and are either real constants or integers that are too large to fit in a 32-bit inline constants. We don't use this for real constants in 32-bit mode because we don't have relative addressing. Instead a real constant is the inline address of a boxed real number. *) local fun putNonAddrConst(addrs, constant) = let val addrOfConst = ! ic val () = genBytes(Word8Vector.fromList(largeWordToBytes(constant, 8))) fun setAddr addr = set32s(Word.toLargeInt(addrOfConst - addr - 0w4), addr, byteVec) in List.app setAddr addrs end in val () = List.app putNonAddrConst nonAddressConstants end val _ = bytesToWords(! ic) = endOfByteArea orelse raise InternalError "mismatch" (* Put in the number of constants. This must go in before we actually put in any constants. In 32-bit mode there are only three constants: the function name and the register mask, now unused and the profile object. All other constants are in the code. *) local val addr = wordsToBytes(endOfByteArea + 0w3 + Word.fromInt constsInConstArea) fun setBytes(_, _, 0) = () | setBytes(ival, offset, count) = ( byteVecSet(byteVec, offset, Word8.fromLargeInt(ival mod 256)); setBytes(ival div 256, offset+0w1, count-1) ) in val () = setBytes(LargeInt.fromInt(3 + constsInConstArea), addr, Word.toInt wordSize) end; (* We've put in all the byte data so it is safe to convert this to a mutable code cell that can contain addresses and will be scanned by the GC. *) val codeSeg = byteVecToCodeVec(byteVec, resultClosure) (* Various RTS functions assume that the first constant is the function name. The profiler assumes that the third word is the address of the mutable that contains the profile count. The second word used to be used for the register mask but is no longer used. *) val () = codeVecPutWord (codeSeg, endOfByteArea, toMachineWord procName) val () = codeVecPutWord (codeSeg, endOfByteArea + 0w1, toMachineWord 1 (* No longer used. *)) (* Next the profile object. *) val () = codeVecPutWord (codeSeg, endOfByteArea + 0w2, profileObject) in let fun setBytes(_, _, 0w0) = () | setBytes(b, addr, count) = ( codeVecSet (codeSeg, addr, wordToWord8 b); setBytes(b >> 0w8, addr+0w1, count-0w1) ) (* Inline constants - native 32-bit only, *) fun putInlConst (addrs, SelfAddress) = (* Self address goes inline. *) codeVecPutConstant (codeSeg, addrs, toMachineWord(codeVecAddr codeSeg), ConstAbsolute) | putInlConst (addrs, InlineAbsoluteAddress m) = codeVecPutConstant (codeSeg, addrs, m, ConstAbsolute) | putInlConst (addrs, InlineRelativeAddress m) = codeVecPutConstant (codeSeg, addrs, m, ConstX86Relative) val _ = List.app putInlConst inlineConstants (* Address constants - native 64-bit and 32-in-64. *) fun putAddrConst ((addrs, m), constAddr) = (* Put the constant in the constant area and set the original address to be the relative offset to the constant itself. *) ( codeVecPutWord (codeSeg, constAddr, m); (* Put in the 32-bit offset - always unsigned since the destination is after the reference. *) List.app(fn addr => setBytes(constAddr * wordSize - addr - 0w4, addr, 0w4)) addrs; constAddr+0w1 ) (* Put the constants. Any values in the constant area start at +3 i.e. after the profile. *) val _ = List.foldl putAddrConst (endOfByteArea+0w3) addressConstants val () = if printAssemblyCode then (* print out the code *) ( printCode(cvec, codeSeg); printStream "\n\n" ) else () in (* Finally lock the code. *) codeVecLock(codeSeg, resultClosure) end (* the result *) end (* generateCode *) structure Sharing = struct type code = code and reg = reg and genReg = genReg and fpReg = fpReg and addrs = addrs and operation = operation and regSet = RegSet.regSet and label = label and branchOps = branchOps - and callKinds = callKinds and arithOp = arithOp and shiftType = shiftType and repOps = repOps and fpOps = fpOps and fpUnaryOps = fpUnaryOps and sse2Operations = sse2Operations and opSize = opSize and closureRef = closureRef end end (* struct *) (* CODECONS *); diff --git a/polyexports.h b/polyexports.h index 11944504..526f4d6a 100644 --- a/polyexports.h +++ b/polyexports.h @@ -1,114 +1,114 @@ /* Title: polyexports.h - Copyright (c) 2006, 2011, 2015 David C.J. Matthews + Copyright (c) 2006, 2011, 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 header contains the structures used in saved state created by "export". */ #ifndef _STANDALONE_H #define _STANDALONE_H 1 // Get time_t #ifdef HAVE_TIME_H #include #endif // Get uintptr_t #if HAVE_STDINT_H # include #endif #if HAVE_INTTYPES_H # ifndef __STDC_FORMAT_MACROS # define __STDC_FORMAT_MACROS # endif # include #endif #ifdef HAVE_STDDEF_H # include #endif #if defined(HAVE_WINDOWS_H) # include #endif // There are several entries typedef struct _memTableEntry { void *mtCurrentAddr; // The address of the area of memory void *mtOriginalAddr; // The original address, for saved states and 32-in-64. uintptr_t mtLength; // The length in bytes of the area unsigned mtFlags; // Flags describing the area. unsigned mtIndex; // An index to identify permanent spaces. } memoryTableEntry; #define MTF_WRITEABLE 0x00000001 // The area is writeable by ML code #define MTF_EXECUTABLE 0x00000002 // The area contains executable code #define MTF_NO_OVERWRITE 0x00000004 // With MTF_WRITEABLE: Don't load over the top #define MTF_BYTES 0x00000008 // Contains only byte data and no addresses typedef struct _exportDescription { unsigned structLength; // The length of this structure unsigned memTableSize; // The size of each entry in the memory table unsigned memTableEntries; // The number of entries in the memory table memoryTableEntry *memTable; // Pointer to the memory table. void *rootFunction; // Points to the start-up function time_t timeStamp; // Creation time stamp unsigned architecture; // Machine architecture unsigned rtsVersion; // Run-time system version void *originalBaseAddr; // Original base address (32-in-64 only) } exportDescription; extern exportDescription poly_exports; #ifdef __cplusplus extern "C" { #endif -#if (defined(_WIN32) && ! defined(__CYGWIN__)) +#if (defined(_WIN32)) #include # ifdef LIBPOLYML_BUILD # ifdef DLL_EXPORT # define POLYLIB_API __declspec (dllexport) # endif # elif defined _MSC_VER // Visual C - POLYLIB_EXPORTS is defined in the library project settings # ifdef POLYLIB_EXPORTS # define POLYLIB_API __declspec (dllexport) # else # define POLYLIB_API __declspec (dllimport) # endif # elif defined DLL_EXPORT # define POLYLIB_API __declspec (dllimport) # else # define POLYLIB_API # endif extern POLYLIB_API int PolyWinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdShow, exportDescription *exports); #else int polymain(int argc, char *argv[], exportDescription *exports); #endif #ifdef __cplusplus }; #endif #endif diff --git a/polyimport.c b/polyimport.c index 69589e93..27d4689c 100644 --- a/polyimport.c +++ b/polyimport.c @@ -1,45 +1,45 @@ /* Title: polyimport.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 for importing a portable database. #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, 0); } #else int main(int argc, char *argv[]) { return polymain(argc, argv, 0); } #endif diff --git a/wininstall/PolyML.wxs b/wininstall/PolyML.wxs index 81413478..c5854d2d 100644 --- a/wininstall/PolyML.wxs +++ b/wininstall/PolyML.wxs @@ -1,195 +1,192 @@ - - - + + + - - - + + + + xmlns:util="http://schemas.microsoft.com/wix/UtilExtension"> - + = 600)]]> - - - + + + - + - - - - - - + + + - - + + - + - - - - - - - - + + + + + + + + - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + - - - + + + + - - + + - + - + - + diff --git a/wininstall/polyicon/polyicon.vcxproj b/wininstall/polyicon/polyicon.vcxproj index 1013b7cf..a23fbf7f 100644 --- a/wininstall/polyicon/polyicon.vcxproj +++ b/wininstall/polyicon/polyicon.vcxproj @@ -1,399 +1,399 @@  Debug32in64 Win32 Debug32in64 x64 Debug Win32 Int32in64Debug Win32 Int32in64Debug x64 Int32In64Release Win32 Int32In64Release x64 Release32in64 Win32 Release32in64 x64 Release Win32 Debug x64 Release x64 {D4DF6521-6183-4E24-A327-55C72519836E} Win32Proj polyicon - 10.0.15063.0 + 10.0 Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application true - v141 + v142 Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode Application false - v141 + v142 true Unicode true true true true true true false false false false false false NotUsing Level3 Disabled WIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true NotUsing Level3 Disabled WIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true NotUsing Level3 Disabled WIN32;_DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true NotUsing Level3 Disabled _DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true NotUsing Level3 Disabled _DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true NotUsing Level3 Disabled _DEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true Level3 NotUsing MaxSpeed true true WIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true Level3 NotUsing MaxSpeed true true WIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true Level3 NotUsing MaxSpeed true true WIN32;NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true Level3 NotUsing MaxSpeed true true NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true Level3 NotUsing MaxSpeed true true NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true Level3 NotUsing MaxSpeed true true NDEBUG;_WINDOWS;%(PreprocessorDefinitions) Windows true true true \ No newline at end of file