gcc/ada/s-auxdec-vms-ia64.adb

   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-2010, 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
  40 pragma 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
  44 with Interfaces;
  45 package 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 Interface (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 Interface (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 Interface (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 Interface (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
 576 end System.Aux_DEC;