From patchwork Tue Jul 12 12:25:35 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 55965 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C67513897780 for ; Tue, 12 Jul 2022 12:31:54 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org C67513897780 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1657629114; bh=wpwHg38AZDZEI5FoeYzW7+RHuABb+Bxs1FL3DA9T2ac=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=pzKq+Wwq9FwBkaOdBi+ml/HGdt0H1qjRppPnLFHXzRcFHo+qFcIYzIqyweCbJLQcz 6u0e5wpMcjRBnjlHJfFLp511XnjyM6+PSwXleJHgmXVQshRm3Tk/RKuPdthitsTKYW +buunuEpGn4nCxbW5chwcLnjnJMuwweU9OV1f2dA= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-ed1-x52f.google.com (mail-ed1-x52f.google.com [IPv6:2a00:1450:4864:20::52f]) by sourceware.org (Postfix) with ESMTPS id D842238316DD for ; Tue, 12 Jul 2022 12:25:36 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org D842238316DD Received: by mail-ed1-x52f.google.com with SMTP id r6so9862481edd.7 for ; Tue, 12 Jul 2022 05:25:36 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=wpwHg38AZDZEI5FoeYzW7+RHuABb+Bxs1FL3DA9T2ac=; b=p+/kY0xORBAU27myllBB/exPZq0nnIfOJ20+g05KBClxOPj0sISxsn95Rk3iofCCwr WEIxGFyxDT+yY2YYcZMnMh2rsGpkXvWxi/fiGicwuxjJvxUhbwnaQoJL5RfkfHgKrj1s VXFbeXnqSbitlFaepuMrpQy9aT3F6zn3KU0rf7jnONPhEqNx3URfV73vlqgmAdkEh+Gj Idn5i6Z2Y4GXeoSFNRwloqTYOAV1eCZA92z270c9HPwVEWdrKu5tGhbDA2I8b28uvEH8 H6N2Tl8XHC/+lsZ9eufS2UrJpnSEGbfv+rPMxYPgq55KmgHNwHAPBqIeJR/7BmrI1kqQ GV5w== X-Gm-Message-State: AJIora9dmO+QiFTuFMe5U1VcOvSb8HdVc+b2sKPYFxZ0NKWUYiYK2wbc 31bJL70SkxtXI6zbAewWTUot4lzhffcjqQ== X-Google-Smtp-Source: AGRyM1uMSMLeqorV76uJOTARm7P5jh0cy3GoB8X17wBiYvqUudyiZGglvGzrOeLO9r+hn6rZIK06+A== X-Received: by 2002:a05:6402:5418:b0:435:5a48:daa9 with SMTP id ev24-20020a056402541800b004355a48daa9mr31879795edb.304.1657628736463; Tue, 12 Jul 2022 05:25:36 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id q22-20020a17090676d600b00726314d0655sm2978233ejn.39.2022.07.12.05.25.35 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 12 Jul 2022 05:25:35 -0700 (PDT) Date: Tue, 12 Jul 2022 12:25:35 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Extend No_Dependence restriction to code generation Message-ID: <20220712122535.GA3404974@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.8 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Eric Botcazou Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This makes it possible to report violations of the No_Dependence restriction during code generation, in other words outside of the Ada front-end proper. These violations are supposed to be only for child units of System, so the implementation is restricted to these cases. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * restrict.ads (type ND_Entry): Add System_Child component. (Check_Restriction_No_Dependence_On_System): Declare. * restrict.adb (Global_Restriction_No_Tasking): Move around. (Violation_Of_No_Dependence): New procedure. (Check_Restriction_No_Dependence): Call Violation_Of_No_Dependence to report a violation. (Check_Restriction_No_Dependence_On_System): New procedure. (Set_Restriction_No_Dependenc): Set System_Child component if the unit is a child of System. * snames.ads-tmpl (Name_Arith_64): New package name. (Name_Arith_128): Likewise. (Name_Memory): Likewise. (Name_Stack_Checking): Likewise. * fe.h (Check_Restriction_No_Dependence_On_System): Declare. diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -252,6 +252,8 @@ extern Boolean SJLJ_Exceptions (void); restrict__check_no_implicit_protected_alloc #define Check_No_Implicit_Task_Alloc \ restrict__check_no_implicit_task_alloc +#define Check_Restriction_No_Dependence_On_System \ + restrict__check_restriction_no_dependence_on_system #define No_Exception_Handlers_Set \ restrict__no_exception_handlers_set #define No_Exception_Propagation_Active \ @@ -262,6 +264,7 @@ extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); extern void Check_No_Implicit_Heap_Alloc (Node_Id); extern void Check_No_Implicit_Protected_Alloc (Node_Id); extern void Check_No_Implicit_Task_Alloc (Node_Id); +extern void Check_Restriction_No_Dependence_On_System (Name_Id, Node_Id); extern Boolean No_Exception_Handlers_Set (void); extern Boolean No_Exception_Propagation_Active (void); diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -44,10 +44,6 @@ with Uname; use Uname; package body Restrict is - Global_Restriction_No_Tasking : Boolean := False; - -- Set to True when No_Tasking is set in the run-time package System - -- or in a configuration pragmas file (for example, gnat.adc). - -------------------------------- -- Package Local Declarations -- -------------------------------- @@ -55,6 +51,10 @@ package body Restrict is Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions; -- Save compilation unit restrictions set by config pragma files + Global_Restriction_No_Tasking : Boolean := False; + -- Set to True when No_Tasking is set in the run-time package System + -- or in a configuration pragmas file (for example, gnat.adc). + Restricted_Profile_Result : Boolean := False; -- This switch memoizes the result of Restricted_Profile function calls for -- improved efficiency. Valid only if Restricted_Profile_Cached is True. @@ -122,6 +122,11 @@ package body Restrict is -- message is to be suppressed if this is an internal file and this file is -- not the main unit. Returns True if message is to be suppressed. + procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id); + -- Called if a violation of restriction No_Dependence for Unit at node N + -- is found. This routine outputs the appropriate message, taking care of + -- warning vs real violation. + ------------------- -- Abort_Allowed -- ------------------- @@ -550,8 +555,6 @@ package body Restrict is ------------------------------------- procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is - DU : Node_Id; - begin -- Ignore call if node U is not in the main source unit. This avoids -- cascaded errors, e.g. when Ada.Containers units with other units. @@ -567,26 +570,33 @@ package body Restrict is -- Loop through entries in No_Dependence table to check each one in turn for J in No_Dependences.First .. No_Dependences.Last loop - DU := No_Dependences.Table (J).Unit; + if Same_Unit (No_Dependences.Table (J).Unit, U) then + Violation_Of_No_Dependence (J, Err); + return; + end if; + end loop; + end Check_Restriction_No_Dependence; - if Same_Unit (U, DU) then - Error_Msg_Sloc := Sloc (DU); - Error_Msg_Node_1 := DU; + ----------------------------------------------- + -- Check_Restriction_No_Dependence_On_System -- + ----------------------------------------------- - if No_Dependences.Table (J).Warn then - Error_Msg - ("?*?violation of restriction `No_Dependence '='> &`#", - Sloc (Err)); - else - Error_Msg - ("|violation of restriction `No_Dependence '='> &`#", - Sloc (Err)); - end if; + procedure Check_Restriction_No_Dependence_On_System + (U : Name_Id; + Err : Node_Id) + is + pragma Assert (U /= No_Name); + + begin + -- Loop through entries in No_Dependence table to check each one in turn + for J in No_Dependences.First .. No_Dependences.Last loop + if No_Dependences.Table (J).System_Child = U then + Violation_Of_No_Dependence (J, Err); return; end if; end loop; - end Check_Restriction_No_Dependence; + end Check_Restriction_No_Dependence_On_System; -------------------------------------------------- -- Check_Restriction_No_Specification_Of_Aspect -- @@ -1474,6 +1484,8 @@ package body Restrict is Warn : Boolean; Profile : Profile_Name := No_Profile) is + ND : ND_Entry; + begin -- Loop to check for duplicate entry @@ -1495,7 +1507,26 @@ package body Restrict is -- Entry is not currently in table - No_Dependences.Append ((Unit, Warn, Profile)); + ND := (Unit, No_Name, Warn, Profile); + + -- Check whether this is a child unit of System + + if Nkind (Unit) = N_Selected_Component then + declare + Root : Node_Id := Unit; + + begin + while Nkind (Prefix (Root)) = N_Selected_Component loop + Root := Prefix (Root); + end loop; + + if Chars (Prefix (Root)) = Name_System then + ND.System_Child := Chars (Selector_Name (Root)); + end if; + end; + end if; + + No_Dependences.Append (ND); end Set_Restriction_No_Dependence; -------------------------------------- @@ -1647,6 +1678,24 @@ package body Restrict is end if; end Suppress_Restriction_Message; + -------------------------------- + -- Violation_Of_No_Dependence -- + -------------------------------- + + procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id) is + begin + Error_Msg_Node_1 := No_Dependences.Table (Unit).Unit; + Error_Msg_Sloc := Sloc (Error_Msg_Node_1); + + if No_Dependences.Table (Unit).Warn then + Error_Msg + ("?*?violation of restriction `No_Dependence '='> &`#", Sloc (N)); + else + Error_Msg + ("|violation of restriction `No_Dependence '='> &`#", Sloc (N)); + end if; + end Violation_Of_No_Dependence; + --------------------- -- Tasking_Allowed -- --------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -168,6 +168,9 @@ package Restrict is Unit : Node_Id; -- The unit parameter from the No_Dependence pragma + System_Child : Name_Id; + -- The name if the unit is a child of System, or else No_Name + Warn : Boolean; -- True if from Restriction_Warnings, False if from Restrictions @@ -269,6 +272,13 @@ package Restrict is -- an explicit WITH clause). U is a node for the unit involved, and Err is -- the node to which an error will be attached if necessary. + procedure Check_Restriction_No_Dependence_On_System + (U : Name_Id; + Err : Node_Id); + -- Likewise, but for the child units of System referenced by their name + + -- WARNING: There is a matching C declaration of this subprogram in fe.h + procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id); -- N is the node id for an N_Aspect_Specification, an N_Pragma, or an -- N_Attribute_Definition_Clause. An error message (warning) will be issued diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -274,10 +274,14 @@ package Snames is -- Names for packages that are treated specially by the compiler + Name_Arith_64 : constant Name_Id := N + $; + Name_Arith_128 : constant Name_Id := N + $; Name_Exception_Traces : constant Name_Id := N + $; Name_Finalization : constant Name_Id := N + $; Name_Interfaces : constant Name_Id := N + $; + Name_Memory : constant Name_Id := N + $; Name_Most_Recent_Exception : constant Name_Id := N + $; + Name_Stack_Checking : constant Name_Id := N + $; Name_Standard : constant Name_Id := N + $; Name_System : constant Name_Id := N + $; Name_Text_IO : constant Name_Id := N + $;