1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . A U X _ D E C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- 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-- This is the Itanium/VMS version. 33 34-- The Add,Clear_Interlocked subprograms are dubiously implmented due to 35-- the lack of a single bit sync_lock_test_and_set builtin. 36 37-- The "Retry" parameter is ignored due to the lack of retry builtins making 38-- the subprograms identical to the non-retry versions. 39 40pragma Style_Checks (All_Checks); 41-- Turn off alpha ordering check on subprograms, this unit is laid 42-- out to correspond to the declarations in the DEC 83 System unit. 43 44with Interfaces; 45package body System.Aux_DEC is 46 47 use type Interfaces.Unsigned_8; 48 49 ------------------------ 50 -- Fetch_From_Address -- 51 ------------------------ 52 53 function Fetch_From_Address (A : Address) return Target is 54 type T_Ptr is access all Target; 55 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); 56 Ptr : constant T_Ptr := To_T_Ptr (A); 57 begin 58 return Ptr.all; 59 end Fetch_From_Address; 60 61 ----------------------- 62 -- Assign_To_Address -- 63 ----------------------- 64 65 procedure Assign_To_Address (A : Address; T : Target) is 66 type T_Ptr is access all Target; 67 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); 68 Ptr : constant T_Ptr := To_T_Ptr (A); 69 begin 70 Ptr.all := T; 71 end Assign_To_Address; 72 73 ----------------------- 74 -- Clear_Interlocked -- 75 ----------------------- 76 77 procedure Clear_Interlocked 78 (Bit : in out Boolean; 79 Old_Value : out Boolean) 80 is 81 Clr_Bit : Boolean := Bit; 82 Old_Uns : Interfaces.Unsigned_8; 83 84 function Sync_Lock_Test_And_Set 85 (Ptr : Address; 86 Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; 87 pragma Import (Intrinsic, Sync_Lock_Test_And_Set, 88 "__sync_lock_test_and_set_1"); 89 90 begin 91 Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0); 92 Bit := Clr_Bit; 93 Old_Value := Old_Uns /= 0; 94 end Clear_Interlocked; 95 96 procedure Clear_Interlocked 97 (Bit : in out Boolean; 98 Old_Value : out Boolean; 99 Retry_Count : Natural; 100 Success_Flag : out Boolean) 101 is 102 pragma Unreferenced (Retry_Count); 103 104 Clr_Bit : Boolean := Bit; 105 Old_Uns : Interfaces.Unsigned_8; 106 107 function Sync_Lock_Test_And_Set 108 (Ptr : Address; 109 Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; 110 pragma Import (Intrinsic, Sync_Lock_Test_And_Set, 111 "__sync_lock_test_and_set_1"); 112 113 begin 114 Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0); 115 Bit := Clr_Bit; 116 Old_Value := Old_Uns /= 0; 117 Success_Flag := True; 118 end Clear_Interlocked; 119 120 --------------------- 121 -- Set_Interlocked -- 122 --------------------- 123 124 procedure Set_Interlocked 125 (Bit : in out Boolean; 126 Old_Value : out Boolean) 127 is 128 Set_Bit : Boolean := Bit; 129 Old_Uns : Interfaces.Unsigned_8; 130 131 function Sync_Lock_Test_And_Set 132 (Ptr : Address; 133 Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; 134 pragma Import (Intrinsic, Sync_Lock_Test_And_Set, 135 "__sync_lock_test_and_set_1"); 136 137 begin 138 Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1); 139 Bit := Set_Bit; 140 Old_Value := Old_Uns /= 0; 141 end Set_Interlocked; 142 143 procedure Set_Interlocked 144 (Bit : in out Boolean; 145 Old_Value : out Boolean; 146 Retry_Count : Natural; 147 Success_Flag : out Boolean) 148 is 149 pragma Unreferenced (Retry_Count); 150 151 Set_Bit : Boolean := Bit; 152 Old_Uns : Interfaces.Unsigned_8; 153 154 function Sync_Lock_Test_And_Set 155 (Ptr : Address; 156 Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; 157 pragma Import (Intrinsic, Sync_Lock_Test_And_Set, 158 "__sync_lock_test_and_set_1"); 159 begin 160 Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1); 161 Bit := Set_Bit; 162 Old_Value := Old_Uns /= 0; 163 Success_Flag := True; 164 end Set_Interlocked; 165 166 --------------------- 167 -- Add_Interlocked -- 168 --------------------- 169 170 procedure Add_Interlocked 171 (Addend : Short_Integer; 172 Augend : in out Aligned_Word; 173 Sign : out Integer) 174 is 175 Overflowed : Boolean := False; 176 Former : Aligned_Word; 177 178 function Sync_Fetch_And_Add 179 (Ptr : Address; 180 Value : Short_Integer) return Short_Integer; 181 pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2"); 182 183 begin 184 Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend); 185 186 if Augend.Value < 0 then 187 Sign := -1; 188 elsif Augend.Value > 0 then 189 Sign := 1; 190 else 191 Sign := 0; 192 end if; 193 194 if Former.Value > 0 and then Augend.Value <= 0 then 195 Overflowed := True; 196 end if; 197 198 if Overflowed then 199 raise Constraint_Error; 200 end if; 201 end Add_Interlocked; 202 203 ---------------- 204 -- Add_Atomic -- 205 ---------------- 206 207 procedure Add_Atomic 208 (To : in out Aligned_Integer; 209 Amount : Integer) 210 is 211 procedure Sync_Add_And_Fetch 212 (Ptr : Address; 213 Value : Integer); 214 pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); 215 begin 216 Sync_Add_And_Fetch (To.Value'Address, Amount); 217 end Add_Atomic; 218 219 procedure Add_Atomic 220 (To : in out Aligned_Integer; 221 Amount : Integer; 222 Retry_Count : Natural; 223 Old_Value : out Integer; 224 Success_Flag : out Boolean) 225 is 226 pragma Unreferenced (Retry_Count); 227 228 function Sync_Fetch_And_Add 229 (Ptr : Address; 230 Value : Integer) return Integer; 231 pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4"); 232 233 begin 234 Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount); 235 Success_Flag := True; 236 end Add_Atomic; 237 238 procedure Add_Atomic 239 (To : in out Aligned_Long_Integer; 240 Amount : Long_Integer) 241 is 242 procedure Sync_Add_And_Fetch 243 (Ptr : Address; 244 Value : Long_Integer); 245 pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8"); 246 begin 247 Sync_Add_And_Fetch (To.Value'Address, Amount); 248 end Add_Atomic; 249 250 procedure Add_Atomic 251 (To : in out Aligned_Long_Integer; 252 Amount : Long_Integer; 253 Retry_Count : Natural; 254 Old_Value : out Long_Integer; 255 Success_Flag : out Boolean) 256 is 257 pragma Unreferenced (Retry_Count); 258 259 function Sync_Fetch_And_Add 260 (Ptr : Address; 261 Value : Long_Integer) return Long_Integer; 262 pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8"); 263 -- Why do we keep importing this over and over again??? 264 265 begin 266 Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount); 267 Success_Flag := True; 268 end Add_Atomic; 269 270 ---------------- 271 -- And_Atomic -- 272 ---------------- 273 274 procedure And_Atomic 275 (To : in out Aligned_Integer; 276 From : Integer) 277 is 278 procedure Sync_And_And_Fetch 279 (Ptr : Address; 280 Value : Integer); 281 pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4"); 282 begin 283 Sync_And_And_Fetch (To.Value'Address, From); 284 end And_Atomic; 285 286 procedure And_Atomic 287 (To : in out Aligned_Integer; 288 From : Integer; 289 Retry_Count : Natural; 290 Old_Value : out Integer; 291 Success_Flag : out Boolean) 292 is 293 pragma Unreferenced (Retry_Count); 294 295 function Sync_Fetch_And_And 296 (Ptr : Address; 297 Value : Integer) return Integer; 298 pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4"); 299 300 begin 301 Old_Value := Sync_Fetch_And_And (To.Value'Address, From); 302 Success_Flag := True; 303 end And_Atomic; 304 305 procedure And_Atomic 306 (To : in out Aligned_Long_Integer; 307 From : Long_Integer) 308 is 309 procedure Sync_And_And_Fetch 310 (Ptr : Address; 311 Value : Long_Integer); 312 pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8"); 313 begin 314 Sync_And_And_Fetch (To.Value'Address, From); 315 end And_Atomic; 316 317 procedure And_Atomic 318 (To : in out Aligned_Long_Integer; 319 From : Long_Integer; 320 Retry_Count : Natural; 321 Old_Value : out Long_Integer; 322 Success_Flag : out Boolean) 323 is 324 pragma Unreferenced (Retry_Count); 325 326 function Sync_Fetch_And_And 327 (Ptr : Address; 328 Value : Long_Integer) return Long_Integer; 329 pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8"); 330 331 begin 332 Old_Value := Sync_Fetch_And_And (To.Value'Address, From); 333 Success_Flag := True; 334 end And_Atomic; 335 336 --------------- 337 -- Or_Atomic -- 338 --------------- 339 340 procedure Or_Atomic 341 (To : in out Aligned_Integer; 342 From : Integer) 343 is 344 procedure Sync_Or_And_Fetch 345 (Ptr : Address; 346 Value : Integer); 347 pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4"); 348 349 begin 350 Sync_Or_And_Fetch (To.Value'Address, From); 351 end Or_Atomic; 352 353 procedure Or_Atomic 354 (To : in out Aligned_Integer; 355 From : Integer; 356 Retry_Count : Natural; 357 Old_Value : out Integer; 358 Success_Flag : out Boolean) 359 is 360 pragma Unreferenced (Retry_Count); 361 362 function Sync_Fetch_And_Or 363 (Ptr : Address; 364 Value : Integer) return Integer; 365 pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4"); 366 367 begin 368 Old_Value := Sync_Fetch_And_Or (To.Value'Address, From); 369 Success_Flag := True; 370 end Or_Atomic; 371 372 procedure Or_Atomic 373 (To : in out Aligned_Long_Integer; 374 From : Long_Integer) 375 is 376 procedure Sync_Or_And_Fetch 377 (Ptr : Address; 378 Value : Long_Integer); 379 pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8"); 380 begin 381 Sync_Or_And_Fetch (To.Value'Address, From); 382 end Or_Atomic; 383 384 procedure Or_Atomic 385 (To : in out Aligned_Long_Integer; 386 From : Long_Integer; 387 Retry_Count : Natural; 388 Old_Value : out Long_Integer; 389 Success_Flag : out Boolean) 390 is 391 pragma Unreferenced (Retry_Count); 392 393 function Sync_Fetch_And_Or 394 (Ptr : Address; 395 Value : Long_Integer) return Long_Integer; 396 pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8"); 397 398 begin 399 Old_Value := Sync_Fetch_And_Or (To.Value'Address, From); 400 Success_Flag := True; 401 end Or_Atomic; 402 403 ------------ 404 -- Insqhi -- 405 ------------ 406 407 procedure Insqhi 408 (Item : Address; 409 Header : Address; 410 Status : out Insq_Status) is 411 412 procedure SYS_PAL_INSQHIL 413 (STATUS : out Integer; Header : Address; ITEM : Address); 414 pragma Import (External, SYS_PAL_INSQHIL); 415 pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL", 416 (Integer, Address, Address), 417 (Value, Value, Value)); 418 419 Istat : Integer; 420 421 begin 422 SYS_PAL_INSQHIL (Istat, Header, Item); 423 424 if Istat = 0 then 425 Status := OK_Not_First; 426 elsif Istat = 1 then 427 Status := OK_First; 428 429 else 430 -- This status is never returned on IVMS 431 432 Status := Fail_No_Lock; 433 end if; 434 end Insqhi; 435 436 ------------ 437 -- Remqhi -- 438 ------------ 439 440 procedure Remqhi 441 (Header : Address; 442 Item : out Address; 443 Status : out Remq_Status) 444 is 445 -- The removed item is returned in the second function return register, 446 -- R9 on IVMS. The VMS ABI calls for "small" records to be returned in 447 -- these registers, so inventing this odd looking record type makes that 448 -- all work. 449 450 type Remq is record 451 Status : Long_Integer; 452 Item : Address; 453 end record; 454 455 procedure SYS_PAL_REMQHIL 456 (Remret : out Remq; Header : Address); 457 pragma Import (External, SYS_PAL_REMQHIL); 458 pragma Import_Valued_Procedure 459 (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL", 460 (Remq, Address), 461 (Value, Value)); 462 463 -- Following variables need documentation??? 464 465 Rstat : Long_Integer; 466 Remret : Remq; 467 468 begin 469 SYS_PAL_REMQHIL (Remret, Header); 470 471 Rstat := Remret.Status; 472 Item := Remret.Item; 473 474 if Rstat = 0 then 475 Status := Fail_Was_Empty; 476 477 elsif Rstat = 1 then 478 Status := OK_Not_Empty; 479 480 elsif Rstat = 2 then 481 Status := OK_Empty; 482 483 else 484 -- This status is never returned on IVMS 485 486 Status := Fail_No_Lock; 487 end if; 488 489 end Remqhi; 490 491 ------------ 492 -- Insqti -- 493 ------------ 494 495 procedure Insqti 496 (Item : Address; 497 Header : Address; 498 Status : out Insq_Status) is 499 500 procedure SYS_PAL_INSQTIL 501 (STATUS : out Integer; Header : Address; ITEM : Address); 502 pragma Import (External, SYS_PAL_INSQTIL); 503 pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL", 504 (Integer, Address, Address), 505 (Value, Value, Value)); 506 507 Istat : Integer; 508 509 begin 510 SYS_PAL_INSQTIL (Istat, Header, Item); 511 512 if Istat = 0 then 513 Status := OK_Not_First; 514 515 elsif Istat = 1 then 516 Status := OK_First; 517 518 else 519 -- This status is never returned on IVMS 520 521 Status := Fail_No_Lock; 522 end if; 523 end Insqti; 524 525 ------------ 526 -- Remqti -- 527 ------------ 528 529 procedure Remqti 530 (Header : Address; 531 Item : out Address; 532 Status : out Remq_Status) 533 is 534 -- The removed item is returned in the second function return register, 535 -- R9 on IVMS. The VMS ABI calls for "small" records to be returned in 536 -- these registers, so inventing (where is rest of this comment???) 537 538 type Remq is record 539 Status : Long_Integer; 540 Item : Address; 541 end record; 542 543 procedure SYS_PAL_REMQTIL 544 (Remret : out Remq; Header : Address); 545 pragma Import (External, SYS_PAL_REMQTIL); 546 pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL", 547 (Remq, Address), 548 (Value, Value)); 549 550 Rstat : Long_Integer; 551 Remret : Remq; 552 553 begin 554 SYS_PAL_REMQTIL (Remret, Header); 555 556 Rstat := Remret.Status; 557 Item := Remret.Item; 558 559 -- Wouldn't case be nicer here, and in previous similar cases ??? 560 561 if Rstat = 0 then 562 Status := Fail_Was_Empty; 563 564 elsif Rstat = 1 then 565 Status := OK_Not_Empty; 566 567 elsif Rstat = 2 then 568 Status := OK_Empty; 569 else 570 -- This status is never returned on IVMS 571 572 Status := Fail_No_Lock; 573 end if; 574 end Remqti; 575 576end System.Aux_DEC; 577