------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2007-2018, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, 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 MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.IO_Exceptions; with Ada.Unchecked_Conversion; with Interfaces.C; with System; use System; with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNATCOLL.Mmap.System is type Mmap_Prot is mod Interfaces.C.int'Last; for Mmap_Prot'Size use Interfaces.C.int'Size; -- PROT_NONE : constant Mmap_Prot := 16#00#; -- PROT_EXEC : constant Mmap_Prot := 16#04#; PROT_READ : constant Mmap_Prot := 16#01#; PROT_WRITE : constant Mmap_Prot := 16#02#; type Mmap_Flags is mod Interfaces.C.int'Last; for Mmap_Flags'Size use Interfaces.C.int'Size; -- MAP_NONE : constant Mmap_Flags := 16#00#; -- MAP_FIXED : constant Mmap_Flags := 16#10#; MAP_SHARED : constant Mmap_Flags := 16#01#; MAP_PRIVATE : constant Mmap_Flags := 16#02#; function From_Advice is new Ada.Unchecked_Conversion (Use_Advice, Interfaces.C.int); function Mmap (Start : Standard.System.Address := Null_Address; Length : File_Size; Prot : Mmap_Prot := PROT_READ; Flags : Mmap_Flags := MAP_PRIVATE; Fd : GNAT.OS_Lib.File_Descriptor; Offset : File_Size := 0) return Standard.System.Address; pragma Import (C, Mmap, "gnatcoll_mmap"); function Munmap (Start : Standard.System.Address; Length : File_Size) return Integer; pragma Import (C, Munmap, "gnatcoll_munmap"); procedure Madvise (Addr : Standard.System.Address; Length : File_Size; Advice : Use_Advice) with Inline; -- Allows a process that has knowledge of its memory behavior to -- describe it to the system. This advice applies to the mapped -- region at address Addr, and for the given Length. If Length -- is 0, this applies to the whole region. function Align (Addr : File_Size) return File_Size; -- Align some offset/length to the lowest page boundary function Is_Mapping_Available return Boolean; -- Wheter memory mapping is actually available on this system. It is an -- error to use Create_Mapping and Dispose_Mapping if this is False. ------------- -- Madvise -- ------------- procedure Madvise (Addr : Standard.System.Address; Length : File_Size; Advice : Use_Advice) is procedure Internal (Addr : Standard.System.Address; Length : File_Size; Advice : Interfaces.C.int); pragma Import (C, Internal, "gnatcoll_madvise"); begin Internal (Addr, Length, From_Advice (Advice)); end Madvise; --------------- -- Open_Read -- --------------- function Open_Read (Filename : String; Use_Mmap_If_Available : Boolean := True) return System_File is Fd : constant File_Descriptor := Open_Read (Filename, Binary); begin if Fd = Invalid_FD then raise Ada.IO_Exceptions.Name_Error with "Cannot open " & Filename; end if; return (Fd => Fd, Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, Write => False, Length => File_Size (File_Length (Fd))); end Open_Read; ---------------- -- Open_Write -- ---------------- function Open_Write (Filename : String; Use_Mmap_If_Available : Boolean := True) return System_File is Fd : constant File_Descriptor := Open_Read_Write (Filename, Binary); begin if Fd = Invalid_FD then raise Ada.IO_Exceptions.Name_Error with "Cannot open " & Filename; end if; return (Fd => Fd, Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, Write => True, Length => File_Size (File_Length (Fd))); end Open_Write; ----------- -- Close -- ----------- procedure Close (File : in out System_File) is begin Close (File.Fd); File.Fd := Invalid_FD; end Close; -------------------- -- Read_From_Disk -- -------------------- function Read_From_Disk (File : System_File; Offset, Length : File_Size) return GNAT.Strings.String_Access is Buffer : GNAT.Strings.String_Access := new String (1 .. Integer (Length)); begin -- ??? Lseek offset should be a size_t instead of a Long_Integer Lseek (File.Fd, Long_Integer (Offset), Seek_Set); if GNAT.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length)) /= Integer (Length) then GNAT.Strings.Free (Buffer); raise Ada.IO_Exceptions.Device_Error; end if; return Buffer; end Read_From_Disk; ------------------- -- Write_To_Disk -- ------------------- procedure Write_To_Disk (File : System_File; Offset, Length : File_Size; Buffer : GNAT.Strings.String_Access) is begin pragma Assert (File.Write); Lseek (File.Fd, Long_Integer (Offset), Seek_Set); if GNAT.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length)) /= Integer (Length) then raise Ada.IO_Exceptions.Device_Error; end if; end Write_To_Disk; -------------------- -- Create_Mapping -- -------------------- procedure Create_Mapping (File : System_File; Offset, Length : in out File_Size; Mutable : Boolean; Mapping : out System_Mapping; Advice : Use_Advice := Use_Normal) is Prot : Mmap_Prot; Flags : Mmap_Flags; begin if File.Write then Prot := PROT_READ or PROT_WRITE; Flags := MAP_SHARED; else Prot := PROT_READ; if Mutable then Prot := Prot or PROT_WRITE; end if; Flags := MAP_PRIVATE; end if; -- Adjust offset and mapping length to account for the required -- alignment of offset on page boundary. declare Queried_Offset : constant File_Size := Offset; begin Offset := Align (Offset); -- First extend the length to compensate the offset shift, then align -- it on the upper page boundary, so that the whole queried area is -- covered. Length := Length + Queried_Offset - Offset; Length := Align (Length + Get_Page_Size - 1); end; Mapping := (Address => Mmap (Offset => Offset, Length => Length, Prot => Prot, Flags => Flags, Fd => File.Fd), Length => Length); if Advice /= Use_Normal then Madvise (Mapping.Address, Length => 0, Advice => Advice); end if; end Create_Mapping; --------------------- -- Dispose_Mapping -- --------------------- procedure Dispose_Mapping (Mapping : in out System_Mapping) is Ignored : Integer; pragma Unreferenced (Ignored); begin Ignored := Munmap (Mapping.Address, Mapping.Length); Mapping := Invalid_System_Mapping; end Dispose_Mapping; -------------------------- -- Is_Mapping_Available -- -------------------------- function Is_Mapping_Available return Boolean is function Has_Mmap return Integer; pragma Import (C, Has_Mmap, "gnatcoll_has_mmap"); begin return Has_Mmap /= 0; end Is_Mapping_Available; ------------------- -- Get_Page_Size -- ------------------- function Get_Page_Size return File_Size is function Internal return Integer; pragma Import (C, Internal, "getpagesize"); begin return File_Size (Internal); end Get_Page_Size; ----------- -- Align -- ----------- function Align (Addr : File_Size) return File_Size is begin return Addr - Addr mod Get_Page_Size; end Align; end GNATCOLL.Mmap.System;