gcc/ada/libgnat/s-mmosin__mingw.adb

   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-2024, 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
  32 with Ada.IO_Exceptions;
  33 with System.Strings; use System.Strings;
  34
  35 with System.OS_Lib;
  36 pragma Unreferenced (System.OS_Lib);
  37 --  Only used to generate same runtime dependencies and same binder file on
  38 --  GNU/Linux and Windows.
  39
  40 package 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
 345 end System.Mmap.OS_Interface;