1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--              S Y S T E M . M M A P . O S _ I N T E R F A C E             --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--                     Copyright (C) 2007-2020, AdaCore                     --
10--                                                                          --
11-- This library is free software;  you can redistribute it and/or modify it --
12-- under terms of the  GNU General Public License  as published by the Free --
13-- Software  Foundation;  either version 3,  or (at your  option) any later --
14-- version. This library is distributed in the hope that it will be useful, --
15-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
16-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with Ada.IO_Exceptions;
33with System.Strings; use System.Strings;
34
35with System.OS_Lib;
36pragma Unreferenced (System.OS_Lib);
37--  Only used to generate same runtime dependencies and same binder file on
38--  GNU/Linux and Windows.
39
40package body System.Mmap.OS_Interface is
41
42   use Win;
43
44   function Align
45     (Addr : File_Size) return File_Size;
46   --  Align some offset/length to the lowest page boundary
47
48   function Open_Common
49     (Filename              : String;
50      Use_Mmap_If_Available : Boolean;
51      Write                 : Boolean) return System_File;
52
53   function From_UTF8 (Path : String) return Wide_String;
54   --  Convert from UTF-8 to Wide_String
55
56   ---------------
57   -- From_UTF8 --
58   ---------------
59
60   function From_UTF8 (Path : String) return Wide_String is
61      function MultiByteToWideChar
62        (Codepage : Interfaces.C.unsigned;
63         Flags    : Interfaces.C.unsigned;
64         Mbstr    : Address;
65         Mb       : Natural;
66         Wcstr    : Address;
67         Wc       : Natural) return Integer;
68      pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar");
69
70      Current_Codepage : Interfaces.C.unsigned;
71      pragma Import (C, Current_Codepage, "__gnat_current_codepage");
72
73      Len : Natural;
74   begin
75      --  Compute length of the result
76      Len := MultiByteToWideChar
77        (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0);
78      if Len = 0 then
79         raise Constraint_Error;
80      end if;
81
82      declare
83         --  Declare result
84         Res : Wide_String (1 .. Len);
85      begin
86         --  And compute it
87         Len := MultiByteToWideChar
88           (Current_Codepage, 0,
89            Path'Address, Path'Length,
90            Res'Address, Len);
91         if Len = 0 then
92            raise Constraint_Error;
93         end if;
94         return Res;
95      end;
96   end From_UTF8;
97
98   -----------------
99   -- Open_Common --
100   -----------------
101
102   function Open_Common
103     (Filename              : String;
104      Use_Mmap_If_Available : Boolean;
105      Write                 : Boolean) return System_File
106   is
107      dwDesiredAccess, dwShareMode : DWORD;
108      PageFlags                    : DWORD;
109
110      W_Filename                   : constant Wide_String :=
111         From_UTF8 (Filename) & Wide_Character'Val (0);
112      File_Handle, Mapping_Handle  : HANDLE;
113
114      SizeH                        : aliased DWORD;
115      Size                         : File_Size;
116   begin
117      if Write then
118         dwDesiredAccess := GENERIC_READ + GENERIC_WRITE;
119         dwShareMode     := 0;
120         PageFlags       := Win.PAGE_READWRITE;
121      else
122         dwDesiredAccess := GENERIC_READ;
123         dwShareMode     := Win.FILE_SHARE_READ;
124         PageFlags       := Win.PAGE_READONLY;
125      end if;
126
127      --  Actually open the file
128
129      File_Handle := CreateFile
130        (W_Filename'Address, dwDesiredAccess, dwShareMode,
131         null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0);
132
133      if File_Handle = Win.INVALID_HANDLE_VALUE then
134         return Invalid_System_File;
135      end if;
136
137      --  Compute its size
138
139      Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access));
140
141      if Size = Win.INVALID_FILE_SIZE then
142         return Invalid_System_File;
143      end if;
144
145      if SizeH /= 0 and then File_Size'Size > 32 then
146         Size := Size + (File_Size (SizeH) * 2 ** 32);
147      end if;
148
149      --  Then create a mapping object, if needed. On Win32, file memory
150      --  mapping is always available.
151
152      if Use_Mmap_If_Available then
153         Mapping_Handle :=
154            Win.CreateFileMapping
155              (File_Handle, null, PageFlags,
156               0, DWORD (Size), Standard.System.Null_Address);
157      else
158         Mapping_Handle := Win.INVALID_HANDLE_VALUE;
159      end if;
160
161      return
162        (Handle         => File_Handle,
163         Mapped         => Use_Mmap_If_Available,
164         Mapping_Handle => Mapping_Handle,
165         Write          => Write,
166         Length         => Size);
167   end Open_Common;
168
169   ---------------
170   -- Open_Read --
171   ---------------
172
173   function Open_Read
174     (Filename              : String;
175      Use_Mmap_If_Available : Boolean := True) return System_File is
176   begin
177      return Open_Common (Filename, Use_Mmap_If_Available, False);
178   end Open_Read;
179
180   ----------------
181   -- Open_Write --
182   ----------------
183
184   function Open_Write
185     (Filename              : String;
186      Use_Mmap_If_Available : Boolean := True) return System_File is
187   begin
188      return Open_Common (Filename, Use_Mmap_If_Available, True);
189   end Open_Write;
190
191   -----------
192   -- Close --
193   -----------
194
195   procedure Close (File : in out System_File) is
196      Ignored : BOOL;
197      pragma Unreferenced (Ignored);
198   begin
199      Ignored := CloseHandle (File.Mapping_Handle);
200      Ignored := CloseHandle (File.Handle);
201      File.Handle := Win.INVALID_HANDLE_VALUE;
202      File.Mapping_Handle := Win.INVALID_HANDLE_VALUE;
203   end Close;
204
205   --------------------
206   -- Read_From_Disk --
207   --------------------
208
209   function Read_From_Disk
210     (File           : System_File;
211      Offset, Length : File_Size) return System.Strings.String_Access
212   is
213      Buffer : String_Access := new String (1 .. Integer (Length));
214
215      Pos    : DWORD;
216      NbRead : aliased DWORD;
217      pragma Unreferenced (Pos);
218   begin
219      Pos := Win.SetFilePointer
220        (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
221
222      if Win.ReadFile
223         (File.Handle, Buffer.all'Address,
224          DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE
225      then
226         System.Strings.Free (Buffer);
227         raise Ada.IO_Exceptions.Device_Error;
228      end if;
229      return Buffer;
230   end Read_From_Disk;
231
232   -------------------
233   -- Write_To_Disk --
234   -------------------
235
236   procedure Write_To_Disk
237     (File           : System_File;
238      Offset, Length : File_Size;
239      Buffer         : System.Strings.String_Access)
240   is
241      Pos       : DWORD;
242      NbWritten : aliased DWORD;
243      pragma Unreferenced (Pos);
244   begin
245      pragma Assert (File.Write);
246      Pos := Win.SetFilePointer
247        (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
248
249      if Win.WriteFile
250         (File.Handle, Buffer.all'Address,
251          DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE
252      then
253         raise Ada.IO_Exceptions.Device_Error;
254      end if;
255   end Write_To_Disk;
256
257   --------------------
258   -- Create_Mapping --
259   --------------------
260
261   procedure Create_Mapping
262     (File           : System_File;
263      Offset, Length : in out File_Size;
264      Mutable        : Boolean;
265      Mapping        : out System_Mapping)
266   is
267      Flags : DWORD;
268   begin
269      if File.Write then
270         Flags := Win.FILE_MAP_WRITE;
271      elsif Mutable then
272         Flags := Win.FILE_MAP_COPY;
273      else
274         Flags := Win.FILE_MAP_READ;
275      end if;
276
277      --  Adjust offset and mapping length to account for the required
278      --  alignment of offset on page boundary.
279
280      declare
281         Queried_Offset : constant File_Size := Offset;
282      begin
283         Offset := Align (Offset);
284
285         --  First extend the length to compensate the offset shift, then align
286         --  it on the upper page boundary, so that the whole queried area is
287         --  covered.
288
289         Length := Length + Queried_Offset - Offset;
290         Length := Align (Length + Get_Page_Size - 1);
291
292         --  But do not exceed the length of the file
293         if Offset + Length > File.Length then
294            Length := File.Length - Offset;
295         end if;
296      end;
297
298      if Length > File_Size (Integer'Last) then
299         raise Ada.IO_Exceptions.Device_Error;
300      else
301         Mapping := Invalid_System_Mapping;
302         Mapping.Address :=
303            Win.MapViewOfFile
304              (File.Mapping_Handle, Flags,
305               0, DWORD (Offset), SIZE_T (Length));
306         Mapping.Length := Length;
307      end if;
308   end Create_Mapping;
309
310   ---------------------
311   -- Dispose_Mapping --
312   ---------------------
313
314   procedure Dispose_Mapping
315     (Mapping : in out System_Mapping)
316   is
317      Ignored : BOOL;
318      pragma Unreferenced (Ignored);
319   begin
320      Ignored := Win.UnmapViewOfFile (Mapping.Address);
321      Mapping := Invalid_System_Mapping;
322   end Dispose_Mapping;
323
324   -------------------
325   -- Get_Page_Size --
326   -------------------
327
328   function Get_Page_Size return File_Size is
329      SystemInfo : aliased SYSTEM_INFO;
330   begin
331      GetSystemInfo (SystemInfo'Unchecked_Access);
332      return File_Size (SystemInfo.dwAllocationGranularity);
333   end Get_Page_Size;
334
335   -----------
336   -- Align --
337   -----------
338
339   function Align
340     (Addr : File_Size) return File_Size is
341   begin
342      return Addr - Addr mod Get_Page_Size;
343   end Align;
344
345end System.Mmap.OS_Interface;
346