gcc/ada/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-2016, 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 package body System.Mmap.OS_Interface is
  36
  37    use Win;
  38
  39    function Align
  40      (Addr : File_Size) return File_Size;
  41    --  Align some offset/length to the lowest page boundary
  42
  43    function Open_Common
  44      (Filename              : String;
  45       Use_Mmap_If_Available : Boolean;
  46       Write                 : Boolean) return System_File;
  47
  48    function From_UTF8 (Path : String) return Wide_String;
  49    --  Convert from UTF-8 to Wide_String
  50
  51    ---------------
  52    -- From_UTF8 --
  53    ---------------
  54
  55    function From_UTF8 (Path : String) return Wide_String is
  56       function MultiByteToWideChar
  57         (Codepage : Interfaces.C.unsigned;
  58          Flags    : Interfaces.C.unsigned;
  59          Mbstr    : Address;
  60          Mb       : Natural;
  61          Wcstr    : Address;
  62          Wc       : Natural) return Integer;
  63       pragma Import (C, MultiByteToWideChar);
  64
  65       Current_Codepage : Interfaces.C.unsigned;
  66       pragma Import (C, Current_Codepage, "__gnat_current_codepage");
  67
  68       Len : Natural;
  69    begin
  70       --  Compute length of the result
  71       Len := MultiByteToWideChar
  72         (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0);
  73       if Len = 0 then
  74          raise Constraint_Error;
  75       end if;
  76
  77       declare
  78          --  Declare result
  79          Res : Wide_String (1 .. Len);
  80       begin
  81          --  And compute it
  82          Len := MultiByteToWideChar
  83            (Current_Codepage, 0,
  84             Path'Address, Path'Length,
  85             Res'Address, Len);
  86          if Len = 0 then
  87             raise Constraint_Error;
  88          end if;
  89          return Res;
  90       end;
  91    end From_UTF8;
  92
  93    -----------------
  94    -- Open_Common --
  95    -----------------
  96
  97    function Open_Common
  98      (Filename              : String;
  99       Use_Mmap_If_Available : Boolean;
 100       Write                 : Boolean) return System_File
 101    is
 102       dwDesiredAccess, dwShareMode : DWORD;
 103       PageFlags                    : DWORD;
 104
 105       W_Filename                   : constant Wide_String :=
 106          From_UTF8 (Filename) & Wide_Character'Val (0);
 107       File_Handle, Mapping_Handle  : HANDLE;
 108
 109       SizeH                        : aliased DWORD;
 110       Size                         : File_Size;
 111    begin
 112       if Write then
 113          dwDesiredAccess := GENERIC_READ + GENERIC_WRITE;
 114          dwShareMode     := 0;
 115          PageFlags       := Win.PAGE_READWRITE;
 116       else
 117          dwDesiredAccess := GENERIC_READ;
 118          dwShareMode     := Win.FILE_SHARE_READ;
 119          PageFlags       := Win.PAGE_READONLY;
 120       end if;
 121
 122       --  Actually open the file
 123
 124       File_Handle := CreateFile
 125         (W_Filename'Address, dwDesiredAccess, dwShareMode,
 126          null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0);
 127
 128       if File_Handle = Win.INVALID_HANDLE_VALUE then
 129          raise Ada.IO_Exceptions.Name_Error
 130            with "Cannot open " & Filename;
 131       end if;
 132
 133       --  Compute its size
 134
 135       Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access));
 136
 137       if Size = Win.INVALID_FILE_SIZE then
 138          raise Ada.IO_Exceptions.Use_Error;
 139       end if;
 140
 141       if SizeH /= 0 and then File_Size'Size > 32 then
 142          Size := Size + (File_Size (SizeH) * 2 ** 32);
 143       end if;
 144
 145       --  Then create a mapping object, if needed. On Win32, file memory
 146       --  mapping is always available.
 147
 148       if Use_Mmap_If_Available then
 149          Mapping_Handle :=
 150             Win.CreateFileMapping
 151               (File_Handle, null, PageFlags,
 152                0, DWORD (Size), Standard.System.Null_Address);
 153       else
 154          Mapping_Handle := Win.INVALID_HANDLE_VALUE;
 155       end if;
 156
 157       return
 158         (Handle         => File_Handle,
 159          Mapped         => Use_Mmap_If_Available,
 160          Mapping_Handle => Mapping_Handle,
 161          Write          => Write,
 162          Length         => Size);
 163    end Open_Common;
 164
 165    ---------------
 166    -- Open_Read --
 167    ---------------
 168
 169    function Open_Read
 170      (Filename              : String;
 171       Use_Mmap_If_Available : Boolean := True) return System_File is
 172    begin
 173       return Open_Common (Filename, Use_Mmap_If_Available, False);
 174    end Open_Read;
 175
 176    ----------------
 177    -- Open_Write --
 178    ----------------
 179
 180    function Open_Write
 181      (Filename              : String;
 182       Use_Mmap_If_Available : Boolean := True) return System_File is
 183    begin
 184       return Open_Common (Filename, Use_Mmap_If_Available, True);
 185    end Open_Write;
 186
 187    -----------
 188    -- Close --
 189    -----------
 190
 191    procedure Close (File : in out System_File) is
 192       Ignored : BOOL;
 193       pragma Unreferenced (Ignored);
 194    begin
 195       Ignored := CloseHandle (File.Mapping_Handle);
 196       Ignored := CloseHandle (File.Handle);
 197       File.Handle := Win.INVALID_HANDLE_VALUE;
 198       File.Mapping_Handle := Win.INVALID_HANDLE_VALUE;
 199    end Close;
 200
 201    --------------------
 202    -- Read_From_Disk --
 203    --------------------
 204
 205    function Read_From_Disk
 206      (File           : System_File;
 207       Offset, Length : File_Size) return System.Strings.String_Access
 208    is
 209       Buffer : String_Access := new String (1 .. Integer (Length));
 210
 211       Pos    : DWORD;
 212       NbRead : aliased DWORD;
 213       pragma Unreferenced (Pos);
 214    begin
 215       Pos := Win.SetFilePointer
 216         (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
 217
 218       if Win.ReadFile
 219          (File.Handle, Buffer.all'Address,
 220           DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE
 221       then
 222          System.Strings.Free (Buffer);
 223          raise Ada.IO_Exceptions.Device_Error;
 224       end if;
 225       return Buffer;
 226    end Read_From_Disk;
 227
 228    -------------------
 229    -- Write_To_Disk --
 230    -------------------
 231
 232    procedure Write_To_Disk
 233      (File           : System_File;
 234       Offset, Length : File_Size;
 235       Buffer         : System.Strings.String_Access)
 236    is
 237       Pos       : DWORD;
 238       NbWritten : aliased DWORD;
 239       pragma Unreferenced (Pos);
 240    begin
 241       pragma Assert (File.Write);
 242       Pos := Win.SetFilePointer
 243         (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
 244
 245       if Win.WriteFile
 246          (File.Handle, Buffer.all'Address,
 247           DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE
 248       then
 249          raise Ada.IO_Exceptions.Device_Error;
 250       end if;
 251    end Write_To_Disk;
 252
 253    --------------------
 254    -- Create_Mapping --
 255    --------------------
 256
 257    procedure Create_Mapping
 258      (File           : System_File;
 259       Offset, Length : in out File_Size;
 260       Mutable        : Boolean;
 261       Mapping        : out System_Mapping)
 262    is
 263       Flags : DWORD;
 264    begin
 265       if File.Write then
 266          Flags := Win.FILE_MAP_WRITE;
 267       elsif Mutable then
 268          Flags := Win.FILE_MAP_COPY;
 269       else
 270          Flags := Win.FILE_MAP_READ;
 271       end if;
 272
 273       --  Adjust offset and mapping length to account for the required
 274       --  alignment of offset on page boundary.
 275
 276       declare
 277          Queried_Offset : constant File_Size := Offset;
 278       begin
 279          Offset := Align (Offset);
 280
 281          --  First extend the length to compensate the offset shift, then align
 282          --  it on the upper page boundary, so that the whole queried area is
 283          --  covered.
 284
 285          Length := Length + Queried_Offset - Offset;
 286          Length := Align (Length + Get_Page_Size - 1);
 287
 288          --  But do not exceed the length of the file
 289          if Offset + Length > File.Length then
 290             Length := File.Length - Offset;
 291          end if;
 292       end;
 293
 294       if Length > File_Size (Integer'Last) then
 295          raise Ada.IO_Exceptions.Device_Error;
 296       else
 297          Mapping := Invalid_System_Mapping;
 298          Mapping.Address :=
 299             Win.MapViewOfFile
 300               (File.Mapping_Handle, Flags,
 301                0, DWORD (Offset), SIZE_T (Length));
 302          Mapping.Length := Length;
 303       end if;
 304    end Create_Mapping;
 305
 306    ---------------------
 307    -- Dispose_Mapping --
 308    ---------------------
 309
 310    procedure Dispose_Mapping
 311      (Mapping : in out System_Mapping)
 312    is
 313       Ignored : BOOL;
 314       pragma Unreferenced (Ignored);
 315    begin
 316       Ignored := Win.UnmapViewOfFile (Mapping.Address);
 317       Mapping := Invalid_System_Mapping;
 318    end Dispose_Mapping;
 319
 320    -------------------
 321    -- Get_Page_Size --
 322    -------------------
 323
 324    function Get_Page_Size return File_Size is
 325       SystemInfo : aliased SYSTEM_INFO;
 326    begin
 327       GetSystemInfo (SystemInfo'Unchecked_Access);
 328       return File_Size (SystemInfo.dwAllocationGranularity);
 329    end Get_Page_Size;
 330
 331    -----------
 332    -- Align --
 333    -----------
 334
 335    function Align
 336      (Addr : File_Size) return File_Size is
 337    begin
 338       return Addr - Addr mod Get_Page_Size;
 339    end Align;
 340
 341 end System.Mmap.OS_Interface;