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-2009, 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 32pragma Style_Checks (All_Checks); 33-- Turn off alpha ordering check on subprograms, this unit is laid 34-- out to correspond to the declarations in the DEC 83 System unit. 35 36with System.Soft_Links; 37 38package body System.Aux_DEC is 39 40 package SSL renames System.Soft_Links; 41 42 ----------------------------------- 43 -- Operations on Largest_Integer -- 44 ----------------------------------- 45 46 -- It would be nice to replace these with intrinsics, but that does 47 -- not work yet (the back end would be ok, but GNAT itself objects) 48 49 type LIU is mod 2 ** Largest_Integer'Size; 50 -- Unsigned type of same length as Largest_Integer 51 52 function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer); 53 function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU); 54 55 function "not" (Left : Largest_Integer) return Largest_Integer is 56 begin 57 return To_LI (not From_LI (Left)); 58 end "not"; 59 60 function "and" (Left, Right : Largest_Integer) return Largest_Integer is 61 begin 62 return To_LI (From_LI (Left) and From_LI (Right)); 63 end "and"; 64 65 function "or" (Left, Right : Largest_Integer) return Largest_Integer is 66 begin 67 return To_LI (From_LI (Left) or From_LI (Right)); 68 end "or"; 69 70 function "xor" (Left, Right : Largest_Integer) return Largest_Integer is 71 begin 72 return To_LI (From_LI (Left) xor From_LI (Right)); 73 end "xor"; 74 75 -------------------------------------- 76 -- Arithmetic Operations on Address -- 77 -------------------------------------- 78 79 -- It would be nice to replace these with intrinsics, but that does 80 -- not work yet (the back end would be ok, but GNAT itself objects) 81 82 Asiz : constant Integer := Integer (Address'Size) - 1; 83 84 type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1; 85 -- Signed type of same size as Address 86 87 function To_A is new Ada.Unchecked_Conversion (SA, Address); 88 function From_A is new Ada.Unchecked_Conversion (Address, SA); 89 90 function "+" (Left : Address; Right : Integer) return Address is 91 begin 92 return To_A (From_A (Left) + SA (Right)); 93 end "+"; 94 95 function "+" (Left : Integer; Right : Address) return Address is 96 begin 97 return To_A (SA (Left) + From_A (Right)); 98 end "+"; 99 100 function "-" (Left : Address; Right : Address) return Integer is 101 pragma Unsuppress (All_Checks); 102 -- Because this can raise Constraint_Error for 64-bit addresses 103 begin 104 return Integer (From_A (Left) - From_A (Right)); 105 end "-"; 106 107 function "-" (Left : Address; Right : Integer) return Address is 108 begin 109 return To_A (From_A (Left) - SA (Right)); 110 end "-"; 111 112 ------------------------ 113 -- Fetch_From_Address -- 114 ------------------------ 115 116 function Fetch_From_Address (A : Address) return Target is 117 type T_Ptr is access all Target; 118 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); 119 Ptr : constant T_Ptr := To_T_Ptr (A); 120 begin 121 return Ptr.all; 122 end Fetch_From_Address; 123 124 ----------------------- 125 -- Assign_To_Address -- 126 ----------------------- 127 128 procedure Assign_To_Address (A : Address; T : Target) is 129 type T_Ptr is access all Target; 130 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); 131 Ptr : constant T_Ptr := To_T_Ptr (A); 132 begin 133 Ptr.all := T; 134 end Assign_To_Address; 135 136 --------------------------------- 137 -- Operations on Unsigned_Byte -- 138 --------------------------------- 139 140 -- It would be nice to replace these with intrinsics, but that does 141 -- not work yet (the back end would be ok, but GNAT itself objects) 142 143 type BU is mod 2 ** Unsigned_Byte'Size; 144 -- Unsigned type of same length as Unsigned_Byte 145 146 function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte); 147 function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU); 148 149 function "not" (Left : Unsigned_Byte) return Unsigned_Byte is 150 begin 151 return To_B (not From_B (Left)); 152 end "not"; 153 154 function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is 155 begin 156 return To_B (From_B (Left) and From_B (Right)); 157 end "and"; 158 159 function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is 160 begin 161 return To_B (From_B (Left) or From_B (Right)); 162 end "or"; 163 164 function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is 165 begin 166 return To_B (From_B (Left) xor From_B (Right)); 167 end "xor"; 168 169 --------------------------------- 170 -- Operations on Unsigned_Word -- 171 --------------------------------- 172 173 -- It would be nice to replace these with intrinsics, but that does 174 -- not work yet (the back end would be ok, but GNAT itself objects) 175 176 type WU is mod 2 ** Unsigned_Word'Size; 177 -- Unsigned type of same length as Unsigned_Word 178 179 function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word); 180 function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU); 181 182 function "not" (Left : Unsigned_Word) return Unsigned_Word is 183 begin 184 return To_W (not From_W (Left)); 185 end "not"; 186 187 function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is 188 begin 189 return To_W (From_W (Left) and From_W (Right)); 190 end "and"; 191 192 function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is 193 begin 194 return To_W (From_W (Left) or From_W (Right)); 195 end "or"; 196 197 function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is 198 begin 199 return To_W (From_W (Left) xor From_W (Right)); 200 end "xor"; 201 202 ------------------------------------- 203 -- Operations on Unsigned_Longword -- 204 ------------------------------------- 205 206 -- It would be nice to replace these with intrinsics, but that does 207 -- not work yet (the back end would be ok, but GNAT itself objects) 208 209 type LWU is mod 2 ** Unsigned_Longword'Size; 210 -- Unsigned type of same length as Unsigned_Longword 211 212 function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword); 213 function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU); 214 215 function "not" (Left : Unsigned_Longword) return Unsigned_Longword is 216 begin 217 return To_LW (not From_LW (Left)); 218 end "not"; 219 220 function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is 221 begin 222 return To_LW (From_LW (Left) and From_LW (Right)); 223 end "and"; 224 225 function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is 226 begin 227 return To_LW (From_LW (Left) or From_LW (Right)); 228 end "or"; 229 230 function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is 231 begin 232 return To_LW (From_LW (Left) xor From_LW (Right)); 233 end "xor"; 234 235 ------------------------------- 236 -- Operations on Unsigned_32 -- 237 ------------------------------- 238 239 -- It would be nice to replace these with intrinsics, but that does 240 -- not work yet (the back end would be ok, but GNAT itself objects) 241 242 type U32 is mod 2 ** Unsigned_32'Size; 243 -- Unsigned type of same length as Unsigned_32 244 245 function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32); 246 function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32); 247 248 function "not" (Left : Unsigned_32) return Unsigned_32 is 249 begin 250 return To_U32 (not From_U32 (Left)); 251 end "not"; 252 253 function "and" (Left, Right : Unsigned_32) return Unsigned_32 is 254 begin 255 return To_U32 (From_U32 (Left) and From_U32 (Right)); 256 end "and"; 257 258 function "or" (Left, Right : Unsigned_32) return Unsigned_32 is 259 begin 260 return To_U32 (From_U32 (Left) or From_U32 (Right)); 261 end "or"; 262 263 function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is 264 begin 265 return To_U32 (From_U32 (Left) xor From_U32 (Right)); 266 end "xor"; 267 268 ------------------------------------- 269 -- Operations on Unsigned_Quadword -- 270 ------------------------------------- 271 272 -- It would be nice to replace these with intrinsics, but that does 273 -- not work yet (the back end would be ok, but GNAT itself objects) 274 275 type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size 276 -- Unsigned type of same length as Unsigned_Quadword 277 278 function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword); 279 function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU); 280 281 function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is 282 begin 283 return To_QW (not From_QW (Left)); 284 end "not"; 285 286 function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is 287 begin 288 return To_QW (From_QW (Left) and From_QW (Right)); 289 end "and"; 290 291 function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is 292 begin 293 return To_QW (From_QW (Left) or From_QW (Right)); 294 end "or"; 295 296 function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is 297 begin 298 return To_QW (From_QW (Left) xor From_QW (Right)); 299 end "xor"; 300 301 ----------------------- 302 -- Clear_Interlocked -- 303 ----------------------- 304 305 procedure Clear_Interlocked 306 (Bit : in out Boolean; 307 Old_Value : out Boolean) 308 is 309 begin 310 SSL.Lock_Task.all; 311 Old_Value := Bit; 312 Bit := False; 313 SSL.Unlock_Task.all; 314 end Clear_Interlocked; 315 316 procedure Clear_Interlocked 317 (Bit : in out Boolean; 318 Old_Value : out Boolean; 319 Retry_Count : Natural; 320 Success_Flag : out Boolean) 321 is 322 pragma Warnings (Off, Retry_Count); 323 324 begin 325 SSL.Lock_Task.all; 326 Old_Value := Bit; 327 Bit := False; 328 Success_Flag := True; 329 SSL.Unlock_Task.all; 330 end Clear_Interlocked; 331 332 --------------------- 333 -- Set_Interlocked -- 334 --------------------- 335 336 procedure Set_Interlocked 337 (Bit : in out Boolean; 338 Old_Value : out Boolean) 339 is 340 begin 341 SSL.Lock_Task.all; 342 Old_Value := Bit; 343 Bit := True; 344 SSL.Unlock_Task.all; 345 end Set_Interlocked; 346 347 procedure Set_Interlocked 348 (Bit : in out Boolean; 349 Old_Value : out Boolean; 350 Retry_Count : Natural; 351 Success_Flag : out Boolean) 352 is 353 pragma Warnings (Off, Retry_Count); 354 355 begin 356 SSL.Lock_Task.all; 357 Old_Value := Bit; 358 Bit := True; 359 Success_Flag := True; 360 SSL.Unlock_Task.all; 361 end Set_Interlocked; 362 363 --------------------- 364 -- Add_Interlocked -- 365 --------------------- 366 367 procedure Add_Interlocked 368 (Addend : Short_Integer; 369 Augend : in out Aligned_Word; 370 Sign : out Integer) 371 is 372 begin 373 SSL.Lock_Task.all; 374 Augend.Value := Augend.Value + Addend; 375 376 if Augend.Value < 0 then 377 Sign := -1; 378 elsif Augend.Value > 0 then 379 Sign := +1; 380 else 381 Sign := 0; 382 end if; 383 384 SSL.Unlock_Task.all; 385 end Add_Interlocked; 386 387 ---------------- 388 -- Add_Atomic -- 389 ---------------- 390 391 procedure Add_Atomic 392 (To : in out Aligned_Integer; 393 Amount : Integer) 394 is 395 begin 396 SSL.Lock_Task.all; 397 To.Value := To.Value + Amount; 398 SSL.Unlock_Task.all; 399 end Add_Atomic; 400 401 procedure Add_Atomic 402 (To : in out Aligned_Integer; 403 Amount : Integer; 404 Retry_Count : Natural; 405 Old_Value : out Integer; 406 Success_Flag : out Boolean) 407 is 408 pragma Warnings (Off, Retry_Count); 409 410 begin 411 SSL.Lock_Task.all; 412 Old_Value := To.Value; 413 To.Value := To.Value + Amount; 414 Success_Flag := True; 415 SSL.Unlock_Task.all; 416 end Add_Atomic; 417 418 procedure Add_Atomic 419 (To : in out Aligned_Long_Integer; 420 Amount : Long_Integer) 421 is 422 begin 423 SSL.Lock_Task.all; 424 To.Value := To.Value + Amount; 425 SSL.Unlock_Task.all; 426 end Add_Atomic; 427 428 procedure Add_Atomic 429 (To : in out Aligned_Long_Integer; 430 Amount : Long_Integer; 431 Retry_Count : Natural; 432 Old_Value : out Long_Integer; 433 Success_Flag : out Boolean) 434 is 435 pragma Warnings (Off, Retry_Count); 436 437 begin 438 SSL.Lock_Task.all; 439 Old_Value := To.Value; 440 To.Value := To.Value + Amount; 441 Success_Flag := True; 442 SSL.Unlock_Task.all; 443 end Add_Atomic; 444 445 ---------------- 446 -- And_Atomic -- 447 ---------------- 448 449 type IU is mod 2 ** Integer'Size; 450 type LU is mod 2 ** Long_Integer'Size; 451 452 function To_IU is new Ada.Unchecked_Conversion (Integer, IU); 453 function From_IU is new Ada.Unchecked_Conversion (IU, Integer); 454 455 function To_LU is new Ada.Unchecked_Conversion (Long_Integer, LU); 456 function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer); 457 458 procedure And_Atomic 459 (To : in out Aligned_Integer; 460 From : Integer) 461 is 462 begin 463 SSL.Lock_Task.all; 464 To.Value := From_IU (To_IU (To.Value) and To_IU (From)); 465 SSL.Unlock_Task.all; 466 end And_Atomic; 467 468 procedure And_Atomic 469 (To : in out Aligned_Integer; 470 From : Integer; 471 Retry_Count : Natural; 472 Old_Value : out Integer; 473 Success_Flag : out Boolean) 474 is 475 pragma Warnings (Off, Retry_Count); 476 477 begin 478 SSL.Lock_Task.all; 479 Old_Value := To.Value; 480 To.Value := From_IU (To_IU (To.Value) and To_IU (From)); 481 Success_Flag := True; 482 SSL.Unlock_Task.all; 483 end And_Atomic; 484 485 procedure And_Atomic 486 (To : in out Aligned_Long_Integer; 487 From : Long_Integer) 488 is 489 begin 490 SSL.Lock_Task.all; 491 To.Value := From_LU (To_LU (To.Value) and To_LU (From)); 492 SSL.Unlock_Task.all; 493 end And_Atomic; 494 495 procedure And_Atomic 496 (To : in out Aligned_Long_Integer; 497 From : Long_Integer; 498 Retry_Count : Natural; 499 Old_Value : out Long_Integer; 500 Success_Flag : out Boolean) 501 is 502 pragma Warnings (Off, Retry_Count); 503 504 begin 505 SSL.Lock_Task.all; 506 Old_Value := To.Value; 507 To.Value := From_LU (To_LU (To.Value) and To_LU (From)); 508 Success_Flag := True; 509 SSL.Unlock_Task.all; 510 end And_Atomic; 511 512 --------------- 513 -- Or_Atomic -- 514 --------------- 515 516 procedure Or_Atomic 517 (To : in out Aligned_Integer; 518 From : Integer) 519 is 520 begin 521 SSL.Lock_Task.all; 522 To.Value := From_IU (To_IU (To.Value) or To_IU (From)); 523 SSL.Unlock_Task.all; 524 end Or_Atomic; 525 526 procedure Or_Atomic 527 (To : in out Aligned_Integer; 528 From : Integer; 529 Retry_Count : Natural; 530 Old_Value : out Integer; 531 Success_Flag : out Boolean) 532 is 533 pragma Warnings (Off, Retry_Count); 534 535 begin 536 SSL.Lock_Task.all; 537 Old_Value := To.Value; 538 To.Value := From_IU (To_IU (To.Value) or To_IU (From)); 539 Success_Flag := True; 540 SSL.Unlock_Task.all; 541 end Or_Atomic; 542 543 procedure Or_Atomic 544 (To : in out Aligned_Long_Integer; 545 From : Long_Integer) 546 is 547 begin 548 SSL.Lock_Task.all; 549 To.Value := From_LU (To_LU (To.Value) or To_LU (From)); 550 SSL.Unlock_Task.all; 551 end Or_Atomic; 552 553 procedure Or_Atomic 554 (To : in out Aligned_Long_Integer; 555 From : Long_Integer; 556 Retry_Count : Natural; 557 Old_Value : out Long_Integer; 558 Success_Flag : out Boolean) 559 is 560 pragma Warnings (Off, Retry_Count); 561 562 begin 563 SSL.Lock_Task.all; 564 Old_Value := To.Value; 565 To.Value := From_LU (To_LU (To.Value) or To_LU (From)); 566 Success_Flag := True; 567 SSL.Unlock_Task.all; 568 end Or_Atomic; 569 570 ------------------------------------ 571 -- Declarations for Queue Objects -- 572 ------------------------------------ 573 574 type QR; 575 576 type QR_Ptr is access QR; 577 578 type QR is record 579 Forward : QR_Ptr; 580 Backward : QR_Ptr; 581 end record; 582 583 function To_QR_Ptr is new Ada.Unchecked_Conversion (Address, QR_Ptr); 584 function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address); 585 586 ------------ 587 -- Insqhi -- 588 ------------ 589 590 procedure Insqhi 591 (Item : Address; 592 Header : Address; 593 Status : out Insq_Status) 594 is 595 Hedr : constant QR_Ptr := To_QR_Ptr (Header); 596 Next : constant QR_Ptr := Hedr.Forward; 597 Itm : constant QR_Ptr := To_QR_Ptr (Item); 598 599 begin 600 SSL.Lock_Task.all; 601 602 Itm.Forward := Next; 603 Itm.Backward := Hedr; 604 Hedr.Forward := Itm; 605 606 if Next = null then 607 Status := OK_First; 608 609 else 610 Next.Backward := Itm; 611 Status := OK_Not_First; 612 end if; 613 614 SSL.Unlock_Task.all; 615 end Insqhi; 616 617 ------------ 618 -- Remqhi -- 619 ------------ 620 621 procedure Remqhi 622 (Header : Address; 623 Item : out Address; 624 Status : out Remq_Status) 625 is 626 Hedr : constant QR_Ptr := To_QR_Ptr (Header); 627 Next : constant QR_Ptr := Hedr.Forward; 628 629 begin 630 SSL.Lock_Task.all; 631 632 Item := From_QR_Ptr (Next); 633 634 if Next = null then 635 Status := Fail_Was_Empty; 636 637 else 638 Hedr.Forward := To_QR_Ptr (Item).Forward; 639 640 if Hedr.Forward = null then 641 Status := OK_Empty; 642 643 else 644 Hedr.Forward.Backward := Hedr; 645 Status := OK_Not_Empty; 646 end if; 647 end if; 648 649 SSL.Unlock_Task.all; 650 end Remqhi; 651 652 ------------ 653 -- Insqti -- 654 ------------ 655 656 procedure Insqti 657 (Item : Address; 658 Header : Address; 659 Status : out Insq_Status) 660 is 661 Hedr : constant QR_Ptr := To_QR_Ptr (Header); 662 Prev : constant QR_Ptr := Hedr.Backward; 663 Itm : constant QR_Ptr := To_QR_Ptr (Item); 664 665 begin 666 SSL.Lock_Task.all; 667 668 Itm.Backward := Prev; 669 Itm.Forward := Hedr; 670 Hedr.Backward := Itm; 671 672 if Prev = null then 673 Status := OK_First; 674 675 else 676 Prev.Forward := Itm; 677 Status := OK_Not_First; 678 end if; 679 680 SSL.Unlock_Task.all; 681 end Insqti; 682 683 ------------ 684 -- Remqti -- 685 ------------ 686 687 procedure Remqti 688 (Header : Address; 689 Item : out Address; 690 Status : out Remq_Status) 691 is 692 Hedr : constant QR_Ptr := To_QR_Ptr (Header); 693 Prev : constant QR_Ptr := Hedr.Backward; 694 695 begin 696 SSL.Lock_Task.all; 697 698 Item := From_QR_Ptr (Prev); 699 700 if Prev = null then 701 Status := Fail_Was_Empty; 702 703 else 704 Hedr.Backward := To_QR_Ptr (Item).Backward; 705 706 if Hedr.Backward = null then 707 Status := OK_Empty; 708 709 else 710 Hedr.Backward.Forward := Hedr; 711 Status := OK_Not_Empty; 712 end if; 713 end if; 714 715 SSL.Unlock_Task.all; 716 end Remqti; 717 718end System.Aux_DEC; 719