aboutsummaryrefslogtreecommitdiffstats
path: root/src/areapools.adb
blob: dd2e382576433a87cbcfb8cd4898ca55c8005c41 (plain)
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
--  Area based memory manager
--  Copyright (C) 2014 Tristan Gingold
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation, either version 2 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program.  If not, see <gnu.org/licenses>.

with Ada.Unchecked_Deallocation;

package body Areapools is
   procedure Deallocate is new Ada.Unchecked_Deallocation
     (Chunk_Type, Chunk_Acc);

   Free_Chunks : Chunk_Acc;

   function Get_Chunk return Chunk_Acc is
      Res : Chunk_Acc;
   begin
      if Free_Chunks /= null then
         Res := Free_Chunks;
         Free_Chunks := Res.Prev;
         return Res;
      else
         return new Chunk_Type (Default_Chunk_Size - 1);
      end if;
   end Get_Chunk;

   procedure Free_Chunk (Chunk : Chunk_Acc) is
   begin
      Chunk.Prev := Free_Chunks;
      Free_Chunks := Chunk;
   end Free_Chunk;

   procedure Allocate (Pool : in out Areapool;
                       Res : out Address;
                       Size : Size_Type;
                       Align : Size_Type)
   is
      Align_M1 : constant Size_Type := Align - 1;

      function Do_Align (X : Size_Type) return Size_Type is
      begin
         return (X + Align_M1) and not Align_M1;
      end Do_Align;

      Chunk : Chunk_Acc;
   begin
      --  Need to allocate a new chunk if there is no current chunk, or not
      --  enough room in the current chunk.
      if Pool.Last = null
        or else Do_Align (Pool.Next_Use) + Size > Pool.Last.Last
      then
         if Size > Default_Chunk_Size then
            Chunk := new Chunk_Type (Size - 1);
         else
            Chunk := Get_Chunk;
         end if;
         Chunk.Prev := Pool.Last;
         Pool.Next_Use := 0;
         if Pool.First = null then
            Pool.First := Chunk;
         end if;
         Pool.Last := Chunk;
      else
         Chunk := Pool.Last;
         Pool.Next_Use := Do_Align (Pool.Next_Use);
      end if;
      Res := Chunk.Data (Pool.Next_Use)'Address;
      Pool.Next_Use := Pool.Next_Use + Size;
   end Allocate;

   procedure Mark (M : out Mark_Type; Pool : Areapool) is
   begin
      M := (Last => Pool.Last, Next_Use => Pool.Next_Use);
   end Mark;

   procedure Release (M : Mark_Type; Pool : in out Areapool)
   is
      Chunk : Chunk_Acc;
      Prev : Chunk_Acc;
   begin
      Chunk := Pool.Last;
      while Chunk /= M.Last loop
         if Erase_When_Released then
            Chunk.Data := (others => 16#DE#);
         end if;

         Prev := Chunk.Prev;
         if Chunk.Last = Default_Chunk_Size - 1 then
            Free_Chunk (Chunk);
         else
            Deallocate (Chunk);
         end if;
         Chunk := Prev;
      end loop;

      if Erase_When_Released
        and then M.Last /= null
      then
         declare
            Last : Size_Type;
         begin
            if Pool.Last = M.Last then
               Last := Pool.Next_Use - 1;
            else
               Last := Chunk.Data'Last;
            end if;
            Chunk.Data (M.Next_Use .. Last) := (others => 16#DE#);
         end;
      end if;

      Pool.Last := M.Last;
      Pool.Next_Use := M.Next_Use;
   end Release;

   function Is_Empty (Pool : Areapool) return Boolean is
   begin
      return Pool.Last = null;
   end Is_Empty;

   function Alloc_On_Pool_Addr (Pool : Areapool_Acc; Val : T)
                               return System.Address
   is
      Res : Address;
   begin
      Allocate (Pool.all, Res, T'Size / Storage_Unit, T'Alignment);
      declare
         Addr1 : constant Address := Res;
         Init : T := Val;
         for Init'Address use Addr1;
      begin
         null;
      end;
      return Res;
   end Alloc_On_Pool_Addr;
end Areapools;