Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                       S Y S T E M . A U X _ D E C                        --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  This is the Itanium/VMS version.

--  The Add,Clear_Interlocked subprograms are dubiously implmented due to

--  the lack of a single bit sync_lock_test_and_set builtin.

--  The "Retry" parameter is ignored due to the lack of retry builtins making

--  the subprograms identical to the non-retry versions.

pragma Style_Checks (All_Checks);

--  Turn off alpha ordering check on subprograms, this unit is laid

--  out to correspond to the declarations in the DEC 83 System unit.

with Interfaces;

package body System.Aux_DEC is

   use type Interfaces.Unsigned_8;

   ------------------------

   -- Fetch_From_Address --

   ------------------------

   function Fetch_From_Address (A : Address) return Target is

      type T_Ptr is access all Target;

      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);

      Ptr : constant T_Ptr := To_T_Ptr (A);

   begin

      return Ptr.all;

   end Fetch_From_Address;

   -----------------------

   -- Assign_To_Address --

   -----------------------

   procedure Assign_To_Address (A : Address; T : Target) is

      type T_Ptr is access all Target;

      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);

      Ptr : constant T_Ptr := To_T_Ptr (A);

   begin

      Ptr.all := T;

   end Assign_To_Address;

   -----------------------

   -- Clear_Interlocked --

   -----------------------

   procedure Clear_Interlocked

     (Bit       : in out Boolean;

      Old_Value : out Boolean)

   is

      Clr_Bit : Boolean := Bit;

      Old_Uns : Interfaces.Unsigned_8;

      function Sync_Lock_Test_And_Set

        (Ptr   : Address;

         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;

      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,

                     "__sync_lock_test_and_set_1");

   begin

      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);

      Bit := Clr_Bit;

      Old_Value := Old_Uns /= 0;

   end Clear_Interlocked;

   procedure Clear_Interlocked

     (Bit          : in out Boolean;

      Old_Value    : out Boolean;

      Retry_Count  : Natural;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      Clr_Bit : Boolean := Bit;

      Old_Uns : Interfaces.Unsigned_8;

      function Sync_Lock_Test_And_Set

        (Ptr   : Address;

         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;

      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,

                     "__sync_lock_test_and_set_1");

   begin

      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);

      Bit := Clr_Bit;

      Old_Value := Old_Uns /= 0;

      Success_Flag := True;

   end Clear_Interlocked;

   ---------------------

   -- Set_Interlocked --

   ---------------------

   procedure Set_Interlocked

     (Bit       : in out Boolean;

      Old_Value : out Boolean)

   is

      Set_Bit : Boolean := Bit;

      Old_Uns : Interfaces.Unsigned_8;

      function Sync_Lock_Test_And_Set

        (Ptr   : Address;

         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;

      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,

                     "__sync_lock_test_and_set_1");

   begin

      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);

      Bit := Set_Bit;

      Old_Value := Old_Uns /= 0;

   end Set_Interlocked;

   procedure Set_Interlocked

     (Bit          : in out Boolean;

      Old_Value    : out Boolean;

      Retry_Count  : Natural;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      Set_Bit : Boolean := Bit;

      Old_Uns : Interfaces.Unsigned_8;

      function Sync_Lock_Test_And_Set

        (Ptr   : Address;

         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;

      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,

                     "__sync_lock_test_and_set_1");

   begin

      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);

      Bit := Set_Bit;

      Old_Value := Old_Uns /= 0;

      Success_Flag := True;

   end Set_Interlocked;

   ---------------------

   -- Add_Interlocked --

   ---------------------

   procedure Add_Interlocked

     (Addend : Short_Integer;

      Augend : in out Aligned_Word;

      Sign   : out Integer)

   is

      Overflowed : Boolean := False;

      Former     : Aligned_Word;

      function Sync_Fetch_And_Add

        (Ptr   : Address;

         Value : Short_Integer) return Short_Integer;

      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");

   begin

      Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);

      if Augend.Value < 0 then

         Sign := -1;

      elsif Augend.Value > 0 then

         Sign := 1;

      else

         Sign := 0;

      end if;

      if Former.Value > 0 and then Augend.Value <= 0 then

         Overflowed := True;

      end if;

      if Overflowed then

         raise Constraint_Error;

      end if;

   end Add_Interlocked;

   ----------------

   -- Add_Atomic --

   ----------------

   procedure Add_Atomic

     (To     : in out Aligned_Integer;

      Amount : Integer)

   is

      procedure Sync_Add_And_Fetch

        (Ptr   : Address;

         Value : Integer);

      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");

   begin

      Sync_Add_And_Fetch (To.Value'Address, Amount);

   end Add_Atomic;

   procedure Add_Atomic

     (To           : in out Aligned_Integer;

      Amount       : Integer;

      Retry_Count  : Natural;

      Old_Value    : out Integer;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      function Sync_Fetch_And_Add

        (Ptr   : Address;

         Value : Integer) return Integer;

      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");

   begin

      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);

      Success_Flag := True;

   end Add_Atomic;

   procedure Add_Atomic

     (To     : in out Aligned_Long_Integer;

      Amount : Long_Integer)

   is

      procedure Sync_Add_And_Fetch

        (Ptr   : Address;

         Value : Long_Integer);

      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");

   begin

      Sync_Add_And_Fetch (To.Value'Address, Amount);

   end Add_Atomic;

   procedure Add_Atomic

     (To           : in out Aligned_Long_Integer;

      Amount       : Long_Integer;

      Retry_Count  : Natural;

      Old_Value    : out Long_Integer;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      function Sync_Fetch_And_Add

        (Ptr   : Address;

         Value : Long_Integer) return Long_Integer;

      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");

      --  Why do we keep importing this over and over again???

   begin

      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);

      Success_Flag := True;

   end Add_Atomic;

   ----------------

   -- And_Atomic --

   ----------------

   procedure And_Atomic

     (To   : in out Aligned_Integer;

      From : Integer)

   is

      procedure Sync_And_And_Fetch

        (Ptr   : Address;

         Value : Integer);

      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");

   begin

      Sync_And_And_Fetch (To.Value'Address, From);

   end And_Atomic;

   procedure And_Atomic

     (To           : in out Aligned_Integer;

      From         : Integer;

      Retry_Count  : Natural;

      Old_Value    : out Integer;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      function Sync_Fetch_And_And

        (Ptr   : Address;

         Value : Integer) return Integer;

      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");

   begin

      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);

      Success_Flag := True;

   end And_Atomic;

   procedure And_Atomic

     (To   : in out Aligned_Long_Integer;

      From : Long_Integer)

   is

      procedure Sync_And_And_Fetch

        (Ptr   : Address;

         Value : Long_Integer);

      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");

   begin

      Sync_And_And_Fetch (To.Value'Address, From);

   end And_Atomic;

   procedure And_Atomic

     (To           : in out Aligned_Long_Integer;

      From         : Long_Integer;

      Retry_Count  : Natural;

      Old_Value    : out Long_Integer;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      function Sync_Fetch_And_And

        (Ptr   : Address;

         Value : Long_Integer) return Long_Integer;

      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");

   begin

      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);

      Success_Flag := True;

   end And_Atomic;

   ---------------

   -- Or_Atomic --

   ---------------

   procedure Or_Atomic

     (To   : in out Aligned_Integer;

      From : Integer)

   is

      procedure Sync_Or_And_Fetch

        (Ptr   : Address;

         Value : Integer);

      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");

   begin

      Sync_Or_And_Fetch (To.Value'Address, From);

   end Or_Atomic;

   procedure Or_Atomic

     (To           : in out Aligned_Integer;

      From         : Integer;

      Retry_Count  : Natural;

      Old_Value    : out Integer;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      function Sync_Fetch_And_Or

        (Ptr   : Address;

         Value : Integer) return Integer;

      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");

   begin

      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);

      Success_Flag := True;

   end Or_Atomic;

   procedure Or_Atomic

     (To   : in out Aligned_Long_Integer;

      From : Long_Integer)

   is

      procedure Sync_Or_And_Fetch

        (Ptr   : Address;

         Value : Long_Integer);

      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");

   begin

      Sync_Or_And_Fetch (To.Value'Address, From);

   end Or_Atomic;

   procedure Or_Atomic

     (To           : in out Aligned_Long_Integer;

      From         : Long_Integer;

      Retry_Count  : Natural;

      Old_Value    : out Long_Integer;

      Success_Flag : out Boolean)

   is

      pragma Unreferenced (Retry_Count);

      function Sync_Fetch_And_Or

        (Ptr   : Address;

         Value : Long_Integer) return Long_Integer;

      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");

   begin

      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);

      Success_Flag := True;

   end Or_Atomic;

   ------------

   -- Insqhi --

   ------------

   procedure Insqhi

     (Item   : Address;

      Header : Address;

      Status : out Insq_Status) is

      procedure SYS_PAL_INSQHIL

        (STATUS : out Integer; Header : Address; ITEM : Address);

      pragma Interface (External, SYS_PAL_INSQHIL);

      pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",

         (Integer, Address, Address),

         (Value, Value, Value));

      Istat : Integer;

   begin

      SYS_PAL_INSQHIL (Istat, Header, Item);

      if Istat = 0 then

         Status := OK_Not_First;

      elsif Istat = 1 then

         Status := OK_First;

      else

         --  This status is never returned on IVMS

         Status := Fail_No_Lock;

      end if;

   end Insqhi;

   ------------

   -- Remqhi --

   ------------

   procedure Remqhi

     (Header : Address;

      Item   : out Address;

      Status : out Remq_Status)

   is

      --  The removed item is returned in the second function return register,

      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in

      --  these registers, so inventing this odd looking record type makes that

      --  all work.

      type Remq is record

         Status : Long_Integer;

         Item   : Address;

      end record;

      procedure SYS_PAL_REMQHIL

        (Remret : out Remq; Header : Address);

      pragma Interface (External, SYS_PAL_REMQHIL);

      pragma Import_Valued_Procedure

        (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",

         (Remq, Address),

         (Value, Value));

      --  Following variables need documentation???

      Rstat  : Long_Integer;

      Remret : Remq;

   begin

      SYS_PAL_REMQHIL (Remret, Header);

      Rstat := Remret.Status;

      Item := Remret.Item;

      if Rstat = 0 then

         Status := Fail_Was_Empty;

      elsif Rstat = 1 then

         Status := OK_Not_Empty;

      elsif Rstat = 2 then

         Status := OK_Empty;

      else

         --  This status is never returned on IVMS

         Status := Fail_No_Lock;

      end if;

   end Remqhi;

   ------------

   -- Insqti --

   ------------

   procedure Insqti

     (Item   : Address;

      Header : Address;

      Status : out Insq_Status) is

      procedure SYS_PAL_INSQTIL

        (STATUS : out Integer; Header : Address; ITEM : Address);

      pragma Interface (External, SYS_PAL_INSQTIL);

      pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",

         (Integer, Address, Address),

         (Value, Value, Value));

      Istat : Integer;

   begin

      SYS_PAL_INSQTIL (Istat, Header, Item);

      if Istat = 0 then

         Status := OK_Not_First;

      elsif Istat = 1 then

         Status := OK_First;

      else

         --  This status is never returned on IVMS

         Status := Fail_No_Lock;

      end if;

   end Insqti;

   ------------

   -- Remqti --

   ------------

   procedure Remqti

     (Header : Address;

      Item   : out Address;

      Status : out Remq_Status)

   is

      --  The removed item is returned in the second function return register,

      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in

      --  these registers, so inventing (where is rest of this comment???)

      type Remq is record

         Status : Long_Integer;

         Item   : Address;

      end record;

      procedure SYS_PAL_REMQTIL

        (Remret : out Remq; Header : Address);

      pragma Interface (External, SYS_PAL_REMQTIL);

      pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",

         (Remq, Address),

         (Value, Value));

      Rstat  : Long_Integer;

      Remret : Remq;

   begin

      SYS_PAL_REMQTIL (Remret, Header);

      Rstat := Remret.Status;

      Item := Remret.Item;

      --  Wouldn't case be nicer here, and in previous similar cases ???

      if Rstat = 0 then

         Status := Fail_Was_Empty;

      elsif Rstat = 1 then

         Status := OK_Not_Empty;

      elsif Rstat = 2 then

         Status := OK_Empty;

      else

         --  This status is never returned on IVMS

         Status := Fail_No_Lock;

      end if;

   end Remqti;

end System.Aux_DEC;