aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/ada/ChangeLog28
-rw-r--r--gcc/ada/bcheck.adb28
-rw-r--r--gcc/ada/exp_ch9.adb106
-rw-r--r--gcc/ada/init.c88
-rw-r--r--gcc/ada/restrict.ads1
-rw-r--r--gcc/ada/s-rident.ads1
-rw-r--r--gcc/ada/sem_util.adb5
-rw-r--r--gcc/ada/sigtramp-armios.c98
8 files changed, 265 insertions, 90 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 90910ca..324d4dc 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,31 @@
+2015-11-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * init.c [Darwin/arm64]: Move __gnat_sigtramp implementation to...
+ (__gnat_map_signal): New function.
+ (__gnat_error_handler):
+ Adjust the context and call above function.
+ * sigtramp-armios.c: ...here. New file.
+
+2015-11-13 Arnaud Charlet <charlet@adacore.com>
+
+ * bcheck.adb (Check_Consistent_Restrictions): Do not check
+ consistency of No_Dependence for runtime units.
+
+2015-11-13 Tristan Gingold <gingold@adacore.com>
+
+ * s-rident.ads (Restriction_Id): Add Pure_Barriers.
+ * restrict.ads (Implementation_Restriction): Add Pure_Barriers.
+ * exp_ch9.adb (Expand_Entry_Barrier): Create
+ Is_Simple_Barrier_Name function, add Is_Pure_Barrier and
+ Check_Pure_Barriers.
+
+2015-11-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Get_Cursor_Type): To determine whether a function
+ First is the proper Iterable primitive, use the base type of the
+ first formal rather than the type. This is needed in the unusual
+ case where the Iterable aspect is specified for an integer type.
+
2015-11-13 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Constant_Indexing_OK): If the indexing is the
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 2cae840..4170b0e 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -979,23 +979,27 @@ package body Bcheck is
for J in ALIs.First .. ALIs.Last loop
declare
A : ALIs_Record renames ALIs.Table (J);
-
begin
for K in A.First_Unit .. A.Last_Unit loop
declare
U : Unit_Record renames Units.Table (K);
begin
- for L in U.First_With .. U.Last_With loop
- if Same_Unit
- (Withs.Table (L).Uname, ND_Unit)
- then
- Error_Msg_File_1 := U.Sfile;
- Error_Msg_Name_1 := ND_Unit;
- Consistency_Error_Msg
- ("file { violates restriction " &
- "No_Dependence => %");
- end if;
- end loop;
+ -- Exclude runtime units from this check since the
+ -- user does not care how a runtime unit is
+ -- implemented.
+
+ if not Is_Internal_File_Name (U.Sfile) then
+ for L in U.First_With .. U.Last_With loop
+ if Same_Unit (Withs.Table (L).Uname, ND_Unit)
+ then
+ Error_Msg_File_1 := U.Sfile;
+ Error_Msg_Name_1 := ND_Unit;
+ Consistency_Error_Msg
+ ("file { violates restriction " &
+ "No_Dependence => %");
+ end if;
+ end loop;
+ end if;
end;
end loop;
end;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 2fd6592..f985019 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -6306,6 +6306,14 @@ package body Exp_Ch9 is
-- Check whether entity in Barrier is external to protected type.
-- If so, barrier may not be properly synchronized.
+ function Is_Pure_Barrier (N : Node_Id) return Traverse_Result;
+ -- Check whether N follow the Pure_Barriers restriction. Return OK if
+ -- so.
+
+ function Is_Simple_Barrier_Name (N : Node_Id) return Boolean;
+ -- Check wether entity name N denotes a component of the protected
+ -- object. This is used to check the Simple_Barrier restriction.
+
----------------------
-- Is_Global_Entity --
----------------------
@@ -6356,6 +6364,81 @@ package body Exp_Ch9 is
procedure Check_Unprotected_Barrier is
new Traverse_Proc (Is_Global_Entity);
+ ----------------------------
+ -- Is_Simple_Barrier_Name --
+ ----------------------------
+
+ function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is
+ Renamed : Node_Id;
+ begin
+ if not Expander_Active then
+ return Scope (Entity (N)) = Current_Scope;
+
+ -- Check for case of _object.all.field (note that the explicit
+ -- dereference gets inserted by analyze/expand of _object.field)
+
+ else
+ Renamed := Renamed_Object (Entity (N));
+ return Present (Renamed)
+ and then Nkind (Renamed) = N_Selected_Component
+ and then Chars (Prefix (Prefix (Renamed))) = Name_uObject;
+ end if;
+ end Is_Simple_Barrier_Name;
+
+ ---------------------
+ -- Is_Pure_Barrier --
+ ---------------------
+
+ function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
+ begin
+ case Nkind (N) is
+ when N_Identifier
+ | N_Expanded_Name =>
+
+ if No (Entity (N)) then
+ return Abandon;
+ end if;
+
+ case Ekind (Entity (N)) is
+ when E_Constant
+ | E_Discriminant
+ | E_Named_Integer
+ | E_Named_Real
+ | E_Enumeration_Literal =>
+ return OK;
+
+ when E_Variable =>
+ if Is_Simple_Barrier_Name (N) then
+ return OK;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ when N_Integer_Literal
+ | N_Real_Literal
+ | N_Character_Literal =>
+ return OK;
+
+ when N_Op_Boolean
+ | N_Op_Not =>
+ if Ekind (Entity (N)) = E_Operator then
+ return OK;
+ end if;
+
+ when N_Short_Circuit =>
+ return OK;
+
+ when others =>
+ null;
+ end case;
+
+ return Abandon;
+ end Is_Pure_Barrier;
+
+ function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier);
+
-- Start of processing for Expand_Entry_Barrier
begin
@@ -6393,6 +6476,12 @@ package body Exp_Ch9 is
Analyze_And_Resolve (Cond, Any_Boolean);
end if;
+ -- Check Pure_Barriers restriction
+
+ if Check_Pure_Barriers (Cond) = Abandon then
+ Check_Restriction (Pure_Barriers, Cond);
+ end if;
+
-- The Ravenscar profile restricts barriers to simple variables declared
-- within the protected object. We also allow Boolean constants, since
-- these appear in several published examples and are also allowed by
@@ -6421,22 +6510,7 @@ package body Exp_Ch9 is
then
return;
- elsif not Expander_Active
- and then Scope (Entity (Cond)) = Current_Scope
- then
- return;
-
- -- Check for case of _object.all.field (note that the explicit
- -- dereference gets inserted by analyze/expand of _object.field)
-
- elsif Present (Renamed_Object (Entity (Cond)))
- and then
- Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component
- and then
- Chars
- (Prefix
- (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject
- then
+ elsif Is_Simple_Barrier_Name (Cond) then
return;
end if;
end if;
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index f0afc40..dcd5c3d 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -2299,45 +2299,7 @@ char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */
#ifdef __arm64__
#include <sys/ucontext.h>
-
-/* Trampoline inserted before raising the exception. It modifies the
- stack so that it looks to be called directly from the fault point.
- Note that LR may be incorrectly restored by unwinding. */
-void __gnat_sigtramp (struct Exception_Data *d, const char *m,
- mcontext_t ctxt,
- void (*proc)(struct Exception_Data *, const char *));
-
-asm("\n"
-" .section __TEXT,__text,regular,pure_instructions\n"
-" .align 2\n"
-"___gnat_sigtramp:\n"
-" .cfi_startproc\n"
- /* Restore callee saved registers. */
-" ldp x19, x20, [x2, #168]\n"
-" ldp x21, x22, [x2, #184]\n"
-" ldp x23, x24, [x2, #200]\n"
-" ldp x25, x26, [x2, #216]\n"
-" ldp x27, x28, [x2, #232]\n"
-" ldp q8, q9, [x2, #416]\n"
-" ldp q10, q11, [x2, #448]\n"
-" ldp q12, q13, [x2, #480]\n"
-" ldp q14, q15, [x2, #512]\n"
- /* Read FP from mcontext. */
-" ldr fp, [x2, #248]\n"
- /* Read SP and PC from mcontext. */
-" ldp x6, lr, [x2, #264]\n"
-" mov sp, x6\n"
- /* Create a minimal frame. */
-" stp fp, lr, [sp, #-16]!\n"
-" .cfi_def_cfa_offset 16\n"
-" .cfi_offset 30, -8\n"
-" .cfi_offset 29, -16\n"
-" blr x3\n"
- /* Release our frame and return (should never get here!). */
-" ldp fp, lr, [sp, #16]\n"
-" ret\n"
-" .cfi_endproc\n"
-);
+#include "sigtramp.h"
#endif
/* Return true if ADDR is within a stack guard area. */
@@ -2425,13 +2387,11 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED,
}
static void
-__gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
+__gnat_map_signal (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED)
{
struct Exception_Data *exception;
const char *msg;
- __gnat_adjust_context_for_raise (sig, ucontext);
-
switch (sig)
{
case SIGSEGV:
@@ -2446,29 +2406,11 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
exception = &constraint_error;
msg = "erroneous memory access";
}
+
/* Reset the use of alt stack, so that the alt stack will be used
for the next signal delivery.
The stack can't be used in case of stack checking. */
syscall (SYS_sigreturn, NULL, UC_RESET_ALT_STACK);
-
-#ifdef __arm64__
- /* ??? Temporary kludge to make stack checking work. The problem is
- that the trampoline doesn't restore LR and, consequently, doesn't
- make it possible to unwind past an interrupted frame which hasn"t
- saved LR on the stack yet. */
- if (__gnat_is_stack_guard ((unsigned long)si->si_addr))
- {
- ucontext_t *uc = (ucontext_t *)ucontext;
- uc->uc_mcontext->__ss.__pc = uc->uc_mcontext->__ss.__lr;
- }
-
- /* On arm64, use a trampoline so that the unwinder won't see the
- signal frame. */
- __gnat_sigtramp (exception, msg,
- ((ucontext_t *)ucontext)->uc_mcontext,
- Raise_From_Signal_Handler);
- return;
-#endif
break;
case SIGFPE:
@@ -2484,6 +2426,30 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
Raise_From_Signal_Handler (exception, msg);
}
+static void
+__gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
+{
+ __gnat_adjust_context_for_raise (sig, ucontext);
+
+#ifdef __arm64__
+ /* ??? Temporary kludge to make stack checking work. The problem is
+ that the trampoline doesn't restore LR and, consequently, doesn't
+ make it possible to unwind past an interrupted frame which hasn"t
+ saved LR on the stack yet. */
+ if (__gnat_is_stack_guard ((unsigned long)si->si_addr))
+ {
+ ucontext_t *uc = (ucontext_t *)ucontext;
+ uc->uc_mcontext->__ss.__pc = uc->uc_mcontext->__ss.__lr;
+ }
+
+ /* Use a trampoline so that the unwinder won't see the signal frame. */
+ __gnat_sigtramp (sig, (void *)si, ucontext,
+ (__sigtramphandler_t *)&__gnat_map_signal);
+#else
+ __gnat_map_signal (sig, si, ucontext);
+#endif
+}
+
void
__gnat_install_handler (void)
{
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
index 6ce7908..c8c050c 100644
--- a/gcc/ada/restrict.ads
+++ b/gcc/ada/restrict.ads
@@ -147,6 +147,7 @@ package Restrict is
No_Wide_Characters => True,
Static_Priorities => True,
Static_Storage_Size => True,
+ Pure_Barriers => True,
SPARK_05 => True,
others => False);
diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads
index 58c69d8..66aa10e 100644
--- a/gcc/ada/s-rident.ads
+++ b/gcc/ada/s-rident.ads
@@ -182,6 +182,7 @@ package System.Rident is
No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368
No_Wide_Characters, -- GNAT
+ Pure_Barriers, -- GNAT
SPARK_05, -- GNAT
-- The following cases require a parameter value
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 59194cf..36dfc4d 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -7553,13 +7553,16 @@ package body Sem_Util is
Cursor := Any_Type;
-- Locate function with desired name and profile in scope of type
+ -- In the rare case where the type is an integer type, a base type
+ -- is created for it, check that the base type of the first formal
+ -- of First matches the base type of the domain.
Func := First_Entity (Scope (Typ));
while Present (Func) loop
if Chars (Func) = Chars (First_Op)
and then Ekind (Func) = E_Function
and then Present (First_Formal (Func))
- and then Etype (First_Formal (Func)) = Typ
+ and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
and then No (Next_Formal (First_Formal (Func)))
then
if Cursor /= Any_Type then
diff --git a/gcc/ada/sigtramp-armios.c b/gcc/ada/sigtramp-armios.c
new file mode 100644
index 0000000..3206256
--- /dev/null
+++ b/gcc/ada/sigtramp-armios.c
@@ -0,0 +1,98 @@
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * S I G T R A M P *
+ * *
+ * Asm Implementation File *
+ * *
+ * Copyright (C) 2015, 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. *
+ * *
+ * In particular, you can freely distribute your programs built with the *
+ * GNAT Pro compiler, including any required library run-time units, using *
+ * any licensing terms of your choosing. See the AdaCore Software License *
+ * for full details. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+/**************************************************
+ * ARM-IOS version of the __gnat_sigtramp service *
+ **************************************************/
+
+#include <sys/ucontext.h>
+
+#include "sigtramp.h"
+/* See sigtramp.h for a general explanation of functionality. */
+
+/* -----------------------------------------
+ -- Protypes for our internal asm stubs --
+ -----------------------------------------
+
+ The registers are expected to be at SIGCONTEXT + OFFSET (reference to the
+ machine context structure). Even though our symbols will remain local, the
+ prototype claims "extern" and not "static" to prevent compiler complaints
+ about a symbol used but never defined. */
+
+/* sigtramp stub providing unwind info for common registers. */
+
+extern void __gnat_sigtramp_common
+ (int signo, void *siginfo, void *sigcontext,
+ __sigtramphandler_t * handler);
+
+void __gnat_sigtramp (int signo, void *si, void *ucontext,
+ __sigtramphandler_t * handler)
+ __attribute__((optimize(2)));
+
+void __gnat_sigtramp (int signo, void *si, void *ucontext,
+ __sigtramphandler_t * handler)
+{
+ mcontext_t mcontext = ((ucontext_t *) ucontext)->uc_mcontext;
+
+ __gnat_sigtramp_common (signo, si, mcontext, handler);
+}
+
+asm("\n"
+" .section __TEXT,__text,regular,pure_instructions\n"
+" .align 2\n"
+"___gnat_sigtramp_common:\n"
+" .cfi_startproc\n"
+ /* Restore callee saved registers. */
+" ldp x19, x20, [x2, #168]\n"
+" ldp x21, x22, [x2, #184]\n"
+" ldp x23, x24, [x2, #200]\n"
+" ldp x25, x26, [x2, #216]\n"
+" ldp x27, x28, [x2, #232]\n"
+" ldp q8, q9, [x2, #416]\n"
+" ldp q10, q11, [x2, #448]\n"
+" ldp q12, q13, [x2, #480]\n"
+" ldp q14, q15, [x2, #512]\n"
+ /* Read FP from mcontext. */
+" ldr fp, [x2, #248]\n"
+ /* Read SP and PC from mcontext. */
+" ldp x6, lr, [x2, #264]\n"
+" mov sp, x6\n"
+ /* Create a minimal frame. */
+" stp fp, lr, [sp, #-16]!\n"
+" .cfi_def_cfa_offset 16\n"
+" .cfi_offset 30, -8\n"
+" .cfi_offset 29, -16\n"
+" blr x3\n"
+ /* Release our frame and return (should never get here!). */
+" ldp fp, lr, [sp, #16]\n"
+" ret\n"
+" .cfi_endproc\n"
+);
generated by cgit v1.1 at 2025-05-31 13:32:19 +0000