├── .github └── workflows │ └── main.yml ├── .gitignore ├── LICENSE ├── README.md ├── alire.toml ├── bbqueue.gpr ├── scripts ├── convert_invar.py └── pretty_counterexample.py ├── src ├── bbqueue-buffers-framed.adb ├── bbqueue-buffers-framed.ads ├── bbqueue-buffers.adb ├── bbqueue-buffers.ads ├── bbqueue.adb └── bbqueue.ads └── tests ├── .gitignore ├── alire.toml ├── src ├── main_buffer.adb ├── main_framed.adb └── main_offsets.adb └── tests.gpr /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | on: # Run the workflow for each of the following event: 2 | push: # - A branch is pushed or updated. 3 | pull_request: # - A pull-request is openned or updated. 4 | workflow_dispatch: # - A manual run of the workflow is requested from the GitHub web interface. 5 | release: 6 | types: [created] # - A release is created. 7 | 8 | jobs: 9 | linux-build: 10 | name: Build and test on Linux 11 | strategy: 12 | matrix: 13 | os: [ubuntu-latest] # [macos-latest, windows-latest, ubuntu-latest] 14 | runs-on: ${{ matrix.os }} 15 | env: 16 | BBQUEUE_COMPILE_CHECKS: enabled 17 | BBQUEUE_RUNTIME_CHECKS: enabled 18 | BBQUEUE_STYLE_CHECKS: enabled 19 | BBQUEUE_CONTRACTS: enabled 20 | 21 | steps: 22 | - uses: actions/checkout@v2 23 | - uses: alire-project/setup-alire@v1 24 | - uses: reviewdog/action-setup@v1 25 | 26 | - name: Alire build 27 | run: alr build 28 | 29 | - name: Test Build 30 | env: 31 | REVIEWDOG_GITHUB_API_TOKEN: ${{ secrets.GITHUB_TOKEN }} 32 | run: | 33 | cd tests/ 34 | status=0 35 | alr -q build > output.txt 2>&1 || status=$? 36 | cat output.txt 37 | cat output.txt | reviewdog -efm="%f:%l:%c: %m" -diff="git diff master" --reporter=github-pr-review 38 | # Check for errors 39 | if [ $status -ne 0 ]; then 40 | echo "ERROR: gprbuild returned $status" 41 | # This will cause the workflow to exit with $status 42 | bash -c "exit $status" 43 | fi 44 | - name: SPARK proof 45 | env: 46 | REVIEWDOG_GITHUB_API_TOKEN: ${{ secrets.GITHUB_TOKEN }} 47 | run: | 48 | cd tests/ 49 | status=0 50 | alr gnatprove -j0 --level=4 --checks-as-errors -cargs -gnatef > output.txt 2>&1 || status=$? 51 | cat output.txt 52 | cat output.txt | reviewdog -efm="%f:%l:%c: %m" -diff="git diff master" --reporter=github-pr-review 53 | # Check for errors 54 | if [ $status -ne 0 ]; then 55 | echo "ERROR: gnatprove returned $status" 56 | # This will cause the workflow to exit with $status 57 | bash -c "exit $status" 58 | fi 59 | - run: ./tests/obj/main_offsets 60 | - run: ./tests/obj/main_buffer 61 | - run: ./tests/obj/main_framed 62 | 63 | # Produce an Alire release manifest 64 | - name: Make Release Manifest 65 | if: (startsWith(matrix.os, 'ubuntu')) 66 | run: | 67 | # Set user GitHub login required for `alr publish` 68 | alr config --set --global user.github_login ${{github.repository_owner}} 69 | 70 | # Run Alire publish assistant 71 | alr publish ${{github.server_url}}/${{github.repository}} ${{github.sha}} 72 | 73 | # Save the path to the release manifest for the next step. 74 | # This is a little trick to get around the fact that the actions/upload-release-asset doesn't allow globing pattern. 75 | - name: Get Release Manifest PATH 76 | if: (github.event_name == 'release' && startsWith(matrix.os, 'ubuntu')) 77 | shell: bash 78 | run: | 79 | export MANIFEST_PATHNAME=$(ls alire/releases/*.toml | head -n 1) 80 | echo MANIFEST_PATHNAME=$MANIFEST_PATHNAME >> $GITHUB_ENV 81 | echo MANIFEST_NAME=$(basename $MANIFEST_PATHNAME) >> $GITHUB_ENV 82 | 83 | # If this worklow was triggered by a release event, upload the release manifest as a GitHub release asset. 84 | - name: Upload release manifest 85 | if: (github.event_name == 'release' && startsWith(matrix.os, 'ubuntu')) 86 | uses: actions/upload-release-asset@v1 87 | env: 88 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 89 | with: 90 | upload_url: ${{ github.event.release.upload_url }} 91 | asset_path: ${{ env.MANIFEST_PATHNAME }} 92 | asset_name: ${{ env.MANIFEST_NAME }} 93 | asset_content_type: application/toml 94 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object file 2 | *.o 3 | 4 | # Ada Library Information 5 | *.ali 6 | obj/ 7 | lib/ 8 | alire/ 9 | config/ 10 | alire.lock 11 | /obj/ 12 | /lib/ 13 | /alire/ 14 | /config/ 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Fabien Chouteau 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # bbqueue-SPARK 2 | ![Alire badge](https://img.shields.io/endpoint?url=https://alire.ada.dev/badges/bbqueue.json) 3 | 4 | An Ada/SPARK proved implementation of [James Munns' BBQueue](https://github.com/jamesmunns/bbqueue) 5 | 6 | `BBqueue` implements lock free, one producer one consumer, BipBuffers. 7 | 8 | The root package `BBqueue` only handles index offsets without having an 9 | internal buffer. It can be used to allocate slices of an existing array, e.g.: 10 | 11 | ```ada 12 | Buf : Storage_Array (8 .. 64) := (others => 0); 13 | Q : aliased Offsets_Only (Buf'Length); 14 | WG : Write_Grant := BBqueue.Empty; 15 | S : Slice_Rec; 16 | begin 17 | Grant (Q, WG, 8); 18 | if State (WG) = Valid then 19 | S := Slice (WG); 20 | Buf (Buf'First + S.From .. Buf'First + S.To) := (others => 42); 21 | end if; 22 | Commit (Q, WG); 23 | ``` 24 | 25 | The package `BBqueue.Buffers` is based on `BBqueue.Offsets_Only` and embeds an 26 | internal buffer. It provides directly usable slices of memory from its internal 27 | buffer: 28 | ```ada 29 | Q : aliased Buffer (64); 30 | WG : Write_Grant := Empty; 31 | S : Slice_Rec; 32 | begin 33 | Grant (Q, WG, 8); 34 | if State (WG) = Valid then 35 | declare 36 | B : Storage_Array (1 .. Slice (WG).Length) 37 | with Address => Slice (WG).Addr; 38 | begin 39 | B := (others => 42); 40 | end; 41 | end if; 42 | Commit (Q, WG); 43 | ``` 44 | 45 | The package `BBqueue.Buffers.Framed` is based on `BBqueue.Buffers` and uses 46 | markers in the buffer to track the size of each commited write grants. The size 47 | of consequent read grants will conrespond to the sizes of commited write 48 | grants. It can be used to handle variable lenght packets: 49 | ```ada 50 | Q : aliased Framed_Buffer (64); 51 | WG : Write_Grant := Empty; 52 | RG : Read_Grant := Empty; 53 | S : Slice_Rec; 54 | begin 55 | Grant (Q, WG, 8); -- Get a worst case grant of size 8 56 | Commit (Q, WG, 4); -- Only commit 4 57 | Grant (Q, WG, 8); -- Get a worst case grant of size 8 58 | Commit (Q, WG, 5); -- Only commit 5 59 | Read (W, RG); -- Returns a grant of size 4 60 | ``` 61 | -------------------------------------------------------------------------------- /alire.toml: -------------------------------------------------------------------------------- 1 | name = "bbqueue" 2 | description = "DMA friendly lock-free BipBuffer" 3 | version = "0.4.0-dev" 4 | 5 | licenses = "MIT" 6 | authors = ["Fabien Chouteau"] 7 | maintainers = ["Fabien Chouteau "] 8 | maintainers-logins = ["Fabien-Chouteau"] 9 | tags = ["spark", "nostd", "embedded", "lockfree", "dma", "bipbuffer"] 10 | website = "https://github.com/Fabien-Chouteau/bbqueue-spark" 11 | 12 | long-description = """An Ada/SPARK proved implementation of James Munns' 13 | BBQueue (https://github.com/jamesmunns/bbqueue)""" 14 | 15 | [build-switches] 16 | release.runtime_checks = "none" 17 | 18 | [[depends-on]] 19 | atomic = "~0.5" 20 | gnat = ">=10" 21 | -------------------------------------------------------------------------------- /bbqueue.gpr: -------------------------------------------------------------------------------- 1 | with "config/bbqueue_config.gpr"; 2 | project Bbqueue is 3 | 4 | for Library_Name use "Bbqueue"; 5 | for Library_Version use Project'Library_Name & ".so." & Bbqueue_Config.Crate_Version; 6 | 7 | for Source_Dirs use ("src/", "config/"); 8 | for Object_Dir use "obj/" & Bbqueue_Config.Build_Profile; 9 | for Create_Missing_Dirs use "True"; 10 | for Library_Dir use "lib"; 11 | 12 | type Library_Type_Type is ("relocatable", "static", "static-pic"); 13 | Library_Type : Library_Type_Type := 14 | external ("BBQUEUE_LIBRARY_TYPE", external ("LIBRARY_TYPE", "static")); 15 | for Library_Kind use Library_Type; 16 | 17 | package Compiler is 18 | for Default_Switches ("Ada") use Bbqueue_Config.Ada_Compiler_Switches; 19 | end Compiler; 20 | 21 | package Binder is 22 | for Switches ("Ada") use ("-Es"); -- Symbolic traceback 23 | end Binder; 24 | 25 | package Install is 26 | for Artifacts (".") use ("share"); 27 | end Install; 28 | 29 | end Bbqueue; 30 | -------------------------------------------------------------------------------- /scripts/convert_invar.py: -------------------------------------------------------------------------------- 1 | import fileinput 2 | import re 3 | 4 | print("pragma Assert (") 5 | for line in fileinput.input(): 6 | line = line.strip() 7 | line = line.replace("(Buffer", "(This") 8 | line = line.replace("Buf'Last", "This.Buf'Last") 9 | line = line.replace("Read)", "This.Read)") 10 | line = line.replace("Write)", "This.Write)") 11 | line = line.replace("(Last", "(This.Last") 12 | line = line.replace("Reserve", "This.Reserve") 13 | line = line.replace("Write_In_Progress", "This.Write_In_Progress") 14 | line = line.replace("Read_In_Progress", "This.Read_In_Progress") 15 | line = line.replace("Granted_Write_Size", "This.Granted_Write_Size") 16 | line = line.replace("Granted_Read_Size", "This.Granted_Read_Size") 17 | 18 | print(line); 19 | print(");") 20 | -------------------------------------------------------------------------------- /scripts/pretty_counterexample.py: -------------------------------------------------------------------------------- 1 | import fileinput 2 | import re 3 | 4 | for line in fileinput.input(): 5 | line = line.strip() 6 | if line.startswith("[Counterexample] "): 7 | line = line.strip("[Counterexample] ") 8 | # print(line) 9 | pattern = re.compile(r'([a-zA-Z_]+) => ([0-9]+)[,)]', re.IGNORECASE) 10 | value = {} 11 | for match in pattern.findall(line): 12 | value[match[0]] = int(match[1]) 13 | 14 | pattern = re.compile(r'This\.Buf\'Last = ([0-9]+)', re.IGNORECASE) 15 | all = pattern.findall(line) 16 | if all != []: 17 | value['Size'] = int(pattern.findall(line)[0]) 18 | pattern = re.compile(r'Max = ([0-9]+)', re.IGNORECASE) 19 | all = pattern.findall(line) 20 | if all != []: 21 | value['Size'] = int(pattern.findall(line)[0]) 22 | 23 | print(value) 24 | 25 | if 'Size' in value: 26 | print('|' + '-' * value['Size'] + '|') 27 | for key in ['Write', 'Read', 'Reserve', 'Last']: 28 | if key in value: 29 | print(' ' + ' ' * value[key] + key[0]) 30 | 31 | -------------------------------------------------------------------------------- /src/bbqueue-buffers-framed.adb: -------------------------------------------------------------------------------- 1 | package body BBqueue.Buffers.framed 2 | with SPARK_Mode 3 | is 4 | pragma Warnings (Off, "upper bound check only fails for invalid values"); 5 | 6 | pragma Compile_Time_Error ((Count'Object_Size mod System.Storage_Unit) /= 0, 7 | "Invalid Object_Size for Count"); 8 | 9 | procedure Write_Header (After_Hdr_Addr : System.Address; 10 | Hdr_Size : Header_Count; 11 | Value : Count); 12 | 13 | procedure Read_Header (Before_Hdr_Addr : System.Address; 14 | Hdr_Size : out Header_Count; 15 | Frame_Size : out Framed_Count) 16 | with Post => Hdr_Size = (Count'Object_Size / System.Storage_Unit); 17 | 18 | function Header_Size (Unused : Count) return Header_Count 19 | is (Count'Object_Size / System.Storage_Unit) 20 | 21 | with Post => Header_Size'Result in 1 .. 9; 22 | -- TODO: The size of the header can be optimized using variable-length 23 | -- encoding. 24 | 25 | ------------------ 26 | -- Write_Header -- 27 | ------------------ 28 | 29 | procedure Write_Header (After_Hdr_Addr : System.Address; 30 | Hdr_Size : Header_Count; 31 | Value : Count) 32 | is 33 | pragma SPARK_Mode (Off); 34 | Header : Count 35 | with Address => 36 | To_Address 37 | (To_Integer (After_Hdr_Addr) - Integer_Address (Hdr_Size)); 38 | begin 39 | Header := Value; 40 | end Write_Header; 41 | 42 | ----------------- 43 | -- Read_Header -- 44 | ----------------- 45 | 46 | procedure Read_Header (Before_Hdr_Addr : System.Address; 47 | Hdr_Size : out Header_Count; 48 | Frame_Size : out Framed_Count) 49 | is 50 | pragma SPARK_Mode (Off); 51 | Header : Count 52 | with Address => Before_Hdr_Addr; 53 | begin 54 | Frame_Size := Header; 55 | Hdr_Size := Header_Size (Frame_Size); 56 | end Read_Header; 57 | 58 | ----------- 59 | -- Grant -- 60 | ----------- 61 | 62 | procedure Grant (This : in out Framed_Buffer; 63 | G : in out Write_Grant; 64 | Size : Framed_Count) 65 | is 66 | Hdr_Size : constant Count := Header_Size (Size); 67 | begin 68 | if Size = 0 then 69 | BBqueue.Buffers.Grant (This.Buffer, G.Grant, Size); 70 | G.Header_Size := 0; 71 | return; 72 | end if; 73 | 74 | -- Save the worst case header size 75 | G.Header_Size := Hdr_Size; 76 | 77 | -- Request Size + worst case header size 78 | BBqueue.Buffers.Grant (This.Buffer, G.Grant, Size + Hdr_Size); 79 | 80 | if State (G) = Valid then 81 | 82 | pragma Assert (G.Grant.Slice.Length = Size + Hdr_Size); 83 | 84 | -- Change the slice to skip the header 85 | G.Grant.Slice.Length := G.Grant.Slice.Length - Hdr_Size; 86 | G.Grant.Slice.Addr := 87 | To_Address 88 | (To_Integer (G.Grant.Slice.Addr) + Integer_Address (Hdr_Size)); 89 | else 90 | -- Grant failed, no header 91 | G.Header_Size := 0; 92 | end if; 93 | end Grant; 94 | 95 | ------------ 96 | -- Commit -- 97 | ------------ 98 | 99 | procedure Commit (This : in out Framed_Buffer; 100 | G : in out Write_Grant; 101 | Size : Framed_Count := Framed_Count'Last) 102 | is 103 | begin 104 | if Size = 0 then 105 | -- Nothing to commit 106 | BBqueue.Buffers.Commit (This.Buffer, G.Grant, 0); 107 | else 108 | 109 | -- Write the header in the buffer 110 | Write_Header (Slice (G.Grant).Addr, G.Header_Size, Size); 111 | 112 | -- Commit header + data 113 | BBqueue.Buffers.Commit (This.Buffer, G.Grant, Size + G.Header_Size); 114 | end if; 115 | 116 | if State (G) = Empty then 117 | G.Header_Size := 0; 118 | end if; 119 | end Commit; 120 | 121 | -------------- 122 | -- Write_CB -- 123 | -------------- 124 | 125 | procedure Write_CB 126 | (This : in out Framed_Buffer; 127 | Size : Framed_Count; 128 | Result : out Result_Kind) 129 | is 130 | G : Write_Grant := Empty; 131 | begin 132 | Grant (This, G, Size); 133 | Result := State (G); 134 | 135 | if Result = Valid then 136 | declare 137 | S : constant Slice_Rec := Slice (G); 138 | B : Storage_Array (1 .. S.Length) 139 | with Address => S.Addr; 140 | To_Commit : Count; 141 | begin 142 | Process_Write (B, To_Commit); 143 | 144 | Commit (This, G, To_Commit); 145 | 146 | pragma Assert (State (G) = Empty); 147 | end; 148 | end if; 149 | end Write_CB; 150 | 151 | ---------- 152 | -- Read -- 153 | ---------- 154 | 155 | procedure Read (This : in out Framed_Buffer; G : in out Read_Grant) is 156 | Frame_Size : Framed_Count; 157 | Hdr_Size : Header_Count; 158 | begin 159 | BBqueue.Buffers.Read (This.Buffer, G.Grant); 160 | 161 | if State (G) = Valid then 162 | 163 | -- Get header size and value from the buffer 164 | Read_Header (Slice (G.Grant).Addr, Hdr_Size, Frame_Size); 165 | G.Header_Size := Hdr_Size; 166 | 167 | -- Change the slice to skip the header and set the actuall value of 168 | -- the frame. 169 | G.Grant.Slice.Length := Frame_Size; 170 | G.Grant.Slice.Addr := 171 | To_Address 172 | (To_Integer (G.Grant.Slice.Addr) + Integer_Address (Hdr_Size)); 173 | 174 | This.Current_Read_Size := Frame_Size; 175 | end if; 176 | end Read; 177 | 178 | ------------- 179 | -- Release -- 180 | ------------- 181 | 182 | procedure Release (This : in out Framed_Buffer; G : in out Read_Grant) is 183 | begin 184 | BBqueue.Buffers.Release (This.Buffer, 185 | G.Grant, 186 | G.Header_Size + This.Current_Read_Size); 187 | G.Header_Size := 0; 188 | end Release; 189 | 190 | ------------- 191 | -- Read_CB -- 192 | ------------- 193 | 194 | procedure Read_CB (This : in out Framed_Buffer; Result : out Result_Kind) is 195 | G : Read_Grant := Empty; 196 | 197 | procedure Call_CB (Addr : System.Address; 198 | Length : Framed_Count); 199 | 200 | procedure Call_CB (Addr : System.Address; 201 | Length : Framed_Count) 202 | is 203 | pragma SPARK_Mode (Off); 204 | B : Storage_Array (1 .. Length) 205 | with Address => Addr; 206 | begin 207 | Process_Read (B); 208 | end Call_CB; 209 | 210 | begin 211 | Read (This, G); 212 | Result := State (G); 213 | 214 | if Result = Valid then 215 | Call_CB (Slice (G).Addr, This.Current_Read_Size); 216 | 217 | Release (This, G); 218 | 219 | pragma Assert (State (G) = Empty); 220 | end if; 221 | end Read_CB; 222 | 223 | end BBqueue.Buffers.framed; 224 | -------------------------------------------------------------------------------- /src/bbqueue-buffers-framed.ads: -------------------------------------------------------------------------------- 1 | -- This unit is based on BBqueue.Buffers and uses markers in the buffer to 2 | -- track the size of each commited write grants. The size of consequent read 3 | -- grants will conrespond to the sizes of commited write grants. 4 | -- 5 | -- It can be used to handle variable lenght packets: 6 | -- 7 | -- Q : aliased Framed_Buffer (64); 8 | -- WG : Write_Grant := Empty; 9 | -- RG : Read_Grant := Empty; 10 | -- S : Slice_Rec; 11 | -- begin 12 | -- Grant (Q, WG, 8); -- Get a worst case grant of size 8 13 | -- Commit (Q, WG, 4); -- Only commit 4 14 | -- Grant (Q, WG, 8); -- Get a worst case grant of size 8 15 | -- Commit (Q, WG, 5); -- Only commit 5 16 | -- Read (W, RG); -- Returns a grant of size 4 17 | 18 | with System; 19 | 20 | package BBqueue.Buffers.framed 21 | with Preelaborate, 22 | SPARK_Mode, 23 | Abstract_State => null 24 | is 25 | 26 | Max_Frame_Header_Size : constant := 9; 27 | 28 | subtype Framed_Count 29 | is Count range Count'First .. Count'Last - Max_Frame_Header_Size; 30 | -- The frame can take up to 9 bytes in addition to the allocated size. The 31 | -- size of what can be allocated is therefore lower than for a non-framed 32 | -- buffer. 33 | 34 | type Framed_Buffer (Size : Buffer_Size) 35 | is limited private; 36 | 37 | -- Producer -- 38 | 39 | type Write_Grant is limited private; 40 | 41 | procedure Grant (This : in out Framed_Buffer; 42 | G : in out Write_Grant; 43 | Size : Framed_Count) 44 | with Pre => State (G) /= Valid, 45 | Post => State (G) in Valid | Empty | Grant_In_Progress | 46 | Insufficient_Size 47 | and then 48 | (if State (G) = Valid then Write_Grant_In_Progress (This)); 49 | -- Request a contiguous writeable slice of the internal buffer 50 | 51 | procedure Commit (This : in out Framed_Buffer; 52 | G : in out Write_Grant; 53 | Size : Framed_Count := Framed_Count'Last) 54 | with Pre => State (G) = Valid, 55 | Post => (if Write_Grant_In_Progress (This)'Old 56 | then State (G) = Empty 57 | else State (G) = Valid); 58 | -- Commit a writeable slice. Size can be smaller than the granted slice for 59 | -- partial commits. The commited slice is then available for Read. 60 | 61 | generic 62 | with procedure Process_Write (Data : out Storage_Array; 63 | To_Commit : out Count); 64 | procedure Write_CB (This : in out Framed_Buffer; 65 | Size : Framed_Count; 66 | Result : out Result_Kind); 67 | -- Write in the buffer using a "callback". This procedure will call 68 | -- Process_Write () on the slice returned by Grant (), if the result 69 | -- is Valid. It will then call Commit with the value To_Commit returned by 70 | -- Process_Write (). 71 | 72 | -- Consumer -- 73 | 74 | type Read_Grant is limited private; 75 | 76 | procedure Read (This : in out Framed_Buffer; 77 | G : in out Read_Grant) 78 | with Pre => State (G) /= Valid, 79 | Post => State (G) in Valid | Empty | Grant_In_Progress 80 | and then 81 | (if State (G) = Valid then Read_Grant_In_Progress (This)); 82 | -- Request contiguous readable slice from the internal buffer. The size of 83 | -- the returned Read_Grant will be based on the size of previously commited 84 | -- frames. 85 | 86 | procedure Release (This : in out Framed_Buffer; 87 | G : in out Read_Grant) 88 | with Pre => State (G) = Valid, 89 | Post => (if Read_Grant_In_Progress (This)'Old 90 | then State (G) = Empty 91 | else State (G) = Valid); 92 | -- Release a readable slice. Partial releases not allowed, the full grant 93 | -- will be released. 94 | 95 | generic 96 | with procedure Process_Read (Data : Storage_Array); 97 | procedure Read_CB (This : in out Framed_Buffer; 98 | Result : out Result_Kind); 99 | -- Read from the buffer using a "callback". This procedure will call 100 | -- Process_Read () on the slice returned by Read (), if the result is 101 | -- Valid. 102 | 103 | -- Utils -- 104 | 105 | function Empty return Write_Grant 106 | with Post => State (Empty'Result) = Empty; 107 | function Empty return Read_Grant 108 | with Post => State (Empty'Result) = Empty; 109 | 110 | function State (G : Write_Grant) return Result_Kind; 111 | function Slice (G : Write_Grant) return Slice_Rec 112 | with Pre => State (G) = Valid; 113 | 114 | function State (G : Read_Grant) return Result_Kind; 115 | function Slice (G : Read_Grant) return Slice_Rec 116 | with Pre => State (G) = Valid; 117 | 118 | function Write_Grant_In_Progress (This : Framed_Buffer) return Boolean 119 | with Ghost; 120 | function Read_Grant_In_Progress (This : Framed_Buffer) return Boolean 121 | with Ghost; 122 | 123 | private 124 | 125 | subtype Header_Count is Framed_Count range 0 .. Max_Frame_Header_Size; 126 | 127 | type Framed_Buffer (Size : Buffer_Size) is limited record 128 | Buffer : BBqueue.Buffers.Buffer (Size); 129 | 130 | Current_Read_Size : Framed_Count := 0; 131 | -- This stores the size of the current read frame, between Read and 132 | -- Release. It is used to prove that the release size (Header_Size + 133 | -- Current_Read_Size) doesn't overflow. 134 | end record; 135 | 136 | function Empty_Slicerec return Slice_Rec 137 | is (0, System.Null_Address); 138 | 139 | type Write_Grant is limited record 140 | Grant : BBqueue.Buffers.Write_Grant; 141 | Header_Size : Header_Count := 0; 142 | end record; 143 | 144 | type Read_Grant is limited record 145 | Grant : BBqueue.Buffers.Read_Grant; 146 | Header_Size : Header_Count := 0; 147 | end record; 148 | 149 | function State (G : Write_Grant) return Result_Kind 150 | is (BBqueue.Buffers.State (G.Grant)); 151 | function Empty return Write_Grant 152 | is (Grant => BBqueue.Buffers.Empty, others => <>); 153 | function Slice (G : Write_Grant) return Slice_Rec 154 | is (BBqueue.Buffers.Slice (G.Grant)); 155 | 156 | function State (G : Read_Grant) return Result_Kind 157 | is (BBqueue.Buffers.State (G.Grant)); 158 | function Empty return Read_Grant 159 | is (Grant => BBqueue.Buffers.Empty, others => <>); 160 | function Slice (G : Read_Grant) return Slice_Rec 161 | is (BBqueue.Buffers.Slice (G.Grant)); 162 | 163 | ----------------------------- 164 | -- Write_Grant_In_Progress -- 165 | ----------------------------- 166 | 167 | function Write_Grant_In_Progress (This : Framed_Buffer) return Boolean 168 | is (Write_Grant_In_Progress (This.Buffer)); 169 | 170 | ---------------------------- 171 | -- Read_Grant_In_Progress -- 172 | ---------------------------- 173 | 174 | function Read_Grant_In_Progress (This : Framed_Buffer) return Boolean 175 | is (Read_Grant_In_Progress (This.Buffer)); 176 | 177 | end BBqueue.Buffers.framed; 178 | -------------------------------------------------------------------------------- /src/bbqueue-buffers.adb: -------------------------------------------------------------------------------- 1 | package body BBqueue.Buffers 2 | with SPARK_Mode 3 | is 4 | 5 | pragma Warnings (Off, "lower bound test optimized away"); 6 | 7 | function Get_Addr (This : Buffer; 8 | Offset : Buffer_Offset) 9 | return System.Address 10 | with Pre => Offset in 0 .. This.Buf'Last - 1; 11 | 12 | -------------- 13 | -- Get_Addr -- 14 | -------------- 15 | 16 | function Get_Addr (This : Buffer; 17 | Offset : Buffer_Offset) 18 | return System.Address 19 | is 20 | pragma SPARK_Mode (Off); 21 | begin 22 | return This.Buf (This.Buf'First + Offset)'Address; 23 | end Get_Addr; 24 | 25 | ----------- 26 | -- Grant -- 27 | ----------- 28 | 29 | procedure Grant (This : in out Buffer; 30 | G : in out Write_Grant; 31 | Size : Count) 32 | is 33 | begin 34 | BBqueue.Grant (This.Offsets, G.Offsets_Grant, Size); 35 | 36 | if G.Offsets_Grant.Result = Valid then 37 | G.Slice.Length := G.Offsets_Grant.Slice.Length; 38 | G.Slice.Addr := Get_Addr (This, G.Offsets_Grant.Slice.From); 39 | end if; 40 | end Grant; 41 | 42 | ------------ 43 | -- Commit -- 44 | ------------ 45 | 46 | procedure Commit 47 | (This : in out Buffer; G : in out Write_Grant; Size : Count := Count'Last) 48 | is 49 | begin 50 | BBqueue.Commit (This.Offsets, G.Offsets_Grant, Size); 51 | end Commit; 52 | 53 | -------------- 54 | -- Write_CB -- 55 | -------------- 56 | 57 | procedure Write_CB (This : in out Buffer; 58 | Size : Count; 59 | Result : out Result_Kind) 60 | is 61 | G : Write_Grant := Empty; 62 | begin 63 | Grant (This, G, Size); 64 | Result := State (G); 65 | 66 | if Result = Valid then 67 | declare 68 | S : constant BBqueue.Slice_Rec := BBqueue.Slice (G.Offsets_Grant); 69 | B : Storage_Array renames This.Buf; 70 | To_Commit : Count; 71 | begin 72 | Process_Write (B (B'First + S.From .. B'First + S.To), 73 | To_Commit); 74 | 75 | Commit (This, G, To_Commit); 76 | 77 | pragma Assert (State (G) = Empty); 78 | end; 79 | end if; 80 | end Write_CB; 81 | 82 | ---------- 83 | -- Read -- 84 | ---------- 85 | 86 | procedure Read (This : in out Buffer; 87 | G : in out Read_Grant; 88 | Max : Count := Count'Last) 89 | is 90 | begin 91 | BBqueue.Read (This.Offsets, G.Offsets_Grant, Max); 92 | 93 | if G.Offsets_Grant.Result = Valid then 94 | G.Slice.Length := G.Offsets_Grant.Slice.Length; 95 | G.Slice.Addr := Get_Addr (This, G.Offsets_Grant.Slice.From); 96 | end if; 97 | end Read; 98 | 99 | ------------- 100 | -- Release -- 101 | ------------- 102 | 103 | procedure Release 104 | (This : in out Buffer; G : in out Read_Grant; Size : Count := Count'Last) 105 | is 106 | begin 107 | BBqueue.Release (This.Offsets, G.Offsets_Grant, Size); 108 | end Release; 109 | 110 | ------------- 111 | -- Read_CB -- 112 | ------------- 113 | 114 | procedure Read_CB (This : in out Buffer; 115 | Result : out Result_Kind) 116 | is 117 | pragma SPARK_Mode (Off); 118 | 119 | G : Read_Grant := Empty; 120 | begin 121 | Read (This, G); 122 | Result := State (G); 123 | 124 | if Result = Valid then 125 | declare 126 | S : constant BBqueue.Slice_Rec := BBqueue.Slice (G.Offsets_Grant); 127 | B : Storage_Array renames This.Buf; 128 | To_Release : Count; 129 | begin 130 | Process_Read (B (B'First + S.From .. B'First + S.To), 131 | To_Release); 132 | 133 | Release (This, G, To_Release); 134 | 135 | pragma Assert (State (G) = Empty); 136 | end; 137 | end if; 138 | 139 | end Read_CB; 140 | 141 | end BBqueue.Buffers; 142 | -------------------------------------------------------------------------------- /src/bbqueue-buffers.ads: -------------------------------------------------------------------------------- 1 | -- This unit is based on BBqueue.Offsets_Only and embeds an internal buffer. 2 | -- It provides directly usable slices of memory from its internal buffer: 3 | -- 4 | -- Q : aliased Buffer (64); 5 | -- WG : Write_Grant := Empty; 6 | -- S : Slice_Rec; 7 | -- begin 8 | -- Grant (Q, WG, 8); 9 | -- if State (WG) = Valid then 10 | -- declare 11 | -- B : Storage_Array (1 .. Slice (WG).Length) 12 | -- with Address => Slice (WG).Addr; 13 | -- begin 14 | -- B := (others => 42); 15 | -- end; 16 | -- Commit (Q, WG); 17 | -- end if; 18 | 19 | with System; 20 | 21 | package BBqueue.Buffers 22 | with Preelaborate, 23 | SPARK_Mode, 24 | Abstract_State => null 25 | is 26 | 27 | type Buffer (Size : Buffer_Size) 28 | is limited private; 29 | 30 | -- Producer -- 31 | 32 | type Write_Grant is limited private; 33 | 34 | procedure Grant (This : in out Buffer; 35 | G : in out Write_Grant; 36 | Size : Count) 37 | with Global => null, 38 | Pre => State (G) /= Valid, 39 | Post => State (G) in Valid | Empty | Grant_In_Progress | 40 | Insufficient_Size 41 | and then 42 | (if Size = 0 then State (G) = Empty) 43 | and then 44 | (if State (G) = Valid 45 | then Write_Grant_In_Progress (This) 46 | and then Slice (G).Length = Size); 47 | -- Request a contiguous writeable slice of the internal buffer 48 | 49 | procedure Commit (This : in out Buffer; 50 | G : in out Write_Grant; 51 | Size : Count := Count'Last) 52 | with Pre => State (G) = Valid, 53 | Post => (if Write_Grant_In_Progress (This)'Old 54 | then State (G) = Empty 55 | else State (G) = Valid); 56 | -- Commit a writeable slice. Size can be smaller than the granted slice for 57 | -- partial commits. The commited slice is then available for Read. 58 | 59 | generic 60 | with procedure Process_Write (Data : out Storage_Array; 61 | To_Commit : out Count); 62 | procedure Write_CB (This : in out Buffer; 63 | Size : Count; 64 | Result : out Result_Kind); 65 | -- Write in the buffer using a "callback". This procedure will call 66 | -- Process_Write () on the slice returned by Grant (), if the result 67 | -- is Valid. It will then call Commit with the value To_Commit returned by 68 | -- Process_Write (). 69 | 70 | -- Consumer -- 71 | 72 | type Read_Grant is limited private; 73 | 74 | procedure Read (This : in out Buffer; 75 | G : in out Read_Grant; 76 | Max : Count := Count'Last) 77 | with Pre => State (G) /= Valid, 78 | Post => State (G) in Valid | Empty | Grant_In_Progress 79 | and then 80 | (if State (G) = Valid 81 | then Read_Grant_In_Progress (This) 82 | and then Slice (G).Length <= Max); 83 | -- Request contiguous readable slice of up to Max elements from the 84 | -- internal buffer. 85 | 86 | procedure Release (This : in out Buffer; 87 | G : in out Read_Grant; 88 | Size : Count := Count'Last) 89 | with Pre => State (G) = Valid, 90 | Post => (if Read_Grant_In_Progress (This)'Old 91 | then State (G) = Empty 92 | else State (G) = Valid); 93 | -- Release a readable slice. Size can be smaller than the granted slice for 94 | -- partial releases. 95 | 96 | generic 97 | with procedure Process_Read (Data : Storage_Array; 98 | To_Release : out Count); 99 | procedure Read_CB (This : in out Buffer; 100 | Result : out Result_Kind); 101 | -- Read from the buffer using a "callback". This procedure will call 102 | -- Process_Read () on the slice returned by Read (), if the result is 103 | -- Valid. It will then call Release with the value To_Release returned 104 | -- by Process_Read (). 105 | 106 | -- Utils -- 107 | 108 | function Empty return Write_Grant 109 | with Post => State (Empty'Result) = Empty; 110 | function Empty return Read_Grant 111 | with Post => State (Empty'Result) = Empty; 112 | 113 | -- Slices -- 114 | 115 | type Slice_Rec is record 116 | Length : Count; 117 | Addr : System.Address; 118 | end record; 119 | 120 | function State (G : Write_Grant) return Result_Kind; 121 | function Slice (G : Write_Grant) return Slice_Rec 122 | with Pre => State (G) = Valid; 123 | 124 | function State (G : Read_Grant) return Result_Kind; 125 | function Slice (G : Read_Grant) return Slice_Rec 126 | with Pre => State (G) = Valid; 127 | 128 | function Write_Grant_In_Progress (This : Buffer) return Boolean 129 | with Ghost; 130 | function Read_Grant_In_Progress (This : Buffer) return Boolean 131 | with Ghost; 132 | 133 | private 134 | 135 | type Buffer (Size : Buffer_Size) is limited record 136 | Buf : Storage_Array (1 .. Size) := (others => 0); 137 | Offsets : Offsets_Only (Size); 138 | end record; 139 | 140 | function Empty_Slicerec return Slice_Rec 141 | is (0, System.Null_Address); 142 | 143 | type Write_Grant is limited record 144 | Offsets_Grant : BBqueue.Write_Grant; 145 | Slice : Slice_Rec := (0, System.Null_Address); 146 | end record; 147 | 148 | type Read_Grant is limited record 149 | Offsets_Grant : BBqueue.Read_Grant; 150 | Slice : Slice_Rec := (0, System.Null_Address); 151 | end record; 152 | 153 | function State (G : Write_Grant) return Result_Kind 154 | is (G.Offsets_Grant.Result); 155 | function Empty return Write_Grant 156 | is (Offsets_Grant => BBqueue.Empty, others => <>); 157 | function Slice (G : Write_Grant) return Slice_Rec 158 | is (G.Slice); 159 | 160 | function State (G : Read_Grant) return Result_Kind 161 | is (G.Offsets_Grant.Result); 162 | function Empty return Read_Grant 163 | is (Offsets_Grant => BBqueue.Empty, others => <>); 164 | function Slice (G : Read_Grant) return Slice_Rec 165 | is (G.Slice); 166 | 167 | ----------------------------- 168 | -- Write_Grant_In_Progress -- 169 | ----------------------------- 170 | 171 | function Write_Grant_In_Progress (This : Buffer) return Boolean 172 | is (BBqueue.Write_Grant_In_Progress (This.Offsets)); 173 | 174 | ---------------------------- 175 | -- Read_Grant_In_Progress -- 176 | ---------------------------- 177 | 178 | function Read_Grant_In_Progress (This : Buffer) return Boolean 179 | is (BBqueue.Read_Grant_In_Progress (This.Offsets)); 180 | 181 | end BBqueue.Buffers; 182 | -------------------------------------------------------------------------------- /src/bbqueue.adb: -------------------------------------------------------------------------------- 1 | -- with Ada.Text_IO; use Ada.Text_IO; 2 | 3 | with Atomic; use Atomic; 4 | 5 | package body BBqueue 6 | with SPARK_Mode => On 7 | is 8 | 9 | ----------- 10 | -- Grant -- 11 | ----------- 12 | 13 | procedure Grant (This : in out Offsets_Only; 14 | G : in out Write_Grant; 15 | Size : Count) 16 | is 17 | Read, Write, Start : Count; 18 | Max : constant Count := This.Size; 19 | Already_Inverted : Boolean; 20 | In_Progress : Boolean; 21 | 22 | begin 23 | 24 | if Size = 0 then 25 | G.Result := Empty; 26 | G.Slice := Empty_Slice; 27 | return; 28 | end if; 29 | 30 | Test_And_Set (This.Write_In_Progress, In_Progress, Acq_Rel); 31 | 32 | if In_Progress then 33 | G.Result := Grant_In_Progress; 34 | G.Slice := Empty_Slice; 35 | return; 36 | end if; 37 | 38 | if Size > This.Size then 39 | Clear (This.Write_In_Progress, Release); 40 | G.Result := Insufficient_Size; 41 | G.Slice := Empty_Slice; 42 | return; 43 | end if; 44 | 45 | -- Writer component. Must never write to `read`, 46 | -- be careful writing to `load` 47 | Write := Atomic_Count.Load (This.Write, Acquire); 48 | Read := Atomic_Count.Load (This.Read, Acquire); 49 | Already_Inverted := Write < Read; 50 | 51 | if Already_Inverted then 52 | 53 | -- The original comparison is ((Write + Size) < Read), it is modified 54 | -- to avoid integer overflow. 55 | if Count'Last - Size >= Write 56 | and then 57 | (Write + Size) < Read 58 | then 59 | -- Inverted, room is still available 60 | Start := Write; 61 | else 62 | -- Inverted, no room is available 63 | Clear (This.Write_In_Progress, Release); 64 | G.Result := Insufficient_Size; 65 | G.Slice := Empty_Slice; 66 | This.Granted_Write_Size := 0; 67 | 68 | return; 69 | end if; 70 | 71 | else 72 | 73 | -- The original comparison is ((Write + Size) <= Max), it is modified 74 | -- to avoid integer overflow. 75 | if Count'Last - Size >= Write 76 | and then 77 | (Write + Size) <= Max 78 | then 79 | -- Non inverted condition 80 | Start := Write; 81 | else 82 | -- Not inverted, but need to go inverted 83 | 84 | -- NOTE: We check Size < Read, NOT <=, because 85 | -- write must never == read in an inverted condition, since 86 | -- we will then not be able to tell if we are inverted or not 87 | if Size < Read then 88 | Start := 0; 89 | else 90 | -- Inverted, no room is available 91 | Clear (This.Write_In_Progress, Release); 92 | G.Result := Insufficient_Size; 93 | G.Slice := Empty_Slice; 94 | This.Granted_Write_Size := 0; 95 | return; 96 | end if; 97 | 98 | end if; 99 | end if; 100 | 101 | -- This is what we want to prove: the granted slice is in the writeable 102 | -- area. 103 | pragma Assert (Size /= 0); 104 | pragma Assert (In_Writable_Area (This, Start)); 105 | pragma Assert (In_Writable_Area (This, Start + Size - 1)); 106 | 107 | Atomic_Count.Store (This.Reserve, Start + Size, Release); 108 | 109 | This.Granted_Write_Size := Size; 110 | 111 | G.Result := Valid; 112 | G.Slice := (Size, Start, Start + Size - 1); 113 | end Grant; 114 | 115 | ------------ 116 | -- Commit -- 117 | ------------ 118 | 119 | procedure Commit (This : in out Offsets_Only; 120 | G : in out Write_Grant; 121 | Size : Count := Count'Last) 122 | is 123 | Used, Write, Last, New_Write : Count; 124 | Max : constant Count := This.Size; 125 | Len : constant Count := This.Granted_Write_Size; 126 | begin 127 | -- If there is no grant in progress, return early. This 128 | -- generally means we are dropping the grant within a 129 | -- wrapper structure 130 | if not Set (This.Write_In_Progress, Acquire) then 131 | return; 132 | end if; 133 | 134 | -- Writer component. Must never write to READ, 135 | -- be careful writing to LAST 136 | 137 | -- Saturate the grant commit 138 | Used := Count'Min (Len, Size); 139 | Write := Atomic_Count.Load (This.Write, Acquire); 140 | 141 | Atomic_Count.Sub (This.Reserve, Len - Used, Acq_Rel); 142 | 143 | Last := Atomic_Count.Load (This.Last, Acquire); 144 | New_Write := Atomic_Count.Load (This.Reserve, Acquire); 145 | 146 | if (New_Write < Write) and then (Write /= Max) then 147 | 148 | -- We have already wrapped, but we are skipping some bytes at the 149 | -- end of the ring. Mark `last` where the write pointer used to be 150 | -- to hold the line here 151 | Atomic_Count.Store (This.Last, Write, Release); 152 | 153 | elsif New_Write > Last then 154 | -- We're about to pass the last pointer, which was previously the 155 | -- artificial end of the ring. Now that we've passed it, we can 156 | -- "unlock" the section that was previously skipped. 157 | -- 158 | -- Since new_write is strictly larger than last, it is safe to move 159 | -- this as the other thread will still be halted by the (about to be 160 | -- updated) write value 161 | Atomic_Count.Store (This.Last, Max, Release); 162 | end if; 163 | -- else: If new_write == last, either: 164 | -- * last == max, so no need to write, OR 165 | -- * If we write in the end chunk again, we'll update last to max next 166 | -- time 167 | -- * If we write to the start chunk in a wrap, we'll update last when we 168 | -- move write backwards 169 | 170 | -- Write must be updated AFTER last, otherwise read could think it was 171 | -- time to invert early! 172 | Atomic_Count.Store (This.Write, New_Write, Release); 173 | 174 | -- Nothing granted anymore 175 | This.Granted_Write_Size := 0; 176 | 177 | G.Result := Empty; 178 | G.Slice := Empty_Slice; 179 | 180 | -- Allow subsequent grants 181 | Clear (This.Write_In_Progress, Release); 182 | 183 | end Commit; 184 | 185 | ---------- 186 | -- Read -- 187 | ---------- 188 | 189 | procedure Read (This : in out Offsets_Only; 190 | G : in out Read_Grant; 191 | Max : Count := Count'Last) 192 | is 193 | Read, Write, Last, Size : Count; 194 | In_Progress : Boolean; 195 | begin 196 | 197 | Test_And_Set (This.Read_In_Progress, In_Progress, Acq_Rel); 198 | if In_Progress then 199 | G.Result := Grant_In_Progress; 200 | G.Slice := Empty_Slice; 201 | return; 202 | end if; 203 | 204 | Write := Atomic_Count.Load (This.Write, Acquire); 205 | Read := Atomic_Count.Load (This.Read, Acquire); 206 | Last := Atomic_Count.Load (This.Last, Acquire); 207 | 208 | -- Resolve the inverted case or end of read 209 | if Read = Last and then Write < Read then 210 | Read := 0; 211 | -- This has some room for error, the other thread reads this 212 | -- Impact to Grant: 213 | -- Grant checks if read < write to see if inverted. If not 214 | -- inverted, but no space left, Grant will initiate an inversion, 215 | -- but will not trigger it 216 | -- Impact to Commit: 217 | -- Commit does not check read, but if Grant has started an 218 | -- inversion, grant could move Last to the prior write position 219 | -- MOVING READ BACKWARDS! 220 | Atomic_Count.Store (This.Read, 0, Release); 221 | end if; 222 | 223 | Size := (if Write < Read then Last - Read else Write - Read); 224 | 225 | -- Bound the slice with the maximum size requested by the user 226 | Size := Count'Min (Size, Max); 227 | 228 | if Size = 0 then 229 | Clear (This.Read_In_Progress); 230 | G.Result := Empty; 231 | G.Slice := Empty_Slice; 232 | return; 233 | end if; 234 | 235 | -- This is what we want to prove: the granted slice is in the readable 236 | -- area. 237 | pragma Assert (Size /= 0); 238 | pragma Assert (In_Readable_Area (This, Read)); 239 | pragma Assert (In_Readable_Area (This, Read + Size - 1)); 240 | 241 | This.Granted_Read_Size := Size; 242 | 243 | G.Result := Valid; 244 | G.Slice := (Size, Read, Read + Size - 1); 245 | end Read; 246 | 247 | ------------- 248 | -- Release -- 249 | ------------- 250 | 251 | procedure Release (This : in out Offsets_Only; 252 | G : in out Read_Grant; 253 | Size : Count := Count'Last) 254 | is 255 | Used : Count; 256 | begin 257 | -- Saturate the grant commit 258 | Used := Count'Min (This.Granted_Read_Size, Size); 259 | 260 | -- If there is no grant in progress, return early. This 261 | -- generally means we are dropping the grant within a 262 | -- wrapper structure 263 | if not Set (This.Read_In_Progress, Acquire) then 264 | return; 265 | end if; 266 | 267 | -- This should always be checked by the public interfaces 268 | -- debug_assert! (used <= self.buf.len ()); 269 | 270 | -- This should be fine, purely incrementing 271 | Atomic_Count.Add (This.Read, Used, Release); 272 | 273 | -- Nothing granted anymore 274 | This.Granted_Read_Size := 0; 275 | 276 | G.Result := Empty; 277 | G.Slice := Empty_Slice; 278 | 279 | -- Allow subsequent read 280 | Clear (This.Read_In_Progress, Release); 281 | end Release; 282 | 283 | end BBqueue; 284 | -------------------------------------------------------------------------------- /src/bbqueue.ads: -------------------------------------------------------------------------------- 1 | -- Based on James Munns' https://github.com/jamesmunns/bbqueue 2 | -- 3 | -- BBqueue implements lock free, one producer one consumer, BipBuffers. 4 | -- 5 | -- This unit only handles index offsets without having an internal buffer. 6 | -- It can be used to allocate slices of an existing array, e.g.: 7 | -- 8 | -- Buf : Storage_Array (8 .. 64) := (others => 0); 9 | -- Q : aliased Offsets_Only (Buf'Length); 10 | -- WG : Write_Grant := BBqueue.Empty; 11 | -- S : Slice_Rec; 12 | -- begin 13 | -- Grant (Q, WG, 8); 14 | -- if State (WG) = Valid then 15 | -- S := Slice (WG); 16 | -- Buf (Buf'First + S.From .. Buf'First + S.To) := (others => 42); 17 | -- Commit (Q, WG); 18 | -- end if; 19 | 20 | with System.Storage_Elements; use System.Storage_Elements; 21 | 22 | private with Atomic; 23 | private with Atomic.Signed; 24 | 25 | package BBqueue 26 | with Preelaborate, 27 | SPARK_Mode, 28 | Abstract_State => null 29 | is 30 | pragma Warnings (Off, "lower bound check only fails if it is invalid"); 31 | 32 | type Result_Kind is (Valid, Grant_In_Progress, Insufficient_Size, Empty); 33 | 34 | subtype Count is Storage_Count; 35 | subtype Buffer_Size is Count range 1 .. Count'Last; 36 | subtype Buffer_Offset is Storage_Offset range 0 .. Count'Last - 1; 37 | 38 | type Offsets_Only (Size : Buffer_Size) is limited private; 39 | 40 | -- Producer -- 41 | 42 | type Write_Grant is limited private; 43 | 44 | procedure Grant (This : in out Offsets_Only; 45 | G : in out Write_Grant; 46 | Size : Count) 47 | with Pre => State (G) /= Valid, 48 | Post => State (G) in Valid | Empty | Grant_In_Progress | 49 | Insufficient_Size 50 | and then 51 | (if Size = 0 then State (G) = Empty) 52 | and then 53 | (if State (G) = Valid 54 | then Write_Grant_In_Progress (This) 55 | and then Slice (G).Length = Size 56 | and then Valid_Slice (This, Slice (G)) 57 | and then Valid_Write_Slice (This, Slice (G))); 58 | -- Request indexes of a contiguous writeable slice of exactly Size elements 59 | 60 | procedure Commit (This : in out Offsets_Only; 61 | G : in out Write_Grant; 62 | Size : Count := Count'Last) 63 | with Pre => State (G) = Valid, 64 | Post => (if Write_Grant_In_Progress (This)'Old 65 | then State (G) = Empty 66 | else State (G) = Valid); 67 | -- Commit a writeable slice. Size can be smaller than the granted slice for 68 | -- partial commits. The commited slice is then available for Read. 69 | 70 | -- Consumer -- 71 | 72 | type Read_Grant is limited private; 73 | 74 | procedure Read (This : in out Offsets_Only; 75 | G : in out Read_Grant; 76 | Max : Count := Count'Last) 77 | with Pre => State (G) /= Valid, 78 | Post => State (G) in Valid | Empty | Grant_In_Progress 79 | and then 80 | (if State (G) = Valid 81 | then Read_Grant_In_Progress (This) 82 | and then Slice (G).Length <= Max 83 | and then Valid_Slice (This, Slice (G)) 84 | and then Valid_Read_Slice (This, Slice (G))); 85 | -- Request indexes of a contiguous readable slice of up to Max elements 86 | 87 | procedure Release (This : in out Offsets_Only; 88 | G : in out Read_Grant; 89 | Size : Count := Count'Last) 90 | with Pre => State (G) = Valid, 91 | Post => (if Read_Grant_In_Progress (This)'Old 92 | then State (G) = Empty 93 | else State (G) = Valid); 94 | -- Release a readable slice. Size can be smaller than the granted slice for 95 | -- partial releases. 96 | 97 | -- Utils -- 98 | 99 | function Empty return Write_Grant 100 | with Post => State (Empty'Result) = Empty; 101 | function Empty return Read_Grant 102 | with Post => State (Empty'Result) = Empty; 103 | 104 | -- Slices -- 105 | 106 | type Slice_Rec is record 107 | Length : Count; 108 | From : Buffer_Offset; 109 | To : Buffer_Offset; 110 | end record; 111 | 112 | function State (G : Write_Grant) return Result_Kind; 113 | function Slice (G : Write_Grant) return Slice_Rec 114 | with Pre => State (G) = Valid; 115 | 116 | function State (G : Read_Grant) return Result_Kind; 117 | function Slice (G : Read_Grant) return Slice_Rec 118 | with Pre => State (G) = Valid; 119 | 120 | -- Contract helpers -- 121 | 122 | function Valid_Slice (This : Offsets_Only; Slice : Slice_Rec) return Boolean 123 | is (Slice.From <= Slice.To 124 | and then Slice.Length = Slice.To - Slice.From + 1 125 | and then Slice.From in 0 .. This.Size - 1 126 | and then Slice.To in 0 .. This.Size - 1) 127 | with Ghost; 128 | -- A valid slice contains offsets within the bounds of the array range. 129 | -- This ensures that: 130 | -- Arr (Arr'First + Start_Offset .. Arr'First + End_Offset) 131 | -- will never be out of bounds. 132 | 133 | function Valid_Write_Slice (This : Offsets_Only; 134 | Slice : Slice_Rec) 135 | return Boolean 136 | with Ghost; 137 | 138 | function Valid_Read_Slice (This : Offsets_Only; 139 | Slice : Slice_Rec) 140 | return Boolean 141 | with Ghost; 142 | 143 | function Write_Grant_In_Progress (This : Offsets_Only) 144 | return Boolean 145 | with Ghost; 146 | 147 | function Read_Grant_In_Progress (This : Offsets_Only) 148 | return Boolean 149 | with Ghost; 150 | 151 | private 152 | 153 | function In_Readable_Area (This : Offsets_Only; 154 | Offset : Buffer_Offset) 155 | return Boolean 156 | with Ghost; 157 | 158 | function In_Writable_Area (This : Offsets_Only; 159 | Offset : Buffer_Offset) 160 | return Boolean 161 | with Ghost; 162 | 163 | package Atomic_Count 164 | is new Atomic.Signed (System.Storage_Elements.Storage_Count); 165 | use Atomic_Count; 166 | 167 | type Offsets_Only (Size : Buffer_Size) is limited record 168 | Write : aliased Atomic_Count.Instance := Atomic_Count.Init (0); 169 | -- Where the next byte will be written 170 | 171 | Read : aliased Atomic_Count.Instance := Atomic_Count.Init (0); 172 | -- Where the next byte will be read from 173 | 174 | Last : aliased Atomic_Count.Instance := Atomic_Count.Init (0); 175 | -- Used in the inverted case to mark the end of the 176 | -- readable streak. Otherwise will == sizeof::(). 177 | -- Writer is responsible for placing this at the correct 178 | -- place when entering an inverted condition, and Reader 179 | -- is responsible for moving it back to sizeof::() 180 | -- when exiting the inverted condition 181 | -- 182 | -- Cooperatively owned 183 | -- 184 | -- NOTE: This should generally be initialized as size_of::(), 185 | -- however this would prevent the structure from being entirely 186 | -- zero-initialized, and can cause the .data section to be much larger 187 | -- than necessary. By forcing the `last` pointer to be zero initially, 188 | -- we place the structure in an "inverted" condition, which will 189 | -- be resolved on the first commited bytes that are written to the 190 | -- structure. 191 | -- 192 | -- When read == last == write, no bytes will be allowed to be read 193 | -- (good), but write grants can be given out (also good). 194 | 195 | Reserve : aliased Atomic_Count.Instance := Atomic_Count.Init (0); 196 | -- Used by the Writer to remember what bytes are currently 197 | -- allowed to be written to, but are not yet ready to be 198 | -- read from 199 | 200 | Read_In_Progress : aliased Atomic.Flag := Atomic.Init (False); 201 | -- Is there an active read grant? 202 | 203 | Write_In_Progress : aliased Atomic.Flag := Atomic.Init (False); 204 | -- Is there an active write grant? 205 | 206 | Granted_Write_Size : Count := 0; 207 | Granted_Read_Size : Count := 0; 208 | end record 209 | with Invariant => 210 | Value (Write) in 0 .. Size 211 | and then Value (Read) in 0 .. Size 212 | and then Value (Last) in 0 .. Size 213 | and then Value (Reserve) in 0 .. Size 214 | and then Value (Last) >= Value (Read) 215 | and then Value (Last) >= Value (Write) 216 | 217 | -- Reserve can only be lower than Write when a write grant made an 218 | -- inverted allocation (starting back at 0), but the grant is not 219 | -- commited yet. 220 | and then (if Value (Reserve) < Value (Write) 221 | then not Is_Inverted (Offsets_Only)) 222 | and then (if Value (Reserve) < Value (Write) 223 | then not Is_Inverted (Offsets_Only) 224 | and then Value (Write) >= Value (Read) 225 | and then Value (Reserve) = Granted_Write_Size 226 | else Value (Reserve) - Granted_Write_Size = Value (Write)) 227 | 228 | -- Reserve is always in a writable area or else = Size 229 | and then (Value (Reserve) = Size 230 | or else In_Writable_Area (Offsets_Only, Value (Reserve))) 231 | 232 | and then (if Is_Inverted (Offsets_Only) 233 | then (Value (Write) + Granted_Write_Size <= Value (Read) 234 | and then 235 | Value (Reserve) <= Value (Read)) 236 | else Value (Read) <= Value (Write) - Granted_Read_Size) 237 | 238 | -- Read cannot be in reserved area 239 | and then (Value (Read) = Value (Write) 240 | or else 241 | (not (Granted_Write_Size /= 0 242 | and then 243 | Value (Read) in 244 | Value (Reserve) - Granted_Write_Size .. 245 | Value (Reserve) - 1 246 | ))) 247 | 248 | -- Write grant bounds 249 | and then (if Is_Inverted (Offsets_Only) 250 | then Granted_Write_Size <= Value (Read) - Value (Write) 251 | else Granted_Write_Size <= Count'Max (Size - Value (Write), 252 | Value (Read))) 253 | -- Read grant bounds 254 | and then (if Is_Inverted (Offsets_Only) 255 | then Granted_Read_Size <= Value (Last) - Value (Read) 256 | else Granted_Read_Size <= Value (Write) - Value (Read)) 257 | 258 | -- Reserve when about to invert 259 | and then (if not Is_Inverted (Offsets_Only) 260 | and then Value (Reserve) < Value (Write) 261 | then 262 | -- When Reserved wrapped around, we know that it is because 263 | -- we needed more space than what is available between Write 264 | -- and then end of the buffer 265 | Value (Reserve) > (Size - Value (Write)) 266 | ) 267 | 268 | and then (Value (Read) + Granted_Read_Size in 0 .. Size) 269 | and then (if not Atomic.Value (Write_In_Progress) 270 | then Granted_Write_Size = 0) 271 | and then (if not Atomic.Value (Read_In_Progress) 272 | then Granted_Read_Size = 0) 273 | ; 274 | 275 | function Is_Inverted (This : Offsets_Only) return Boolean 276 | is (Value (This.Write) < Value (This.Read)) 277 | with Ghost; 278 | 279 | Empty_Slice : constant Slice_Rec := (0, 0, 0); 280 | 281 | type Write_Grant is limited record 282 | Result : Result_Kind := Empty; 283 | Slice : Slice_Rec := Empty_Slice; 284 | end record; 285 | 286 | type Read_Grant is limited record 287 | Result : Result_Kind := Empty; 288 | Slice : Slice_Rec := Empty_Slice; 289 | end record; 290 | 291 | function State (G : Write_Grant) return Result_Kind 292 | is (G.Result); 293 | function Empty return Write_Grant 294 | is (Result => Empty, others => <>); 295 | function Slice (G : Write_Grant) return Slice_Rec 296 | is (G.Slice); 297 | 298 | function State (G : Read_Grant) return Result_Kind 299 | is (G.Result); 300 | function Empty return Read_Grant 301 | is (Result => Empty, others => <>); 302 | function Slice (G : Read_Grant) return Slice_Rec 303 | is (G.Slice); 304 | 305 | -- Contract helpers -- 306 | 307 | ---------------------- 308 | -- In_Readable_Area -- 309 | ---------------------- 310 | 311 | function In_Readable_Area (This : Offsets_Only; 312 | Offset : Buffer_Offset) 313 | return Boolean 314 | is (if Is_Inverted (This) then 315 | -- Already inverted. 316 | (if Value (This.Read) /= Value (This.Last) then 317 | -- |===W-----------R==L..| 318 | -- Data remaining before Last: 319 | -- We can read between R .. L 320 | Offset in Value (This.Read) .. Value (This.Last) 321 | else 322 | -- |===W--------------R..| 323 | -- L 324 | -- Read = Last, the next valid read is inverted: 325 | -- We can read between 0 .. W - 1 326 | Offset in 0 .. Value (This.Write) - 1) 327 | else 328 | -- |----R=========W-----| 329 | -- Not Inverted (R <= W): 330 | -- We can read between R .. W - 1 331 | Offset in Value (This.Read) .. Value (This.Write) - 1); 332 | 333 | ---------------------- 334 | -- In_Writable_Area -- 335 | ---------------------- 336 | 337 | function In_Writable_Area (This : Offsets_Only; 338 | Offset : Buffer_Offset) 339 | return Boolean 340 | is (if Is_Inverted (This) then 341 | -- Already inverted 342 | -- |---W==========R----| 343 | -- Inverted (R > W): 344 | -- We can write between W .. R - 1 345 | Offset in Value (This.Write) .. Value (This.Read) - 1 346 | else ( 347 | -- |====R---------W=====| 348 | -- Not Inverted (R <= W): 349 | -- We can write between W .. Size - 1, or 0 .. R - 1 if we invert 350 | (Offset in Value (This.Write) .. This.Size - 1) 351 | or else 352 | (Offset in 0 .. Value (This.Read) - 1))); 353 | 354 | ----------------------- 355 | -- Valid_Write_Slice -- 356 | ----------------------- 357 | 358 | function Valid_Write_Slice (This : Offsets_Only; 359 | Slice : Slice_Rec) 360 | return Boolean 361 | is (Valid_Slice (This, Slice) 362 | and then In_Writable_Area (This, Slice.From) 363 | and then In_Writable_Area (This, Slice.To)); 364 | 365 | function Valid_Read_Slice (This : Offsets_Only; 366 | Slice : Slice_Rec) 367 | return Boolean 368 | is (Valid_Slice (This, Slice) 369 | and then In_Readable_Area (This, Slice.From) 370 | and then In_Readable_Area (This, Slice.To)); 371 | 372 | ----------------------------- 373 | -- Write_Grant_In_Progress -- 374 | ----------------------------- 375 | 376 | function Write_Grant_In_Progress (This : Offsets_Only) return Boolean 377 | is (Atomic.Value (This.Write_In_Progress)); 378 | 379 | ---------------------------- 380 | -- Read_Grant_In_Progress -- 381 | ---------------------------- 382 | 383 | function Read_Grant_In_Progress (This : Offsets_Only) return Boolean 384 | is (Atomic.Value (This.Read_In_Progress)); 385 | 386 | end BBqueue; 387 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | config/ 2 | alire.lock 3 | -------------------------------------------------------------------------------- /tests/alire.toml: -------------------------------------------------------------------------------- 1 | name = "tests" 2 | description = "" 3 | version = "0.0.0" 4 | executables = ["main_offsets", "main_buffer", "main_framed"] 5 | 6 | [[depends-on]] 7 | bbqueue = "*" 8 | gnatprove = "^11" 9 | 10 | [[pins]] 11 | bbqueue = {path = "../"} 12 | 13 | [build-profiles] 14 | bbqueue = "validation" 15 | -------------------------------------------------------------------------------- /tests/src/main_buffer.adb: -------------------------------------------------------------------------------- 1 | with Ada.Text_IO; use Ada.Text_IO; 2 | 3 | with System.Storage_Elements; use System.Storage_Elements; 4 | with BBqueue; 5 | with BBqueue.Buffers; 6 | with System; use System; 7 | 8 | procedure Main_Buffer 9 | with SPARK_Mode 10 | is 11 | use type BBqueue.Result_Kind; 12 | 13 | Q : aliased BBqueue.Buffers.Buffer (35); 14 | 15 | procedure Fill (WG : BBqueue.Buffers.Write_Grant; 16 | Val : Storage_Element) 17 | with Pre => BBqueue.Buffers.State (WG) = BBqueue.Valid; 18 | 19 | procedure Fill_With_CB (Size : BBqueue.Count; 20 | Val : Storage_Element); 21 | 22 | procedure Print_Content (RG : BBqueue.Buffers.Read_Grant) 23 | with Pre => BBqueue.Buffers.State (RG) = BBqueue.Valid; 24 | 25 | procedure Print_Content_With_CB; 26 | 27 | ---------- 28 | -- Fill -- 29 | ---------- 30 | 31 | procedure Fill (WG : BBqueue.Buffers.Write_Grant; 32 | Val : Storage_Element) 33 | is 34 | pragma SPARK_Mode (Off); 35 | 36 | S : constant BBqueue.Buffers.Slice_Rec := BBqueue.Buffers.Slice (WG); 37 | Arr : Storage_Array (1 .. S.Length) with Address => S.Addr; 38 | begin 39 | Put_Line ("Fill" & S.Length'Img & " bytes."); 40 | Arr := (others => Val); 41 | end Fill; 42 | 43 | ------------------ 44 | -- Fill_With_CB -- 45 | ------------------ 46 | 47 | procedure Fill_With_CB (Size : BBqueue.Count; Val : Storage_Element) is 48 | 49 | pragma SPARK_Mode (Off); 50 | 51 | procedure Process_Write (Data : out Storage_Array; 52 | To_Commit : out BBqueue.Count); 53 | 54 | procedure Process_Write (Data : out Storage_Array; 55 | To_Commit : out BBqueue.Count) 56 | is 57 | begin 58 | Put_Line ("Fill" & Data'Length'Img & " bytes."); 59 | Data := (others => Val); 60 | To_Commit := Data'Length; 61 | end Process_Write; 62 | 63 | procedure Write is new BBqueue.Buffers.Write_CB (Process_Write); 64 | Result : BBqueue.Result_Kind; 65 | begin 66 | Write (Q, Size, Result); 67 | if Result /= BBqueue.Valid then 68 | Put_Line ("Write failed: " & Result'Img); 69 | end if; 70 | end Fill_With_CB; 71 | 72 | ------------------- 73 | -- Print_Content -- 74 | ------------------- 75 | 76 | procedure Print_Content (RG : BBqueue.Buffers.Read_Grant) is 77 | pragma SPARK_Mode (Off); 78 | S : constant BBqueue.Buffers.Slice_Rec := BBqueue.Buffers.Slice (RG); 79 | Arr : Storage_Array (1 .. S.Length) with Address => S.Addr; 80 | begin 81 | Put ("Print" & S.Length'Img & " bytes -> "); 82 | for Elt of Arr loop 83 | Put (Elt'Img); 84 | end loop; 85 | New_Line; 86 | end Print_Content; 87 | 88 | --------------------------- 89 | -- Print_Content_With_CB -- 90 | --------------------------- 91 | 92 | procedure Print_Content_With_CB is 93 | procedure Process_Read (Data : Storage_Array; 94 | To_Release : out BBqueue.Count); 95 | 96 | procedure Process_Read (Data : Storage_Array; 97 | To_Release : out BBqueue.Count) 98 | is 99 | begin 100 | Put ("Print" & Data'Length'Img & " bytes -> "); 101 | for Elt of Data loop 102 | Put (Elt'Img); 103 | end loop; 104 | New_Line; 105 | To_Release := Data'Length; 106 | end Process_Read; 107 | 108 | procedure Read is new BBqueue.Buffers.Read_CB (Process_Read); 109 | Result : BBqueue.Result_Kind; 110 | begin 111 | Read (Q, Result); 112 | if Result /= BBqueue.Valid then 113 | Put_Line ("Read failed: " & Result'Img); 114 | end if; 115 | end Print_Content_With_CB; 116 | 117 | WG : BBqueue.Buffers.Write_Grant := BBqueue.Buffers.Empty; 118 | RG : BBqueue.Buffers.Read_Grant := BBqueue.Buffers.Empty; 119 | 120 | V : Storage_Element := 1; 121 | begin 122 | 123 | for X in 1 .. 4 loop 124 | Put_Line ("-- Loop" & X'Img & " --"); 125 | 126 | BBqueue.Buffers.Grant (Q, WG, 10); 127 | if BBqueue.Buffers.State (WG) /= BBqueue.Valid then 128 | exit; 129 | end if; 130 | Put_Line ("BBqueue.Buffers.Grant (Q, 10) -> "); 131 | Put_Line ("Fill (WG, " & V'Img & ")"); 132 | Fill (WG, V); 133 | V := V + 1; 134 | 135 | BBqueue.Buffers.Commit (Q, WG, 10); 136 | Put_Line ("BBqueue.Buffers.Commit (WG, 10); ->"); 137 | 138 | BBqueue.Buffers.Read (Q, RG); 139 | if BBqueue.Buffers.State (RG) /= BBqueue.Valid then 140 | exit; 141 | end if; 142 | Put ("BBqueue.Buffers.Read (Q, RG); -> "); 143 | Print_Content (RG); 144 | 145 | BBqueue.Buffers.Release (Q, RG); 146 | Put_Line ("BBqueue.Buffers.Release (Q, RG); -> "); 147 | 148 | pragma Assert (BBqueue.Buffers.State (WG) = BBqueue.Empty); 149 | pragma Assert (BBqueue.Buffers.State (RG) = BBqueue.Empty); 150 | end loop; 151 | 152 | for X in 5 .. 7 loop 153 | Put_Line ("-- Loop" & X'Img & " with callbacks --"); 154 | Fill_With_CB (5, V); 155 | Fill_With_CB (5, V + 1); 156 | V := V + 1; 157 | Print_Content_With_CB; 158 | Print_Content_With_CB; 159 | end loop; 160 | end Main_Buffer; 161 | -------------------------------------------------------------------------------- /tests/src/main_framed.adb: -------------------------------------------------------------------------------- 1 | with Ada.Text_IO; use Ada.Text_IO; 2 | 3 | with System.Storage_Elements; use System.Storage_Elements; 4 | with BBqueue; 5 | with BBqueue.Buffers.framed; 6 | with System; use System; 7 | 8 | procedure Main_Framed 9 | with SPARK_Mode 10 | is 11 | use type BBqueue.Result_Kind; 12 | 13 | Q : aliased BBqueue.Buffers.framed.Framed_Buffer (60); 14 | 15 | procedure Fill_With_CB (Request, Actual : BBqueue.Count; 16 | Val : Storage_Element); 17 | procedure Print_Content_With_CB; 18 | 19 | ------------------ 20 | -- Fill_With_CB -- 21 | ------------------ 22 | 23 | procedure Fill_With_CB (Request, Actual : BBqueue.Count; 24 | Val : Storage_Element) 25 | is 26 | pragma SPARK_Mode (Off); 27 | 28 | procedure Process_Write (Data : out Storage_Array; 29 | To_Commit : out BBqueue.Count); 30 | 31 | procedure Process_Write (Data : out Storage_Array; 32 | To_Commit : out BBqueue.Count) 33 | is 34 | begin 35 | Put_Line ("Fill" & Actual'Img & " bytes."); 36 | Data (Data'First .. Data'First + Actual - 1) := (others => Val); 37 | To_Commit := Actual; 38 | end Process_Write; 39 | 40 | procedure Write is new BBqueue.Buffers.framed.Write_CB (Process_Write); 41 | Result : BBqueue.Result_Kind; 42 | begin 43 | Write (Q, Request, Result); 44 | if Result /= BBqueue.Valid then 45 | Put_Line ("Write failed: " & Result'Img); 46 | end if; 47 | end Fill_With_CB; 48 | 49 | --------------------------- 50 | -- Print_Content_With_CB -- 51 | --------------------------- 52 | 53 | procedure Print_Content_With_CB is 54 | procedure Process_Read (Data : Storage_Array); 55 | 56 | procedure Process_Read (Data : Storage_Array) is 57 | begin 58 | Put ("Print" & Data'Length'Img & " bytes -> "); 59 | for Elt of Data loop 60 | Put (Elt'Img); 61 | end loop; 62 | New_Line; 63 | end Process_Read; 64 | 65 | procedure Read is new BBqueue.Buffers.framed.Read_CB (Process_Read); 66 | Result : BBqueue.Result_Kind; 67 | begin 68 | Read (Q, Result); 69 | if Result /= BBqueue.Valid then 70 | Put_Line ("Read failed: " & Result'Img); 71 | end if; 72 | end Print_Content_With_CB; 73 | 74 | V : Storage_Element := 1; 75 | begin 76 | 77 | Put_Line ("Count'Object_Size:" & BBqueue.Count'Object_Size'Img); 78 | 79 | for X in BBqueue.Count range 1 .. 4 loop 80 | Put_Line ("-- Loop" & X'Img & " --"); 81 | Fill_With_CB (10, X, V); 82 | Fill_With_CB (20, X * 2, V * 2); 83 | V := V + 1; 84 | Print_Content_With_CB; 85 | Print_Content_With_CB; 86 | end loop; 87 | end Main_Framed; 88 | -------------------------------------------------------------------------------- /tests/src/main_offsets.adb: -------------------------------------------------------------------------------- 1 | with Ada.Text_IO; use Ada.Text_IO; 2 | 3 | with System.Storage_Elements; use System.Storage_Elements; 4 | with BBqueue; 5 | with System; use System; 6 | 7 | procedure Main_Offsets 8 | with SPARK_Mode 9 | is 10 | use type BBqueue.Result_Kind; 11 | 12 | Buffer : Storage_Array (0 .. 34) := (others => 0); 13 | Q : aliased BBqueue.Offsets_Only (Buffer'Length); 14 | 15 | procedure Fill (WG : BBqueue.Write_Grant; 16 | Val : Storage_Element) 17 | with Pre => BBqueue.State (WG) = BBqueue.Valid 18 | and then BBqueue.Valid_Slice (Q, BBqueue.Slice (WG)); 19 | 20 | procedure Print (G : BBqueue.Write_Grant); 21 | procedure Print (G : BBqueue.Read_Grant); 22 | procedure Print_Content (RG : BBqueue.Read_Grant) 23 | with Pre => BBqueue.State (RG) = BBqueue.Valid 24 | and then BBqueue.Valid_Slice (Q, BBqueue.Slice (RG)); 25 | procedure Print_Buffer; 26 | 27 | ---------- 28 | -- Fill -- 29 | ---------- 30 | 31 | procedure Fill (WG : BBqueue.Write_Grant; 32 | Val : Storage_Element) 33 | is 34 | S : constant BBqueue.Slice_Rec := BBqueue.Slice (WG); 35 | begin 36 | Buffer (Buffer'First + S.From .. Buffer'First + S.To) 37 | := (others => Val); 38 | end Fill; 39 | 40 | ----------- 41 | -- Print -- 42 | ----------- 43 | 44 | procedure Print (G : BBqueue.Write_Grant) is 45 | begin 46 | Put ("Write Grant - " & BBqueue.State (G)'Img); 47 | if BBqueue.State (G) = BBqueue.Valid then 48 | Put_Line (" Size:" & BBqueue.Slice (G).Length'Img); 49 | else 50 | New_Line; 51 | end if; 52 | end Print; 53 | 54 | ----------- 55 | -- Print -- 56 | ----------- 57 | 58 | procedure Print (G : BBqueue.Read_Grant) is 59 | begin 60 | Put ("Read Grant - " & BBqueue.State (G)'Img); 61 | if BBqueue.State (G) = BBqueue.Valid then 62 | Put_Line (" Size:" & BBqueue.Slice (G).Length'Img); 63 | else 64 | New_Line; 65 | end if; 66 | end Print; 67 | 68 | ------------------- 69 | -- Print_Content -- 70 | ------------------- 71 | 72 | procedure Print_Content (RG : BBqueue.Read_Grant) is 73 | S : constant BBqueue.Slice_Rec := BBqueue.Slice (RG); 74 | begin 75 | Put ("Print" & S.Length'Img & " bytes -> "); 76 | for Elt of Buffer (Buffer'First + S.From .. Buffer'First + S.To) loop 77 | Put (Elt'Img); 78 | end loop; 79 | New_Line; 80 | end Print_Content; 81 | 82 | ------------------ 83 | -- Print_Buffer -- 84 | ------------------ 85 | 86 | procedure Print_Buffer is 87 | begin 88 | Put ("Buffer => "); 89 | for Elt of Buffer loop 90 | Put (Elt'Img); 91 | end loop; 92 | New_Line; 93 | end Print_Buffer; 94 | 95 | WG : BBqueue.Write_Grant := BBqueue.Empty; 96 | RG : BBqueue.Read_Grant := BBqueue.Empty; 97 | 98 | V : Storage_Element := 1; 99 | begin 100 | 101 | for X in 1 .. 7 loop 102 | Put_Line ("-- Loop" & X'Img & " --"); 103 | 104 | Print_Buffer; 105 | 106 | BBqueue.Grant (Q, WG, 10); 107 | if BBqueue.State (WG) /= BBqueue.Valid then 108 | exit; 109 | end if; 110 | 111 | Put ("BBqueue.Grant (Q, 10) -> "); 112 | Print (WG); 113 | Print_Buffer; 114 | Put_Line ("Fill (WG, " & V'Img & ")"); 115 | Fill (WG, V); 116 | V := V + 1; 117 | Print_Buffer; 118 | 119 | BBqueue.Commit (Q, WG, 10); 120 | Put ("BBqueue.Commit (WG, 10); ->"); 121 | Print (WG); 122 | Print_Buffer; 123 | 124 | BBqueue.Read (Q, RG); 125 | if BBqueue.State (RG) /= BBqueue.Valid then 126 | exit; 127 | end if; 128 | 129 | Put ("BBqueue.Read (Q); -> "); 130 | Print (RG); 131 | Print_Content (RG); 132 | Print_Buffer; 133 | 134 | BBqueue.Release (Q, RG); 135 | Put ("BBqueue.Release (RG); -> "); 136 | Print (RG); 137 | Print_Buffer; 138 | 139 | pragma Assert (BBqueue.State (WG) = BBqueue.Empty); 140 | pragma Assert (BBqueue.State (RG) = BBqueue.Empty); 141 | end loop; 142 | end Main_Offsets; 143 | -------------------------------------------------------------------------------- /tests/tests.gpr: -------------------------------------------------------------------------------- 1 | with "config/tests_config.gpr"; 2 | 3 | with "bbqueue.gpr"; 4 | 5 | project Tests is 6 | for Source_Dirs use ("src"); 7 | for Object_Dir use "obj"; 8 | for Create_Missing_Dirs use "True"; 9 | for Main use ("main_offsets.adb", "main_buffer.adb", "main_framed.adb"); 10 | package Compiler renames BBqueue.Compiler; 11 | package Binder renames BBqueue.Binder; 12 | end Tests; 13 | --------------------------------------------------------------------------------