From af0c51ac87ab2a87caa03fa108f0d164987a2764 Mon Sep 17 00:00:00 2001 From: Ben Cheng Date: Thu, 28 Mar 2013 11:14:20 -0700 Subject: [GCC 4.8] Initial check-in of GCC 4.8.0 Change-Id: I0719d8a6d0f69b367a6ab6f10eb75622dbf12771 --- gcc-4.8/gcc/ada/s-auxdec-vms-ia64.adb | 576 ++++++++++++++++++++++++++++++++++ 1 file changed, 576 insertions(+) create mode 100644 gcc-4.8/gcc/ada/s-auxdec-vms-ia64.adb (limited to 'gcc-4.8/gcc/ada/s-auxdec-vms-ia64.adb') diff --git a/gcc-4.8/gcc/ada/s-auxdec-vms-ia64.adb b/gcc-4.8/gcc/ada/s-auxdec-vms-ia64.adb new file mode 100644 index 000000000..b8ca67e85 --- /dev/null +++ b/gcc-4.8/gcc/ada/s-auxdec-vms-ia64.adb @@ -0,0 +1,576 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2012, 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 -- +-- . -- +-- -- +-- 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 Import (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 Import (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 Import (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 Import (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; -- cgit v1.2.3