File: gnatcoll-storage_pools-alignment.adb

package info (click to toggle)
libgnatcoll 18-4
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 5,068 kB
  • sloc: ada: 40,393; python: 354; ansic: 310; makefile: 245; sh: 31
file content (127 lines) | stat: -rw-r--r-- 5,481 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2005-2017, 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.                            --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- 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    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

with System.Storage_Pools;       use System, System.Storage_Pools;
with System.Storage_Elements;    use System.Storage_Elements;
with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;

package body GNATCOLL.Storage_Pools.Alignment is

   type Storage_Element_Access is access Storage_Element;
   function Convert is new Ada.Unchecked_Conversion
     (System.Address, Storage_Element_Access);

   --------------
   -- Allocate --
   --------------

   procedure Allocate
     (Pool         : in out Unbounded_No_Reclaim_Align_Pool;
      Address      : out System.Address;
      Storage_Size : Storage_Count;
      Alignment    : Storage_Count)
   is
      pragma Unreferenced (Alignment);

      --   We need to allocate more memory than actually requested, so that
      --   even if "new" returns an incorrect alignment, we have enough spare
      --   memory to return the correct alignment. We also always need a buffer
      --   of at least two Storage_Element to store the offset between the
      --   address from "new" and the one returned by the use, so that
      --   Deallocates works appropriately.
      --   Worst case is when "new" returned a correctly aligned chunk, and we
      --   then need to offset by Pool.Alignment bytes.

      Bytes_For_Offset : constant := 3;

      Align : constant Storage_Count  := Pool.Alignment;
      Size  : constant Storage_Offset :=
        Storage_Size + Align + Bytes_For_Offset - 1;

      subtype Local_Storage_Array is Storage_Array (1 .. Size);
      type Ptr is access Local_Storage_Array;

      Allocated : constant Ptr := new Local_Storage_Array;
      Offset    : constant Storage_Count :=
        Align - Allocated.all'Address mod Align;

   begin
      Allocated (Offset - 2) := Storage_Element (Offset / 65_536);
      Allocated (Offset - 1) := Storage_Element ((Offset mod 65_536) / 256);
      Allocated (Offset) := Storage_Element (Offset mod 256);
      Address := Allocated.all'Address + Offset;
   end Allocate;

   ----------------
   -- Deallocate --
   ----------------

   procedure Deallocate
     (Pool         : in out Unbounded_No_Reclaim_Align_Pool;
      Address      : System.Address;
      Storage_Size : Storage_Count;
      Alignment    : Storage_Count)
   is
      pragma Unreferenced (Alignment);

      Size : constant Storage_Offset :=
        Storage_Size + Pool.Alignment;
      subtype Local_Storage_Array is Storage_Array (1 .. Size);
      type Ptr is access Local_Storage_Array;

      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Local_Storage_Array, Ptr);
      function Convert is new Ada.Unchecked_Conversion
        (System.Address, Ptr);

      Offset_High2 : constant Storage_Element := Convert (Address - 3).all;
      Offset_High  : constant Storage_Element := Convert (Address - 2).all;
      Offset_Low   : constant Storage_Element := Convert (Address - 1).all;
      Offset : constant Storage_Count :=
         Storage_Count (Offset_High2) * 65_536
         + Storage_Count (Offset_High) * 256
         + Storage_Count (Offset_Low);

      Real_Address : constant System.Address := Address - Offset;
      Var : Ptr := Convert (Real_Address);

   begin
      Unchecked_Free (Var);
   end Deallocate;

   ------------------
   -- Storage_Size --
   ------------------

   function Storage_Size
     (Pool  : Unbounded_No_Reclaim_Align_Pool) return Storage_Count
   is
      pragma Unreferenced (Pool);
   begin
      --  Intuitively, should return System.Memory_Size. But on Sun/Alsys,
      --  System.Memory_Size > System.Max_Int, which means all you can do with
      --  it is raise CONSTRAINT_ERROR...
      return Storage_Count'Last;
   end Storage_Size;
end GNATCOLL.Storage_Pools.Alignment;