Commit b8c9f7af by Arnaud Charlet

[multiple changes]

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.

From-SVN: r230305
parent 4e9ee595
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> 2015-11-13 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Constant_Indexing_OK): If the indexing is the * sem_ch4.adb (Constant_Indexing_OK): If the indexing is the
......
...@@ -979,23 +979,27 @@ package body Bcheck is ...@@ -979,23 +979,27 @@ package body Bcheck is
for J in ALIs.First .. ALIs.Last loop for J in ALIs.First .. ALIs.Last loop
declare declare
A : ALIs_Record renames ALIs.Table (J); A : ALIs_Record renames ALIs.Table (J);
begin begin
for K in A.First_Unit .. A.Last_Unit loop for K in A.First_Unit .. A.Last_Unit loop
declare declare
U : Unit_Record renames Units.Table (K); U : Unit_Record renames Units.Table (K);
begin begin
for L in U.First_With .. U.Last_With loop -- Exclude runtime units from this check since the
if Same_Unit -- user does not care how a runtime unit is
(Withs.Table (L).Uname, ND_Unit) -- implemented.
then
Error_Msg_File_1 := U.Sfile; if not Is_Internal_File_Name (U.Sfile) then
Error_Msg_Name_1 := ND_Unit; for L in U.First_With .. U.Last_With loop
Consistency_Error_Msg if Same_Unit (Withs.Table (L).Uname, ND_Unit)
("file { violates restriction " & then
"No_Dependence => %"); Error_Msg_File_1 := U.Sfile;
end if; Error_Msg_Name_1 := ND_Unit;
end loop; Consistency_Error_Msg
("file { violates restriction " &
"No_Dependence => %");
end if;
end loop;
end if;
end; end;
end loop; end loop;
end; end;
......
...@@ -6306,6 +6306,14 @@ package body Exp_Ch9 is ...@@ -6306,6 +6306,14 @@ package body Exp_Ch9 is
-- Check whether entity in Barrier is external to protected type. -- Check whether entity in Barrier is external to protected type.
-- If so, barrier may not be properly synchronized. -- 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 -- -- Is_Global_Entity --
---------------------- ----------------------
...@@ -6356,6 +6364,81 @@ package body Exp_Ch9 is ...@@ -6356,6 +6364,81 @@ package body Exp_Ch9 is
procedure Check_Unprotected_Barrier is procedure Check_Unprotected_Barrier is
new Traverse_Proc (Is_Global_Entity); 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 -- Start of processing for Expand_Entry_Barrier
begin begin
...@@ -6393,6 +6476,12 @@ package body Exp_Ch9 is ...@@ -6393,6 +6476,12 @@ package body Exp_Ch9 is
Analyze_And_Resolve (Cond, Any_Boolean); Analyze_And_Resolve (Cond, Any_Boolean);
end if; 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 -- The Ravenscar profile restricts barriers to simple variables declared
-- within the protected object. We also allow Boolean constants, since -- within the protected object. We also allow Boolean constants, since
-- these appear in several published examples and are also allowed by -- these appear in several published examples and are also allowed by
...@@ -6421,22 +6510,7 @@ package body Exp_Ch9 is ...@@ -6421,22 +6510,7 @@ package body Exp_Ch9 is
then then
return; return;
elsif not Expander_Active elsif Is_Simple_Barrier_Name (Cond) then
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
return; return;
end if; end if;
end if; end if;
......
...@@ -2299,45 +2299,7 @@ char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */ ...@@ -2299,45 +2299,7 @@ char __gnat_alternate_stack[32 * 1024]; /* 1 * MINSIGSTKSZ */
#ifdef __arm64__ #ifdef __arm64__
#include <sys/ucontext.h> #include <sys/ucontext.h>
#include "sigtramp.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"
);
#endif #endif
/* Return true if ADDR is within a stack guard area. */ /* Return true if ADDR is within a stack guard area. */
...@@ -2425,13 +2387,11 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, ...@@ -2425,13 +2387,11 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED,
} }
static void 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; struct Exception_Data *exception;
const char *msg; const char *msg;
__gnat_adjust_context_for_raise (sig, ucontext);
switch (sig) switch (sig)
{ {
case SIGSEGV: case SIGSEGV:
...@@ -2446,29 +2406,11 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext) ...@@ -2446,29 +2406,11 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
exception = &constraint_error; exception = &constraint_error;
msg = "erroneous memory access"; msg = "erroneous memory access";
} }
/* Reset the use of alt stack, so that the alt stack will be used /* Reset the use of alt stack, so that the alt stack will be used
for the next signal delivery. for the next signal delivery.
The stack can't be used in case of stack checking. */ The stack can't be used in case of stack checking. */
syscall (SYS_sigreturn, NULL, UC_RESET_ALT_STACK); 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; break;
case SIGFPE: case SIGFPE:
...@@ -2484,6 +2426,30 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext) ...@@ -2484,6 +2426,30 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
Raise_From_Signal_Handler (exception, msg); 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 void
__gnat_install_handler (void) __gnat_install_handler (void)
{ {
......
...@@ -147,6 +147,7 @@ package Restrict is ...@@ -147,6 +147,7 @@ package Restrict is
No_Wide_Characters => True, No_Wide_Characters => True,
Static_Priorities => True, Static_Priorities => True,
Static_Storage_Size => True, Static_Storage_Size => True,
Pure_Barriers => True,
SPARK_05 => True, SPARK_05 => True,
others => False); others => False);
......
...@@ -182,6 +182,7 @@ package System.Rident is ...@@ -182,6 +182,7 @@ package System.Rident is
No_Elaboration_Code, -- GNAT No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368 No_Obsolescent_Features, -- Ada 2005 AI-368
No_Wide_Characters, -- GNAT No_Wide_Characters, -- GNAT
Pure_Barriers, -- GNAT
SPARK_05, -- GNAT SPARK_05, -- GNAT
-- The following cases require a parameter value -- The following cases require a parameter value
......
...@@ -7553,13 +7553,16 @@ package body Sem_Util is ...@@ -7553,13 +7553,16 @@ package body Sem_Util is
Cursor := Any_Type; Cursor := Any_Type;
-- Locate function with desired name and profile in scope of 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)); Func := First_Entity (Scope (Typ));
while Present (Func) loop while Present (Func) loop
if Chars (Func) = Chars (First_Op) if Chars (Func) = Chars (First_Op)
and then Ekind (Func) = E_Function and then Ekind (Func) = E_Function
and then Present (First_Formal (Func)) 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))) and then No (Next_Formal (First_Formal (Func)))
then then
if Cursor /= Any_Type then if Cursor /= Any_Type then
......
/****************************************************************************
* *
* 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"
);
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment