diff --git a/INSTALL.md b/INSTALL.md index 55e6bfd..c484969 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -33,6 +33,7 @@ Values for `RELEASE` are as below: | GNAT GPL 2017 | `gnat-gpl-2017` | | GNAT CE 2018 | `gcc8` | | GNAT CE 2019 | `gcc8` | +| GNAT CE 2020 | `gnat-ce-2020` | Build by running make RELEASE=release all at the top level (or, if you only want one runtime, by make RELEASE=release in that runtime's subdirectory). diff --git a/README.md b/README.md index aa1662e..88ba403 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ This package includes GNAT Ada Run Time Systems (RTSs) based on [FreeRTOS](http://www.freertos.org) and targeted at boards with -Cortex-M0, M3, -M4, -M4F MCUs +Cortex-M0, -M3, -M4, -M4F MCUs (respectively [BBC micro:bit](http://microbit.org), [Arduino Due](https://www.arduino.cc), and the STM32F4-series evaluation diff --git a/common/common.gpr b/common/common.gpr index dafff72..0f219f5 100644 --- a/common/common.gpr +++ b/common/common.gpr @@ -18,7 +18,8 @@ abstract project Common is - type Compiler_Release is ("gcc6", "gnat-gpl-2017", "gcc7", "gcc8"); + type Compiler_Release is + ("gcc6", "gnat-gpl-2017", "gcc7", "gcc8", "gnat-ce-2020"); Release : Compiler_Release := external ("RELEASE", "gcc8"); type Install_Locally is ("yes", "no"); diff --git a/common/gnat-ce-2020/a-tags.adb b/common/gnat-ce-2020/a-tags.adb new file mode 100644 index 0000000..88875c8 --- /dev/null +++ b/common/gnat-ce-2020/a-tags.adb @@ -0,0 +1,1111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A G S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2020, 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 file has been modified from the gcc-mirror version at +-- commit [ead7594] for Cortex GNAT RTS (only by commenting-out the +-- Wide_*Expanded_Name functions). + +with Ada.Exceptions; +with Ada.Unchecked_Conversion; + +with System.HTable; +with System.Storage_Elements; use System.Storage_Elements; +-- with System.WCh_Con; use System.WCh_Con; +-- with System.WCh_StW; use System.WCh_StW; + +pragma Elaborate (System.HTable); +-- Elaborate needed instead of Elaborate_All to avoid elaboration cycles +-- when polling is turned on. This is safe because HTable doesn't do anything +-- at elaboration time; it just contains a generic package we want to +-- instantiate. + +package body Ada.Tags is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_External_Tag (T : Tag) return System.Address; + -- Returns address of a null terminated string containing the external name + + function Is_Primary_DT (T : Tag) return Boolean; + -- Given a tag returns True if it has the signature of a primary dispatch + -- table. This is Inline_Always since it is called from other Inline_ + -- Always subprograms where we want no out of line code to be generated. + + function IW_Membership + (Descendant_TSD : Type_Specific_Data_Ptr; + T : Tag) return Boolean; + -- Subsidiary function of IW_Membership and CW_Membership which factorizes + -- the functionality needed to check if a given descendant implements an + -- interface tag T. + + function Length (Str : Cstring_Ptr) return Natural; + -- Length of string represented by the given pointer (treating the string + -- as a C-style string, which is Nul terminated). See comment in body + -- explaining why we cannot use the normal strlen built-in. + + function OSD (T : Tag) return Object_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, + -- retrieve the address of the record containing the Object Specific + -- Data table. + + function SSD (T : Tag) return Select_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the + -- address of the record containing the Select Specific Data in T's TSD. + + pragma Inline_Always (Get_External_Tag); + pragma Inline_Always (Is_Primary_DT); + pragma Inline_Always (OSD); + pragma Inline_Always (SSD); + + -- Unchecked conversions + + function To_Address is + new Unchecked_Conversion (Cstring_Ptr, System.Address); + + function To_Cstring_Ptr is + new Unchecked_Conversion (System.Address, Cstring_Ptr); + + -- Disable warnings on possible aliasing problem + + function To_Tag is + new Unchecked_Conversion (Integer_Address, Tag); + + function To_Addr_Ptr is + new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); + + function To_Address is + new Ada.Unchecked_Conversion (Tag, System.Address); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); + + function To_Object_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); + + function To_Tag_Ptr is + new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); + + function To_Type_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); + + ------------------------------- + -- Inline_Always Subprograms -- + ------------------------------- + + -- Inline_always subprograms must be placed before their first call to + -- avoid defeating the frontend inlining mechanism and thus ensure the + -- generation of their correct debug info. + + ------------------- + -- CW_Membership -- + ------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Typ'Class + + -- Each dispatch table contains a reference to a table of ancestors (stored + -- in the first part of the Tags_Table) and a count of the level of + -- inheritance "Idepth". + + -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are + -- contained in the dispatch table referenced by Obj'Tag . Knowing the + -- level of inheritance of both types, this can be computed in constant + -- time by the formula: + + -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) + -- = Typ'tag + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is + Obj_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size); + Typ_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size); + Obj_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all); + Typ_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all); + Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth; + begin + return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag; + end CW_Membership; + + ---------------------- + -- Get_External_Tag -- + ---------------------- + + function Get_External_Tag (T : Tag) return System.Address is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return To_Address (TSD.External_Tag); + end Get_External_Tag; + + ----------------- + -- Is_Abstract -- + ----------------- + + function Is_Abstract (T : Tag) return Boolean is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + return TSD.Is_Abstract; + end Is_Abstract; + + ------------------- + -- Is_Primary_DT -- + ------------------- + + function Is_Primary_DT (T : Tag) return Boolean is + begin + return DT (T).Signature = Primary_DT; + end Is_Primary_DT; + + --------- + -- OSD -- + --------- + + function OSD (T : Tag) return Object_Specific_Data_Ptr is + OSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + begin + return To_Object_Specific_Data_Ptr (OSD_Ptr.all); + end OSD; + + --------- + -- SSD -- + --------- + + function SSD (T : Tag) return Select_Specific_Data_Ptr is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.SSD; + end SSD; + + ------------------------- + -- External_Tag_HTable -- + ------------------------- + + type HTable_Headers is range 1 .. 64; + + -- The following internal package defines the routines used for the + -- instantiation of a new System.HTable.Static_HTable (see below). See + -- spec in g-htable.ads for details of usage. + + package HTable_Subprograms is + procedure Set_HT_Link (T : Tag; Next : Tag); + function Get_HT_Link (T : Tag) return Tag; + function Hash (F : System.Address) return HTable_Headers; + function Equal (A, B : System.Address) return Boolean; + end HTable_Subprograms; + + package External_Tag_HTable is new System.HTable.Static_HTable ( + Header_Num => HTable_Headers, + Element => Dispatch_Table, + Elmt_Ptr => Tag, + Null_Ptr => null, + Set_Next => HTable_Subprograms.Set_HT_Link, + Next => HTable_Subprograms.Get_HT_Link, + Key => System.Address, + Get_Key => Get_External_Tag, + Hash => HTable_Subprograms.Hash, + Equal => HTable_Subprograms.Equal); + + ------------------------ + -- HTable_Subprograms -- + ------------------------ + + -- Bodies of routines for hash table instantiation + + package body HTable_Subprograms is + + ----------- + -- Equal -- + ----------- + + function Equal (A, B : System.Address) return Boolean is + Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); + Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); + J : Integer; + begin + J := 1; + loop + if Str1 (J) /= Str2 (J) then + return False; + elsif Str1 (J) = ASCII.NUL then + return True; + else + J := J + 1; + end if; + end loop; + end Equal; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link (T : Tag) return Tag is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.HT_Link.all; + end Get_HT_Link; + + ---------- + -- Hash -- + ---------- + + function Hash (F : System.Address) return HTable_Headers is + function H is new System.HTable.Hash (HTable_Headers); + Str : constant Cstring_Ptr := To_Cstring_Ptr (F); + Res : constant HTable_Headers := H (Str (1 .. Length (Str))); + begin + return Res; + end Hash; + + ----------------- + -- Set_HT_Link -- + ----------------- + + procedure Set_HT_Link (T : Tag; Next : Tag) is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + TSD.HT_Link.all := Next; + end Set_HT_Link; + + end HTable_Subprograms; + + ------------------ + -- Base_Address -- + ------------------ + + function Base_Address (This : System.Address) return System.Address is + begin + return This + Offset_To_Top (This); + end Base_Address; + + --------------- + -- Check_TSD -- + --------------- + + procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is + T : Tag; + + E_Tag_Len : constant Integer := Length (TSD.External_Tag); + E_Tag : String (1 .. E_Tag_Len); + for E_Tag'Address use TSD.External_Tag.all'Address; + pragma Import (Ada, E_Tag); + + Dup_Ext_Tag : constant String := "duplicated external tag """; + + begin + -- Verify that the external tag of this TSD is not registered in the + -- runtime hash table. + + T := External_Tag_HTable.Get (To_Address (TSD.External_Tag)); + + if T /= null then + + -- Avoid concatenation, as it is not allowed in no run time mode + + declare + Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1); + begin + Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag; + Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) := + E_Tag; + Msg (Msg'Last) := '"'; + raise Program_Error with Msg; + end; + end if; + end Check_TSD; + + -------------------- + -- Descendant_Tag -- + -------------------- + + function Descendant_Tag (External : String; Ancestor : Tag) return Tag is + Int_Tag : constant Tag := Internal_Tag (External); + begin + if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then + raise Tag_Error; + else + return Int_Tag; + end if; + end Descendant_Tag; + + -------------- + -- Displace -- + -------------- + + function Displace (This : System.Address; T : Tag) return System.Address is + Iface_Table : Interface_Data_Ptr; + Obj_Base : System.Address; + Obj_DT : Dispatch_Table_Ptr; + Obj_DT_Tag : Tag; + + begin + if System."=" (This, System.Null_Address) then + return System.Null_Address; + end if; + + Obj_Base := Base_Address (This); + Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all; + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then + + -- Case of Static value of Offset_To_Top + + if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then + Obj_Base := Obj_Base - + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value; + + -- Otherwise call the function generated by the expander to + -- provide the value. + + else + Obj_Base := Obj_Base - + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all + (Obj_Base); + end if; + + return Obj_Base; + end if; + end loop; + end if; + + -- Check if T is an immediate ancestor. This is required to handle + -- conversion of class-wide interfaces to tagged types. + + if CW_Membership (Obj_DT_Tag, T) then + return Obj_Base; + end if; + + -- If the object does not implement the interface we must raise CE + + raise Constraint_Error with "invalid interface conversion"; + end Displace; + + -------- + -- DT -- + -------- + + function DT (T : Tag) return Dispatch_Table_Ptr is + Offset : constant SSE.Storage_Offset := + To_Dispatch_Table_Ptr (T).Prims_Ptr'Position; + begin + return To_Dispatch_Table_Ptr (To_Address (T) - Offset); + end DT; + + ------------------- + -- IW_Membership -- + ------------------- + + function IW_Membership + (Descendant_TSD : Type_Specific_Data_Ptr; + T : Tag) return Boolean + is + Iface_Table : Interface_Data_Ptr; + + begin + Iface_Table := Descendant_TSD.Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then + return True; + end if; + end loop; + end if; + + -- Look for the tag in the ancestor tags table. This is required for: + -- Iface_CW in Typ'Class + + for Id in 0 .. Descendant_TSD.Idepth loop + if Descendant_TSD.Tags_Table (Id) = T then + return True; + end if; + end loop; + + return False; + end IW_Membership; + + ------------------- + -- IW_Membership -- + ------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Iface'Class + + -- Each dispatch table contains a table with the tags of all the + -- implemented interfaces. + + -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces + -- that are contained in the dispatch table referenced by Obj'Tag. + + function IW_Membership (This : System.Address; T : Tag) return Boolean is + Obj_Base : System.Address; + Obj_DT : Dispatch_Table_Ptr; + Obj_TSD : Type_Specific_Data_Ptr; + + begin + Obj_Base := Base_Address (This); + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD); + + return IW_Membership (Obj_TSD, T); + end IW_Membership; + + ------------------- + -- Expanded_Name -- + ------------------- + + function Expanded_Name (T : Tag) return String is + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.Expanded_Name; + return Result (1 .. Length (Result)); + end Expanded_Name; + + ------------------ + -- External_Tag -- + ------------------ + + function External_Tag (T : Tag) return String is + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.External_Tag; + return Result (1 .. Length (Result)); + end External_Tag; + + --------------------- + -- Get_Entry_Index -- + --------------------- + + function Get_Entry_Index (T : Tag; Position : Positive) return Positive is + begin + return SSD (T).SSD_Table (Position).Index; + end Get_Entry_Index; + + ---------------------- + -- Get_Prim_Op_Kind -- + ---------------------- + + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind + is + begin + return SSD (T).SSD_Table (Position).Kind; + end Get_Prim_Op_Kind; + + ---------------------- + -- Get_Offset_Index -- + ---------------------- + + function Get_Offset_Index + (T : Tag; + Position : Positive) return Positive + is + begin + if Is_Primary_DT (T) then + return Position; + else + return OSD (T).OSD_Table (Position); + end if; + end Get_Offset_Index; + + --------------------- + -- Get_Tagged_Kind -- + --------------------- + + function Get_Tagged_Kind (T : Tag) return Tagged_Kind is + begin + return DT (T).Tag_Kind; + end Get_Tagged_Kind; + + ----------------------------- + -- Interface_Ancestor_Tags -- + ----------------------------- + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; + + begin + if Iface_Table = null then + declare + Table : Tag_Array (1 .. 0); + begin + return Table; + end; + + else + declare + Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); + begin + for J in 1 .. Iface_Table.Nb_Ifaces loop + Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; + end loop; + + return Table; + end; + end if; + end Interface_Ancestor_Tags; + + ------------------ + -- Internal_Tag -- + ------------------ + + -- Internal tags have the following format: + -- "Internal tag at 16#ADDRESS#: " + + Internal_Tag_Header : constant String := "Internal tag at "; + Header_Separator : constant Character := '#'; + + function Internal_Tag (External : String) return Tag is + pragma Unsuppress (All_Checks); + -- To make T'Class'Input robust in the case of bad data + + Res : Tag := null; + + begin + -- Raise Tag_Error for empty strings and very long strings. This makes + -- T'Class'Input robust in the case of bad data, for example + -- + -- String (123456789..1234) + -- + -- The limit of 10,000 characters is arbitrary, but is unlikely to be + -- exceeded by legitimate external tag names. + + if External'Length not in 1 .. 10_000 then + raise Tag_Error; + end if; + + -- Handle locally defined tagged types + + if External'Length > Internal_Tag_Header'Length + and then + External (External'First .. + External'First + Internal_Tag_Header'Length - 1) = + Internal_Tag_Header + then + declare + Addr_First : constant Natural := + External'First + Internal_Tag_Header'Length; + Addr_Last : Natural; + Addr : Integer_Address; + + begin + -- Search the second separator (#) to identify the address + + Addr_Last := Addr_First; + + for J in 1 .. 2 loop + while Addr_Last <= External'Last + and then External (Addr_Last) /= Header_Separator + loop + Addr_Last := Addr_Last + 1; + end loop; + + -- Skip the first separator + + if J = 1 then + Addr_Last := Addr_Last + 1; + end if; + end loop; + + if Addr_Last <= External'Last then + + -- Protect the run-time against wrong internal tags. We + -- cannot use exception handlers here because it would + -- disable the use of this run-time compiling with + -- restriction No_Exception_Handler. + + declare + C : Character; + Wrong_Tag : Boolean := False; + + begin + if External (Addr_First) /= '1' + or else External (Addr_First + 1) /= '6' + or else External (Addr_First + 2) /= '#' + then + Wrong_Tag := True; + + else + for J in Addr_First + 3 .. Addr_Last - 1 loop + C := External (J); + + if not (C in '0' .. '9') + and then not (C in 'A' .. 'F') + and then not (C in 'a' .. 'f') + then + Wrong_Tag := True; + exit; + end if; + end loop; + end if; + + -- Convert the numeric value into a tag + + if not Wrong_Tag then + Addr := Integer_Address'Value + (External (Addr_First .. Addr_Last)); + + -- Internal tags never have value 0 + + if Addr /= 0 then + return To_Tag (Addr); + end if; + end if; + end; + end if; + end; + + -- Handle library-level tagged types + + else + -- Make NUL-terminated copy of external tag string + + declare + Ext_Copy : aliased String (External'First .. External'Last + 1); + pragma Assert (Ext_Copy'Length > 1); -- See Length check at top + begin + Ext_Copy (External'Range) := External; + Ext_Copy (Ext_Copy'Last) := ASCII.NUL; + Res := External_Tag_HTable.Get (Ext_Copy'Address); + end; + end if; + + if Res = null then + declare + Msg1 : constant String := "unknown tagged type: "; + Msg2 : String (1 .. Msg1'Length + External'Length); + + begin + Msg2 (1 .. Msg1'Length) := Msg1; + Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := + External; + Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2); + end; + end if; + + return Res; + end Internal_Tag; + + --------------------------------- + -- Is_Descendant_At_Same_Level -- + --------------------------------- + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean + is + begin + if Descendant = Ancestor then + return True; + + else + declare + D_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size); + A_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size); + D_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (D_TSD_Ptr.all); + A_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (A_TSD_Ptr.all); + begin + return + D_TSD.Access_Level = A_TSD.Access_Level + and then (CW_Membership (Descendant, Ancestor) + or else IW_Membership (D_TSD, Ancestor)); + end; + end if; + end Is_Descendant_At_Same_Level; + + ------------ + -- Length -- + ------------ + + -- Note: This unit is used in the Ravenscar runtime library, so it cannot + -- depend on System.CTRL. Furthermore, this happens on CPUs where the GCC + -- intrinsic strlen may not be available, so we need to recode our own Ada + -- version here. + + function Length (Str : Cstring_Ptr) return Natural is + Len : Integer; + + begin + Len := 1; + while Str (Len) /= ASCII.NUL loop + Len := Len + 1; + end loop; + + return Len - 1; + end Length; + + ------------------- + -- Offset_To_Top -- + ------------------- + + function Offset_To_Top + (This : System.Address) return SSE.Storage_Offset + is + Tag_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + + type Storage_Offset_Ptr is access SSE.Storage_Offset; + function To_Storage_Offset_Ptr is + new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); + + Curr_DT : Dispatch_Table_Ptr; + + begin + Curr_DT := DT (To_Tag_Ptr (This).all); + + -- See the documentation of Dispatch_Table_Wrapper.Offset_To_Top + + if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then + + -- The parent record type has variable-size components, so the + -- instance-specific offset is stored in the tagged record, right + -- after the reference to Curr_DT (which is a secondary dispatch + -- table). + + return To_Storage_Offset_Ptr (This + Tag_Size).all; + + else + -- The offset is compile-time known, so it is simply stored in the + -- Offset_To_Top field. + + return Curr_DT.Offset_To_Top; + end if; + end Offset_To_Top; + + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Tag) return Boolean is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.Needs_Finalization; + end Needs_Finalization; + + ----------------- + -- Parent_Size -- + ----------------- + + function Parent_Size + (Obj : System.Address; + T : Tag) return SSE.Storage_Count + is + Parent_Slot : constant Positive := 1; + -- The tag of the parent is always in the first slot of the table of + -- ancestor tags. + + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + -- Pointer to the TSD + + Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); + Parent_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Parent_Tag) - DT_Typeinfo_Ptr_Size); + Parent_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); + + begin + -- Here we compute the size of the _parent field of the object + + return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); + end Parent_Size; + + ---------------- + -- Parent_Tag -- + ---------------- + + function Parent_Tag (T : Tag) return Tag is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + + -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. + -- The first entry in the Ancestors_Tags array will be null for such + -- a type, but it's better to be explicit about returning No_Tag in + -- this case. + + if TSD.Idepth = 0 then + return No_Tag; + else + return TSD.Tags_Table (1); + end if; + end Parent_Tag; + + ------------------------------- + -- Register_Interface_Offset -- + ------------------------------- + + procedure Register_Interface_Offset + (Prim_T : Tag; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T); + Iface_Table : constant Interface_Data_Ptr := + To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; + + begin + -- Save Offset_Value in the table of interfaces of the primary DT. + -- This data will be used by the subprogram "Displace" to give support + -- to backward abstract interface type conversions. + + -- Register the offset in the table of interfaces + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then + if Is_Static or else Offset_Value = 0 then + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := + Offset_Value; + else + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := + Offset_Func; + end if; + + return; + end if; + end loop; + end if; + + -- If we arrive here there is some error in the run-time data structure + + raise Program_Error; + end Register_Interface_Offset; + + ------------------ + -- Register_Tag -- + ------------------ + + procedure Register_Tag (T : Tag) is + begin + External_Tag_HTable.Set (T); + end Register_Tag; + + ------------------- + -- Secondary_Tag -- + ------------------- + + function Secondary_Tag (T, Iface : Tag) return Tag is + Iface_Table : Interface_Data_Ptr; + Obj_DT : Dispatch_Table_Ptr; + + begin + if not Is_Primary_DT (T) then + raise Program_Error; + end if; + + Obj_DT := DT (T); + Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then + return Iface_Table.Ifaces_Table (Id).Secondary_DT; + end if; + end loop; + end if; + + -- If the object does not implement the interface we must raise CE + + raise Constraint_Error with "invalid interface conversion"; + end Secondary_Tag; + + --------------------- + -- Set_Entry_Index -- + --------------------- + + procedure Set_Entry_Index + (T : Tag; + Position : Positive; + Value : Positive) + is + begin + SSD (T).SSD_Table (Position).Index := Value; + end Set_Entry_Index; + + ------------------------------- + -- Set_Dynamic_Offset_To_Top -- + ------------------------------- + + procedure Set_Dynamic_Offset_To_Top + (This : System.Address; + Prim_T : Tag; + Interface_T : Tag; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Sec_Base : System.Address; + Sec_DT : Dispatch_Table_Ptr; + + begin + -- Save the offset to top field in the secondary dispatch table + + if Offset_Value /= 0 then + Sec_Base := This - Offset_Value; + Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); + Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; + end if; + + Register_Interface_Offset + (Prim_T, Interface_T, False, Offset_Value, Offset_Func); + end Set_Dynamic_Offset_To_Top; + + ---------------------- + -- Set_Prim_Op_Kind -- + ---------------------- + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind) + is + begin + SSD (T).SSD_Table (Position).Kind := Value; + end Set_Prim_Op_Kind; + + -------------------- + -- Unregister_Tag -- + -------------------- + + procedure Unregister_Tag (T : Tag) is + begin + External_Tag_HTable.Remove (Get_External_Tag (T)); + end Unregister_Tag; + + -- ------------------------ + -- -- Wide_Expanded_Name -- + -- ------------------------ + + -- WC_Encoding : Character; + -- pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- -- Encoding method for source, as exported by binder + + -- function Wide_Expanded_Name (T : Tag) return Wide_String is + -- S : constant String := Expanded_Name (T); + -- W : Wide_String (1 .. S'Length); + -- L : Natural; + -- begin + -- String_To_Wide_String + -- (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + -- return W (1 .. L); + -- end Wide_Expanded_Name; + + -- ----------------------------- + -- -- Wide_Wide_Expanded_Name -- + -- ----------------------------- + + -- function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is + -- S : constant String := Expanded_Name (T); + -- W : Wide_Wide_String (1 .. S'Length); + -- L : Natural; + -- begin + -- String_To_Wide_Wide_String + -- (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + -- return W (1 .. L); + -- end Wide_Wide_Expanded_Name; + +end Ada.Tags; diff --git a/common/gnat-ce-2020/a-tags.ads b/common/gnat-ce-2020/a-tags.ads new file mode 100644 index 0000000..69b588f --- /dev/null +++ b/common/gnat-ce-2020/a-tags.ads @@ -0,0 +1,630 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A G S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- For performance analysis, take into account that the operations in this +-- package provide the guarantee that all dispatching calls on primitive +-- operations of tagged types and interfaces take constant time (in terms +-- of source lines executed), that is to say, the cost of these calls is +-- independent of the number of primitives of the type or interface, and +-- independent of the number of ancestors or interface progenitors that a +-- tagged type may have. + +-- The following subprograms of the public part of this package take constant +-- time (in terms of source lines executed): + +-- Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag, +-- Is_Abstract, Is_Descendant_At_Same_Level, Parent_Tag, +-- Descendant_Tag (when used with a library-level tagged type), +-- Internal_Tag (when used with a library-level tagged type). + +-- The following subprograms of the public part of this package execute in +-- time that is not constant (in terms of sources line executed): + +-- Internal_Tag (when used with a locally defined tagged type), because in +-- such cases this routine processes the external tag, extracts from it an +-- address available there, and converts it into the tag value returned by +-- this function. The number of instructions executed is not constant since +-- it depends on the length of the external tag string. + +-- Descendant_Tag (when used with a locally defined tagged type), because +-- it relies on the subprogram Internal_Tag() to provide its functionality. + +-- Interface_Ancestor_Tags, because this function returns a table whose +-- length depends on the number of interfaces covered by a tagged type. + +-- This file has been modified from the gcc-mirror version at +-- commit [ead7594] for Cortex GNAT RTS (only by commenting-out the +-- Wide_*Expanded_Name functions). + +with System.Storage_Elements; + +package Ada.Tags is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362 + + type Tag is private; + pragma Preelaborable_Initialization (Tag); + + No_Tag : constant Tag; + + function Expanded_Name (T : Tag) return String; + + -- function Wide_Expanded_Name (T : Tag) return Wide_String; + -- pragma Ada_05 (Wide_Expanded_Name); + + -- function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String; + -- pragma Ada_05 (Wide_Wide_Expanded_Name); + + function External_Tag (T : Tag) return String; + + function Internal_Tag (External : String) return Tag; + + function Descendant_Tag + (External : String; + Ancestor : Tag) return Tag; + pragma Ada_05 (Descendant_Tag); + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean; + pragma Ada_05 (Is_Descendant_At_Same_Level); + + function Parent_Tag (T : Tag) return Tag; + pragma Ada_05 (Parent_Tag); + + type Tag_Array is array (Positive range <>) of Tag; + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array; + pragma Ada_05 (Interface_Ancestor_Tags); + + function Is_Abstract (T : Tag) return Boolean; + pragma Ada_2012 (Is_Abstract); + + Tag_Error : exception; + +private + -- Structure of the GNAT Primary Dispatch Table + + -- +--------------------+ + -- | Signature | + -- +--------------------+ + -- | Tagged_Kind | + -- +--------------------+ Predef Prims + -- | Predef_Prims -----------------------------> +------------+ + -- +--------------------+ | table of | + -- | Offset_To_Top | | predefined | + -- +--------------------+ | primitives | + -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+ + -- Tag ---> +--------------------+ +-------------------+ + -- | table of | | inheritance depth | + -- : primitive ops : +-------------------+ + -- | pointers | | access level | + -- +--------------------+ +-------------------+ + -- | alignment | + -- +-------------------+ + -- | expanded name | + -- +-------------------+ + -- | external tag | + -- +-------------------+ + -- | hash table link | + -- +-------------------+ + -- | transportable | + -- +-------------------+ + -- | is_abstract | + -- +-------------------+ + -- | needs finalization| + -- +-------------------+ + -- | Ifaces_Table ---> Interface Data + -- +-------------------+ +------------+ + -- Select Specific Data <---- SSD | | Nb_Ifaces | + -- +------------------+ +-------------------+ +------------+ + -- |table of primitive| | table of | | table | + -- : operation : : ancestor : : of : + -- | kinds | | tags | | interfaces | + -- +------------------+ +-------------------+ +------------+ + -- |table of | + -- : entry : + -- | indexes | + -- +------------------+ + + -- Structure of the GNAT Secondary Dispatch Table + + -- +--------------------+ + -- | Signature | + -- +--------------------+ + -- | Tagged_Kind | + -- +--------------------+ Predef Prims + -- | Predef_Prims -----------------------------> +------------+ + -- +--------------------+ | table of | + -- | Offset_To_Top | | predefined | + -- +--------------------+ | primitives | + -- | OSD_Ptr |---> Object Specific Data | thunks | + -- Tag ---> +--------------------+ +---------------+ +------------+ + -- | table of | | num prim ops | + -- : primitive op : +---------------+ + -- | thunk pointers | | table of | + -- +--------------------+ + primitive | + -- | op offsets | + -- +---------------+ + + -- The runtime information kept for each tagged type is separated into two + -- objects: the Dispatch Table and the Type Specific Data record. + + package SSE renames System.Storage_Elements; + + subtype Cstring is String (Positive); + type Cstring_Ptr is access all Cstring; + pragma No_Strict_Aliasing (Cstring_Ptr); + + -- Declarations for the table of interfaces + + type Offset_To_Top_Function_Ptr is + access function (This : System.Address) return SSE.Storage_Offset; + -- Type definition used to call the function that is generated by the + -- expander in case of tagged types with discriminants that have secondary + -- dispatch tables. This function provides the Offset_To_Top value in this + -- specific case. + + type Interface_Data_Element is record + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : SSE.Storage_Offset; + Offset_To_Top_Func : Offset_To_Top_Function_Ptr; + Secondary_DT : Tag; + end record; + -- If some ancestor of the tagged type has discriminants the field + -- Static_Offset_To_Top is False and the field Offset_To_Top_Func + -- is used to store the access to the function generated by the + -- expander which provides this value; otherwise Static_Offset_To_Top + -- is True and such value is stored in the Offset_To_Top_Value field. + -- Secondary_DT references a secondary dispatch table whose contents + -- are pointers to the primitives of the tagged type that cover the + -- interface primitives. Secondary_DT gives support to dispatching + -- calls through interface types associated with Generic Dispatching + -- Constructors. + + type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + + type Interface_Data_Ptr is access all Interface_Data; + -- Table of abstract interfaces used to give support to backward interface + -- conversions and also to IW_Membership. + + -- Primitive operation kinds. These values differentiate the kinds of + -- callable entities stored in the dispatch table. Certain kinds may + -- not be used, but are added for completeness. + + type Prim_Op_Kind is + (POK_Function, + POK_Procedure, + POK_Protected_Entry, + POK_Protected_Function, + POK_Protected_Procedure, + POK_Task_Entry, + POK_Task_Function, + POK_Task_Procedure); + + -- Select specific data types + + type Select_Specific_Data_Element is record + Index : Positive; + Kind : Prim_Op_Kind; + end record; + + type Select_Specific_Data_Array is + array (Positive range <>) of Select_Specific_Data_Element; + + type Select_Specific_Data (Nb_Prim : Positive) is record + SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); + -- NOTE: Nb_Prim is the number of non-predefined primitive operations + end record; + + type Select_Specific_Data_Ptr is access all Select_Specific_Data; + -- A table used to store the primitive operation kind and entry index of + -- primitive subprograms of a type that implements a limited interface. + -- The Select Specific Data table resides in the Type Specific Data of a + -- type. This construct is used in the handling of dispatching triggers + -- in select statements. + + type Prim_Ptr is access procedure; + type Address_Array is array (Positive range <>) of Prim_Ptr; + + subtype Dispatch_Table is Address_Array (1 .. 1); + -- Used by GDB to identify the _tags and traverse the run-time structure + -- associated with tagged types. For compatibility with older versions of + -- gdb, its name must not be changed. + + type Tag is access all Dispatch_Table; + pragma No_Strict_Aliasing (Tag); + + type Interface_Tag is access all Dispatch_Table; + + No_Tag : constant Tag := null; + + -- The expander ensures that Tag objects reference the Prims_Ptr component + -- of the wrapper. + + type Tag_Ptr is access all Tag; + pragma No_Strict_Aliasing (Tag_Ptr); + + type Offset_To_Top_Ptr is access all SSE.Storage_Offset; + pragma No_Strict_Aliasing (Offset_To_Top_Ptr); + + type Tag_Table is array (Natural range <>) of Tag; + + type Size_Ptr is + access function (A : System.Address) return Long_Long_Integer; + + type Type_Specific_Data (Idepth : Natural) is record + -- The discriminant Idepth is the Inheritance Depth Level: Used to + -- implement the membership test associated with single inheritance of + -- tagged types in constant-time. It also indicates the size of the + -- Tags_Table component. + + Access_Level : Natural; + -- Accessibility level required to give support to Ada 2005 nested type + -- extensions. This feature allows safe nested type extensions by + -- shifting the accessibility checks to certain operations, rather than + -- being enforced at the type declaration. In particular, by performing + -- run-time accessibility checks on class-wide allocators, class-wide + -- function return, and class-wide stream I/O, the danger of objects + -- outliving their type declaration can be eliminated (Ada 2005: AI-344) + + Alignment : Natural; + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag_Ptr; + -- Components used to support to the Ada.Tags subprograms in RM 3.9 + + -- Note: Expanded_Name is referenced by GDB to determine the actual name + -- of the tagged type. Its requirements are: 1) it must have this exact + -- name, and 2) its contents must point to a C-style Nul terminated + -- string containing its expanded name. GDB has no requirement on a + -- given position inside the record. + + Transportable : Boolean; + -- Used to check RM E.4(18), set for types that satisfy the requirements + -- for being used in remote calls as actuals for classwide formals or as + -- return values for classwide functions. + + Is_Abstract : Boolean; + -- True if the type is abstract (Ada 2012: AI05-0173) + + Needs_Finalization : Boolean; + -- Used to dynamically check whether an object is controlled or not + + Size_Func : Size_Ptr; + -- Pointer to the subprogram computing the _size of the object. Used by + -- the run-time whenever a call to the 'size primitive is required. We + -- cannot assume that the contents of dispatch tables are addresses + -- because in some architectures the ABI allows descriptors. + + Interfaces_Table : Interface_Data_Ptr; + -- Pointer to the table of interface tags. It is used to implement the + -- membership test associated with interfaces and also for backward + -- abstract interface type conversions (Ada 2005:AI-251) + + SSD : Select_Specific_Data_Ptr; + -- Pointer to a table of records used in dispatching selects. This field + -- has a meaningful value for all tagged types that implement a limited, + -- protected, synchronized or task interfaces and have non-predefined + -- primitive operations. + + Tags_Table : Tag_Table (0 .. Idepth); + -- Table of ancestor tags. Its size actually depends on the inheritance + -- depth level of the tagged type. + end record; + + type Type_Specific_Data_Ptr is access all Type_Specific_Data; + pragma No_Strict_Aliasing (Type_Specific_Data_Ptr); + + -- Declarations for the dispatch table record + + type Signature_Kind is + (Unknown, + Primary_DT, + Secondary_DT); + + -- Tagged type kinds with respect to concurrency and limitedness + + type Tagged_Kind is + (TK_Abstract_Limited_Tagged, + TK_Abstract_Tagged, + TK_Limited_Tagged, + TK_Protected, + TK_Tagged, + TK_Task); + + type Dispatch_Table_Wrapper (Num_Prims : Natural) is record + Signature : Signature_Kind; + Tag_Kind : Tagged_Kind; + Predef_Prims : System.Address; + -- Pointer to the dispatch table of predefined Ada primitives + + -- According to the C++ ABI the components Offset_To_Top and TSD are + -- stored just "before" the dispatch table, and they are referenced with + -- negative offsets referring to the base of the dispatch table. The + -- _Tag (or the VTable_Ptr in C++ terminology) must point to the base + -- of the virtual table, just after these components, to point to the + -- Prims_Ptr table. + + Offset_To_Top : SSE.Storage_Offset; + -- Offset between the _Tag field and the field that contains the + -- reference to this dispatch table. For primary dispatch tables it is + -- zero. For secondary dispatch tables: if the parent record type (if + -- any) has a compile-time-known size, then Offset_To_Top contains the + -- expected value, otherwise it contains SSE.Storage_Offset'Last and the + -- actual offset is to be found in the tagged record, right after the + -- field that contains the reference to this dispatch table. See the + -- implementation of Ada.Tags.Offset_To_Top for the corresponding logic. + + TSD : System.Address; + + Prims_Ptr : aliased Address_Array (1 .. Num_Prims); + -- The size of the Prims_Ptr array actually depends on the tagged type + -- to which it applies. For each tagged type, the expander computes the + -- actual array size, allocating the Dispatch_Table record accordingly. + end record; + + type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; + pragma No_Strict_Aliasing (Dispatch_Table_Ptr); + + -- The following type declaration is used by the compiler when the program + -- is compiled with restriction No_Dispatching_Calls. It is also used with + -- interface types to generate the tag and run-time information associated + -- with them. + + type No_Dispatch_Table_Wrapper is record + NDT_TSD : System.Address; + NDT_Prims_Ptr : Natural; + end record; + + DT_Predef_Prims_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Predef_Prims field of the Dispatch_Table + + DT_Offset_To_Top_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Offset_To_Top field of the Dispatch Table + + DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Typeinfo_Ptr field of the Dispatch Table + + use type System.Storage_Elements.Storage_Offset; + + DT_Offset_To_Top_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size; + + DT_Predef_Prims_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size + + DT_Predef_Prims_Size; + -- Offset from Prims_Ptr to Predef_Prims component + + -- Object Specific Data record of secondary dispatch tables + + type Object_Specific_Data_Array is array (Positive range <>) of Positive; + + type Object_Specific_Data (OSD_Num_Prims : Positive) is record + OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims); + -- Table used in secondary DT to reference their counterpart in the + -- select specific data (in the TSD of the primary DT). This construct + -- is used in the handling of dispatching triggers in select statements. + -- Nb_Prim is the number of non-predefined primitive operations. + end record; + + type Object_Specific_Data_Ptr is access all Object_Specific_Data; + pragma No_Strict_Aliasing (Object_Specific_Data_Ptr); + + -- The following subprogram specifications are placed here instead of the + -- package body to see them from the frontend through rtsfind. + + function Base_Address (This : System.Address) return System.Address; + -- Ada 2005 (AI-251): Displace "This" to point to the base address of the + -- object (that is, the address of the primary tag of the object). + + procedure Check_TSD (TSD : Type_Specific_Data_Ptr); + -- Ada 2012 (AI-113): Raise Program_Error if the external tag of this TSD + -- is the same as the external tag for some other tagged type declaration. + + function Displace (This : System.Address; T : Tag) return System.Address; + -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch + -- table of T. + + function Secondary_Tag (T, Iface : Tag) return Tag; + -- Ada 2005 (AI-251): Given a primary tag T associated with a tagged type + -- Typ, search for the secondary tag of the interface type Iface covered + -- by Typ. + + function DT (T : Tag) return Dispatch_Table_Ptr; + -- Return the pointer to the TSD record associated with T + + function Get_Entry_Index (T : Tag; Position : Positive) return Positive; + -- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry) + -- given a dispatch table T and a position of a primitive operation in T. + + function Get_Offset_Index + (T : Tag; + Position : Positive) return Positive; + -- Ada 2005 (AI-251): Given a pointer to a secondary dispatch table (T) + -- and a position of an operation in the DT, retrieve the corresponding + -- operation's position in the primary dispatch table from the Offset + -- Specific Data table of T. + + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind; + -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch + -- table T and a position of a primitive operation in T. + + function Get_Tagged_Kind (T : Tag) return Tagged_Kind; + -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary + -- dispatch table, return the tagged kind of a type in the context of + -- concurrency and limitedness. + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; + -- Given the tag of an object and the tag associated to a type, return + -- true if Obj is in Typ'Class. + + function IW_Membership (This : System.Address; T : Tag) return Boolean; + -- Ada 2005 (AI-251): General routine that checks if a given object + -- implements a tagged type. Its common usage is to check if Obj is in + -- Iface'Class, but it is also used to check if a class-wide interface + -- implements a given type (Iface_CW_Typ in T'Class). For example: + -- + -- type I is interface; + -- type T is tagged ... + -- + -- function Test (O : I'Class) is + -- begin + -- return O in T'Class. + -- end Test; + + function Offset_To_Top + (This : System.Address) return SSE.Storage_Offset; + -- Ada 2005 (AI-251): Returns the current value of the Offset_To_Top + -- component available in the prologue of the dispatch table. If the parent + -- of the tagged type has discriminants this value is stored in a record + -- component just immediately after the tag component. + + function Needs_Finalization (T : Tag) return Boolean; + -- A helper routine used in conjunction with finalization collections which + -- service class-wide types. The function dynamically determines whether an + -- object is controlled or has controlled components. + + function Parent_Size + (Obj : System.Address; + T : Tag) return SSE.Storage_Count; + -- Computes the size the ancestor part of a tagged extension object whose + -- address is 'obj' by calling indirectly the ancestor _size function. The + -- ancestor is the parent of the type represented by tag T. This function + -- assumes that _size is always in slot one of the dispatch table. + + procedure Register_Interface_Offset + (Prim_T : Tag; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Register in the table of interfaces of the tagged type associated with + -- Prim_T the offset of the record component associated with the progenitor + -- Interface_T (that is, the distance from "This" to the object component + -- containing the tag of the secondary dispatch table). In case of constant + -- offset, Is_Static is true and Offset_Value has such value. In case of + -- variable offset, Is_Static is false and Offset_Func is an access to + -- function that must be called to evaluate the offset. + + procedure Register_Tag (T : Tag); + -- Insert the Tag and its associated external_tag in a table for the sake + -- of Internal_Tag. + + procedure Set_Dynamic_Offset_To_Top + (This : System.Address; + Prim_T : Tag; + Interface_T : Tag; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Ada 2005 (AI-251): The compiler generates calls to this routine only + -- when initializing the Offset_To_Top field of dispatch tables of tagged + -- types that cover interface types whose parent type has variable size + -- components. + -- + -- "This" is the object whose dispatch table is being initialized. Prim_T + -- is the primary tag of such object. Interface_T is the interface tag for + -- which the secondary dispatch table is being initialized. Offset_Value + -- is the distance from "This" to the object component containing the tag + -- of the secondary dispatch table (a zero value means that this interface + -- shares the primary dispatch table). Offset_Func references a function + -- that must be called to evaluate the offset at run time. This routine + -- also takes care of registering these values in the table of interfaces + -- of the type. + + procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); + -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's + -- TSD table indexed by Position. + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind); + -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD + -- table indexed by Position. + + procedure Unregister_Tag (T : Tag); + -- Remove a particular tag from the external tag hash table + + Max_Predef_Prims : constant Positive := 16; + -- Number of reserved slots for the following predefined ada primitives: + -- + -- 1. Size + -- 2. Read + -- 3. Write + -- 4. Input + -- 5. Output + -- 6. "=" + -- 7. assignment + -- 8. deep adjust + -- 9. deep finalize + -- 10. Put_Image + -- 11. async select + -- 12. conditional select + -- 13. prim_op kind + -- 14. task_id + -- 15. dispatching requeue + -- 16. timed select + -- + -- The compiler checks that the value here is correct + + subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims); + type Predef_Prims_Table_Ptr is access Predef_Prims_Table; + pragma No_Strict_Aliasing (Predef_Prims_Table_Ptr); + + type Addr_Ptr is access System.Address; + pragma No_Strict_Aliasing (Addr_Ptr); + -- This type is used by the frontend to generate the code that handles + -- dispatch table slots of types declared at the local level. + +end Ada.Tags; diff --git a/common/gnat-ce-2020/environment_task.adb b/common/gnat-ce-2020/environment_task.adb new file mode 100644 index 0000000..3e3a1ad --- /dev/null +++ b/common/gnat-ce-2020/environment_task.adb @@ -0,0 +1,83 @@ +-- Copyright (C) 2016-2018 Free Software Foundation, Inc. +-- +-- This file is part of the Cortex GNAT RTS project. This file is +-- free software; you can redistribute it and/or modify it under +-- terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 3, or (at your option) any +-- later version. This file is distributed in the hope that it will +-- be useful, but WITHOUT 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 . + +with System.Parameters; +with System.Tasking.Restricted.Stages; +with System.Task_Info; + +package body Environment_Task is + + procedure Environment_Task (Arg : System.Address); + procedure Environment_Task (Arg : System.Address) is + pragma Unreferenced (Arg); + -- Generated by gnatbind. + procedure Main + with + Import, + Convention => C, + External_Name => "main"; + begin + Main; -- should not return; + end Environment_Task; + + -- For creating the environment task; declared here to avoid + -- accessibility level issues. + Environment_Task_Elaborated : aliased Boolean; + Activation_Chain_Dummy : System.Tasking.Activation_Chain + with Suppress_Initialization; + Environment_TCB : aliased System.Tasking.Ada_Task_Control_Block + (System.Tasking.Null_Entry); + + -- If the link includes a symbol _environment_task_storage_size, + -- use this as the storage size: otherwise, use 1536. + Environment_Task_Storage_Size : constant System.Parameters.Size_Type + with + Import, + Convention => Ada, + External_Name => "_environment_task_storage_size"; + pragma Weak_External (Environment_Task_Storage_Size); + + procedure Create is + -- Will be overwritten by binder-generated code if the main + -- program has pragma Priority. + Main_Priority : Integer; + pragma Import (C, Main_Priority, "__gl_main_priority"); + use type System.Address; + begin + System.Tasking.Restricted.Stages.Create_Restricted_Task + (Priority => Main_Priority, + Stack_Address => System.Null_Address, + Size => + (if Environment_Task_Storage_Size'Address = System.Null_Address + then 1536 + else Environment_Task_Storage_Size), + Sec_Stack_Address => null, + Secondary_Stack_Size => System.Parameters.Unspecified_Size, + Task_Info => System.Task_Info.Unspecified_Task_Info, + CPU => System.Tasking.Unspecified_CPU, + State => Environment_Task'Access, + Discriminants => System.Null_Address, + Elaborated => Environment_Task_Elaborated'Access, + Chain => Activation_Chain_Dummy, + Task_Image => "", + Created_Task => Environment_TCB'Access); + end Create; + +end Environment_Task; diff --git a/common/gnat-ce-2020/s-parame.adb b/common/gnat-ce-2020/s-parame.adb new file mode 100644 index 0000000..3cc65ae --- /dev/null +++ b/common/gnat-ce-2020/s-parame.adb @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2018 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 version for Cortex GNAT RTS. + +package body System.Parameters is + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + (if Size = Unspecified_Size then + Default_Stack_Size + elsif Size < Minimum_Stack_Size then + Minimum_Stack_Size + else + Size); + + -- If the link includes a symbol _default_storage_size, + -- use this as the storage size: otherwise, use 1024. + Default_Storage_Size : constant Size_Type + with + Import, + Convention => Ada, + External_Name => "_default_storage_size"; + pragma Weak_External (Default_Storage_Size); + + -- If the link includes a symbol _minimum_storage_size, + -- use this as the minimum storage size: otherwise, use 768. + Minimum_Storage_Size : constant Size_Type + with + Import, + Convention => Ada, + External_Name => "_minimum_storage_size"; + pragma Weak_External (Minimum_Storage_Size); + + function Default_Stack_Size return Size_Type is + (if Default_Storage_Size'Address = System.Null_Address + then 1024 + else Default_Storage_Size); + + function Minimum_Stack_Size return Size_Type is + (if Minimum_Storage_Size'Address = System.Null_Address + then 768 + else Minimum_Storage_Size); + + -- Secondary stack + + Default_Secondary_Stack_Size : Size_Type + with + Volatile, + Export, + Convention => Ada, + External_Name => "__gnat_default_ss_size"; + -- Written by the GCC8 binder (unless otherwise specified, to + -- Runtime_Default_Sec_Stack_Size) + + function Secondary_Stack_Size (Stack_Size : Size_Type) return Size_Type + is (if Default_Secondary_Stack_Size = 0 + then (Stack_Size * 10) / 100 -- default is 10% + else Default_Secondary_Stack_Size); + + -- Items referenced by the GCC8 binder, but not used; may need to + -- go to System.Secondary_Stack eventually. + + Binder_Sec_Stacks_Count : Natural + with + Export, + Convention => Ada, + External_Name => "__gnat_binder_ss_count"; + + Default_Sized_SS_Pool : System.Address + with + Export, + Convention => Ada, + External_Name => "__gnat_default_ss_pool"; + +end System.Parameters; diff --git a/common/gnat-ce-2020/s-parame.ads b/common/gnat-ce-2020/s-parame.ads new file mode 100644 index 0000000..8e0cecb --- /dev/null +++ b/common/gnat-ce-2020/s-parame.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2013, 2016-2018, 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 package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +-- Modified from GCC 4.9.1 for Cortex GNAT RTS. + +package System.Parameters is + pragma Preelaborate; + pragma No_Elaboration_Code_All; + + type Size_Type is new Integer; + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Type used to provide task storage size to runtime + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size specified, return the Storage_Size value + -- required by the RM for the Storage_Size attribute. The required + -- adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + function Secondary_Stack_Size (Stack_Size : Size_Type) return Size_Type; + -- The secondary stack is allocated as part of the task's stack, + -- whose size is passed in Stack_Size. + + Runtime_Default_Sec_Stack_Size : constant Size_Type := 0; + -- The run-time chosen default size for secondary stacks that may + -- be overriden by the user with the use of binder -D switch. + -- The GCC8 binder generates references. + -- + -- 0 means to use 10% of the task's stack. + +end System.Parameters; diff --git a/common/gnat-ce-2020/s-secsta.adb b/common/gnat-ce-2020/s-secsta.adb new file mode 100644 index 0000000..cb984cc --- /dev/null +++ b/common/gnat-ce-2020/s-secsta.adb @@ -0,0 +1,66 @@ +-- Copyright (C) 2016-2017 Free Software Foundation, Inc. +-- +-- This file is part of the Cortex GNAT RTS project. This file is +-- free software; you can redistribute it and/or modify it under +-- terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 3, or (at your option) any +-- later version. This file is distributed in the hope that it will +-- be useful, but WITHOUT 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 . + +with System.Tasking; + +package body System.Secondary_Stack is + + function Get_Current_Stack return SS_Stack_Ptr is + (System.Tasking.Self.Secondary_Stack); + + -- procedure SS_Init + -- (Stk : in out Address; + -- Size : Natural) is + -- begin + -- null; + -- end SS_Init; + + procedure SS_Allocate + (Addr : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count) is + use type System.Parameters.Size_Type; + + Current_Stack : constant SS_Stack_Ptr := Get_Current_Stack; + + Aligned_Size : constant System.Parameters.Size_Type := + ((System.Parameters.Size_Type (Storage_Size) + + Standard'Maximum_Alignment - 1) + / Standard'Maximum_Alignment) + * Standard'Maximum_Alignment; + begin + if Current_Stack.Top + Aligned_Size > Current_Stack.Size + 1 then + raise Storage_Error; + end if; + + Addr := Current_Stack.Mem (Current_Stack.Top)'Address; + Current_Stack.Top := Current_Stack.Top + Aligned_Size; + end SS_Allocate; + + function SS_Mark return Mark_Id is + begin + return Mark_Id (Get_Current_Stack.Top); + end SS_Mark; + + procedure SS_Release (M : Mark_Id) is + begin + Get_Current_Stack.Top := System.Parameters.Size_Type (M); + end SS_Release; + +end System.Secondary_Stack; diff --git a/common/gnat-ce-2020/s-secsta.ads b/common/gnat-ce-2020/s-secsta.ads new file mode 100644 index 0000000..338e910 --- /dev/null +++ b/common/gnat-ce-2020/s-secsta.ads @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S E C O N D A R Y _ S T A C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2013, 2016-2018, 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Parameters; +with System.Storage_Elements; + +package System.Secondary_Stack is + pragma Preelaborate; + pragma No_Elaboration_Code_All; + + -- The secondary stack for a task is an area in the task's stack + -- reserved for managing objects of indefinite type + -- (e.g. Strings). + -- + -- The secondary stack is created as an object in the + -- System.Tasking.Restricted.Stages Wrapper procedure. + + type SS_Stack (Size : System.Parameters.Size_Type) is private; + type SS_Stack_Ptr is access all SS_Stack with Storage_Size => 0; + + -- procedure SS_Init + -- (Stk : in out System.Address; + -- Size : Natural); + -- Initialize a secondary stack at the given address to the given + -- Size. + + procedure SS_Allocate + (Addr : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count); + -- Allocate enough space for a 'Storage_Size' bytes object with + -- maximum alignment from the current task's stack. The address of + -- the allocated space is returned in Addr. + + -- procedure SS_Free (Stk : in out Address); + -- Release the memory allocated for the Secondary Stack. That is + -- to say, all the allocated chunks. Upon return, Stk will be set + -- to System.Null_Address. + + type Mark_Id is private; + -- Type used to mark the stack for mark/release processing + + function SS_Mark return Mark_Id; + -- Return the Mark corresponding to the current state of the stack + + procedure SS_Release (M : Mark_Id); + -- Restore the state of the stack corresponding to the mark M. + + -- function SS_Get_Max return Long_Long_Integer; + -- Return maximum used space in storage units for the current secondary + -- stack. For a dynamically allocated secondary stack, the returned + -- result is always -1. For a statically allocated secondary stack, + -- the returned value shows the largest amount of space allocated so + -- far during execution of the program to the current secondary stack, + -- i.e. the secondary stack for the current task. + + -- generic + -- with procedure Put_Line (S : String); + -- procedure SS_Info; + -- Debugging procedure used to print out secondary Stack allocation + -- information. This procedure is generic in order to avoid a direct + -- dependance on a particular IO package. + +private + SS_Pool : Integer; + -- Unused entity that is just present to ease the sharing of the + -- pool mechanism for specific allocation/deallocation in the + -- compiler (???) + + type Memory_Array + is array (System.Parameters.Size_Type range <>) + of System.Storage_Elements.Storage_Element + with + Alignment => Standard'Maximum_Alignment; + + -- This stack grows up. + type SS_Stack (Size : System.Parameters.Size_Type) is record + Top : System.Parameters.Size_Type := 1; + Mem : Memory_Array (1 .. Size); + end record; + + type Mark_Id is new System.Parameters.Size_Type; + -- A mark value contains a stack pointer value corresponding to + -- the point of the mark call. + +end System.Secondary_Stack; diff --git a/common/gnat-ce-2020/s-tarest.adb b/common/gnat-ce-2020/s-tarest.adb new file mode 100644 index 0000000..cf5dced --- /dev/null +++ b/common/gnat-ce-2020/s-tarest.adb @@ -0,0 +1,270 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2018, 2020 Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls. + +-- This is the version for the Cortex GNAT RTS project. + +with Ada.Unchecked_Conversion; +with System.Address_To_Access_Conversions; +with System.FreeRTOS.TCB; +with System.Memory; + +package body System.Tasking.Restricted.Stages is + + Sequential_Elaboration_Started : Boolean := False; + + procedure Wrapper (Arg1 : System.Address) with Convention => C; + -- This is the procedure passed to + -- FreeRTOS.Tasks.Create_Task. Arg1 is the address of its + -- Parameters. + + type Parameters is record + ATCB : Task_Id; + Task_Proc : Task_Procedure_Access; + Discriminants : System.Address; + SStack_Addr : System.Secondary_Stack.SS_Stack_Ptr; + SStack_Size : System.Parameters.Size_Type; + end record; + + package Parameters_Conversion + is new System.Address_To_Access_Conversions (Object => Parameters); + + procedure Wrapper (Arg1 : System.Address) is + function Convert_Task_Id + is new Ada.Unchecked_Conversion (Task_Id, System.Address); + + P : constant Parameters_Conversion.Object_Pointer := + Parameters_Conversion.To_Pointer (Arg1); + + use type System.Secondary_Stack.SS_Stack_Ptr; + begin + -- Save the ATCB in the FreeRTOS TCB + FreeRTOS.TCB.Set_Application_Parameter (Convert_Task_Id (P.ATCB)); + + -- Secondary stack handling: + -- + -- If P.SStack_Addr is Null_Address, then we are to allocate a + -- region from the bottom of the task's stack, size P.SStack_Size. + -- + -- If P.SStack_Addr isn't Null_Address, it's a region of the + -- task's package's BSS allocated and initialized by the + -- compiler. + + if P.SStack_Addr = null then + declare + -- At this point, the stack is the task's stack. Declare + -- a stack here. + Secondary_Stack : + aliased System.Secondary_Stack.SS_Stack (Size => P.SStack_Size); + begin + -- Register the secondary stack + P.ATCB.Secondary_Stack := Secondary_Stack'Unchecked_Access; + -- Unchecked_Access is OK because it can only be accessed from + -- the current task, within Task_Proc. + + -- Call the task procedure. The secondary stack is still + -- on the stack. + P.Task_Proc (P.Discriminants); + end; + else + -- Register the compiler-allocated secondary stack + P.ATCB.Secondary_Stack := P.SStack_Addr; + + -- Call the task procedure + P.Task_Proc (P.Discriminants); + end if; + + -- If we return here, the task procedure has exited (and not + -- because of an exception, which would already have reached + -- the last chance handler). + raise Program_Error with "task exited, not allowed in Ravenscar"; + end Wrapper; + + -- Null_Task_Name : constant String := (1 => ASCII.NUL); + + -- The > GCC 7 version + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id) is + + pragma Unreferenced (Stack_Address); + pragma Unreferenced (Task_Info); + pragma Unreferenced (CPU); + pragma Unreferenced (Chain); + + Actual_Stack_Size : constant System.Parameters.Size_Type := + System.Parameters.Adjust_Storage_Size (Size); + + Wrapper_Parameter_Address : constant System.Address := + Memory.Alloc (Parameters'Max_Size_In_Storage_Elements); + Wrapper_Parameter_Access : + constant Parameters_Conversion.Object_Pointer := + Parameters_Conversion.To_Pointer (Wrapper_Parameter_Address); + + use type System.Parameters.Size_Type; + use type FreeRTOS.Tasks.Task_Handle; + begin + if Wrapper_Parameter_Address = System.Null_Address then + raise Storage_Error with "couldn't allocate task wrapper"; + end if; + Wrapper_Parameter_Access.all := + (ATCB => Created_Task, + Task_Proc => State, + Discriminants => Discriminants, + SStack_Addr => Sec_Stack_Address, + SStack_Size => + (if Secondary_Stack_Size = System.Parameters.Unspecified_Size + then System.Parameters.Secondary_Stack_Size (Actual_Stack_Size) + else Secondary_Stack_Size)); -- don't think this will happen? + + Created_Task.Common.Base_Priority := (if Priority = Unspecified_Priority + then System.Default_Priority + else Priority); + Created_Task.Common.Thread := + FreeRTOS.Tasks.Create_Task + (Code => Wrapper'Access, + Name => Task_Image, + Stack_Depth => Natural (Actual_Stack_Size), + Parameters => Wrapper_Parameter_Address, + Priority => Created_Task.Common.Base_Priority); + -- The Entry_Call belongs to the task, so Self can be set up now. + Created_Task.Entry_Call.Self := Created_Task; + Elaborated.all := Created_Task.Common.Thread /= null; + + -- Place at front of the chain of created tasks, so they can be + -- accessed via GDB (this is a Ravenscar RTS, so tasks can only + -- be created during elaboration and can't be deleted). + Created_Task.Common.All_Tasks_Link := Task_Chain; + Task_Chain := Created_Task; + end Create_Restricted_Task; + + procedure Create_Restricted_Task_Sequential + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id) + is + -- Create_Restricted_Task requires a Chain parameter; however, + -- in this RTS it's ignored, because all tasks are activated as + -- they are elaborated (i.e., concurrently) BUT FreeRTOS + -- tasking is suspended. + Dummy_Activation_Chain : Activation_Chain; + begin + -- If we're called at all, it's because sequential activation + -- has been requested. If this is the first call, suspend + -- tasking (awaiting a call to Activate_All_Tasks_Sequential). + pragma Assert (Partition_Elaboration_Policy = 'S', + "Partition_Elaboration_Policy not sequential"); + if not Sequential_Elaboration_Started then + Sequential_Elaboration_Started := True; + FreeRTOS.Tasks.Suspend_All_Tasks; + end if; + + Create_Restricted_Task + (Priority => Priority, + Stack_Address => Stack_Address, + Size => Size, + Sec_Stack_Address => Sec_Stack_Address, + Secondary_Stack_Size => Secondary_Stack_Size, + Task_Info => Task_Info, + CPU => CPU, + State => State, + Discriminants => Discriminants, + Elaborated => Elaborated, + Chain => Dummy_Activation_Chain, -- <<< + Task_Image => Task_Image, + Created_Task => Created_Task); + end Create_Restricted_Task_Sequential; + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access) is + pragma Unreferenced (Chain_Access); + begin + -- This can get called even with sequential elaboration, + -- because if the RTS was compiled with concurrent activation + -- (almost certainly the case) any tasks in the RTS (e.g. for + -- Timing_Events) will call here at the end of package + -- elaboration. + null; + end Activate_Restricted_Tasks; + + procedure Activate_All_Tasks_Sequential is + begin + pragma Assert (Partition_Elaboration_Policy = 'S', + "Partition_Elaboration_Policy not sequential"); + -- If the elaboration policy is Sequential, Suspend_All_Tasks + -- would have been called (in Create_Restricted_Task_Sequential) + -- when the first user task was created during elaboration. + -- However, if there are no user tasks but there are tasks in + -- the RTS (e.g. Ada.Real_Time.Timing_Events) they will have + -- been compiled with concurrent elaboration via + -- Create_Restricted_Task, and Suspend_All_Tasks won't have + -- been called. Unusual, but!! + if Sequential_Elaboration_Started then + FreeRTOS.Tasks.Resume_All_Tasks; + end if; + end Activate_All_Tasks_Sequential; + + procedure Complete_Restricted_Activation is + begin + null; + end Complete_Restricted_Activation; + + procedure Complete_Restricted_Task is + begin + null; + end Complete_Restricted_Task; + +end System.Tasking.Restricted.Stages; diff --git a/common/gnat-ce-2020/s-tarest.ads b/common/gnat-ce-2020/s-tarest.ads new file mode 100644 index 0000000..7e59f30 --- /dev/null +++ b/common/gnat-ce-2020/s-tarest.ads @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2012, 2016-2018, 2020 -- +-- Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +-- The restricted GNARLI is also composed of System.Protected_Objects and +-- System.Protected_Objects.Single_Entry + +-- Modified for the Cortex GNAT RTS, by leaving out parts that aren't +-- called. +-- +-- If the user compiles with Partition_Elaboration_Policy set to +-- Sequential, the compiled code calls +-- Create_Restricted_Task_Sequential instead of +-- Create_Restricted_Task, and at the end calls +-- Activate_All_Tasks_Sequential. +-- +-- In Cortex GNAT RTS, the environment task is created and then the +-- FreeRTOS scheduler is started to run it. It executes the +-- binder-generated adainit() to perform elaboration and then +-- executes the Ada main program. +-- +-- All the program's tasks are created as they are encountered during +-- elaboration. If the elaboration policy is Concurrent, +-- Create_Restricted_Task is called, and the tasks become active +-- immediately. + +-- If however the elaboration policy is Sequential, the alternative +-- Create_Restricted_Task_Sequential is called and the FreeRTOS +-- scheduler is suspended on the first call, so that no tasks other +-- than the environment task actually start running. +-- Activate_All_Tasks_Sequential is called by adainit() at the end of +-- elaboration. + +with System.Parameters; +with System.Task_Info; + +package System.Tasking.Restricted.Stages is + pragma Preelaborate; + pragma No_Elaboration_Code_All; + + Partition_Elaboration_Policy : Character := 'C'; + pragma Export (C, Partition_Elaboration_Policy, + "__gnat_partition_elaboration_policy"); + -- Partition elaboration policy. Value can be either 'C' for + -- concurrent, which is the default, or 'S' for sequential. This + -- value is modified by the binder generated code in adainit(), + -- before calling elaboration code, if task activation is to be + -- Sequential. + + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id); + -- Compiler interface only. Do not call from within the RTS. This + -- must be called to create a new task, when the partition + -- elaboration policy is not specified (or is concurrent). + -- + -- Priority is the task's priority (assumed to be in the + -- System.Any_Priority'Range) + -- + -- Stack_Address is the start address of the stack associated to + -- the task, in case it has been preallocated by the compiler; it + -- is equal to Null_Address when the stack needs to be allocated + -- by the underlying operating system. + -- + -- Size is the stack size of the task to create + -- + -- Sec_Stack_Address is the pointer to the secondary stack created by the + -- compiler. If null, the secondary stack is either allocated by the binder + -- or the run-time. + -- + -- Secondary_Stack_Size is the secondary stack size of the task to create + -- + -- Task_Info is the task info associated with the created task, or + -- Unspecified_Task_Info if none. + -- + -- CPU is the task affinity. We pass it as an Integer to avoid an + -- explicit dependency from System.Multiprocessors when not + -- needed. Static range checks are performed when analyzing the + -- pragma, and dynamic ones are performed before setting the + -- affinity at run time. + -- + -- State is the compiler generated task's procedure body + -- + -- Discriminants is a pointer to a limited record whose + -- discriminants are those of the task to create. This parameter + -- should be passed as the single argument to State. + -- + -- Elaborated is a pointer to a Boolean that must be set to true + -- on exit if the task could be successfully elaborated. + -- + -- Chain is a linked list of task that needs to be created. On + -- exit, Created_Task.Activation_Link will be Chain.T_ID, and + -- Chain.T_ID will be Created_Task (the created task will be + -- linked at the front of Chain). Not used in Cortex GNAT RTS. + -- + -- Task_Image is a string created by the compiler that the run + -- time can store to ease the debugging and the + -- Ada.Task_Identification facility. + -- + -- Created_Task is the resulting task. + -- + -- This procedure can raise Storage_Error if the task creation + -- fails + + procedure Create_Restricted_Task_Sequential + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Sec_Stack_Address : System.Secondary_Stack.SS_Stack_Ptr; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task, when the sequential partition + -- elaboration policy is used. + -- + -- The parameters are the same as Create_Restricted_Task except there is + -- no Chain parameter (for the activation chain), as there is only one + -- global activation chain, which is declared in the body of this package. + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access); + -- Compiler interface only. Do not call from within the RTS. This + -- must be called by the creator of a chain of one or more new + -- tasks, to activate them. The chain is a linked list that up to + -- this point is only known to the task that created them, though + -- the individual tasks are already in the All_Tasks_List. + -- + -- The compiler builds the chain in LIFO order (as a + -- stack). Another version of this procedure had code to reverse + -- the chain, so as to activate the tasks in the order of + -- declaration. This might be nice, but it is not needed if + -- priority-based scheduling is supported, since all the activated + -- tasks synchronize on the activators lock before they start + -- activating and so they should start activating in priority + -- order. + -- + -- When the partition elaboration policy is sequential, this + -- procedure does nothing, tasks will be activated at end of + -- elaboration. + + procedure Activate_All_Tasks_Sequential; + pragma Export (C, Activate_All_Tasks_Sequential, + "__gnat_activate_all_tasks"); + -- Binder interface only. Do not call from within the RTS. This must be + -- called at the end of the elaboration to activate all tasks, in order + -- to implement the sequential elaboration policy. + + procedure Complete_Restricted_Activation; + -- Compiler interface only. Do not call from within the RTS. This + -- should be called from the task body at the end of the + -- elaboration code for its declarative part. Decrement the count + -- of tasks to be activated by the activator and wake it up so it + -- can check to see if all tasks have been activated. Except for + -- the environment task, which should never call this procedure, + -- T.Activator should only be null iff T has completed activation. + + procedure Complete_Restricted_Task; + -- Compiler interface only. Do not call from within the RTS. This + -- should be called from an implicit at-end handler associated + -- with the task body, when it completes. From this point, the + -- current task will become not callable. If the current task have + -- not completed activation, this should be done now in order to + -- wake up the activator (the environment task). + +end System.Tasking.Restricted.Stages; diff --git a/common/gnat-ce-2020/s-taskin.ads b/common/gnat-ce-2020/s-taskin.ads new file mode 100644 index 0000000..a7fc44b --- /dev/null +++ b/common/gnat-ce-2020/s-taskin.ads @@ -0,0 +1,1233 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2013, 2016-2018, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides necessary type definitions for compiler interface + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This file has been extensively modified from the GCC 4.9.1 version +-- for the Cortex GNAT RTS project. + +with System.FreeRTOS.Tasks; +with System.Secondary_Stack; + +package System.Tasking is + pragma Preelaborate; + pragma No_Elaboration_Code_All; + + ------------------- + -- Locking Rules -- + ------------------- + + -- The following rules must be followed at all times, to prevent + -- deadlock and generally ensure correct operation of locking. + + -- Never lock a lock unless abort is deferred + + -- Never undefer abort while holding a lock + + -- Overlapping critical sections must be properly nested, and locks must + -- be released in LIFO order. E.g., the following is not allowed: + + -- Lock (X); + -- ... + -- Lock (Y); + -- ... + -- Unlock (X); + -- ... + -- Unlock (Y); + + -- Locks with lower (smaller) level number cannot be locked + -- while holding a lock with a higher level number. (The level + + -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock) + -- 2. System.Tasking.Initialization.Global_Task_Lock (in body) + -- 3. System.Task_Primitives.Operations.Single_RTS_Lock + -- 4. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock) + + -- Clearly, there can be no circular chain of hold-and-wait + -- relationships involving locks in different ordering levels. + + -- We used to have Global_Task_Lock before Protection.L but this was + -- clearly wrong since there can be calls to "new" inside protected + -- operations. The new ordering prevents these failures. + + -- Sometimes we need to hold two ATCB locks at the same time. To allow us + -- to order the locking, each ATCB is given a unique serial number. If one + -- needs to hold locks on several ATCBs at once, the locks with lower + -- serial numbers must be locked first. + + -- We don't always need to check the serial numbers, since the serial + -- numbers are assigned sequentially, and so: + + -- . The parent of a task always has a lower serial number. + -- . The activator of a task always has a lower serial number. + -- . The environment task has a lower serial number than any other task. + -- . If the activator of a task is different from the task's parent, + -- the parent always has a lower serial number than the activator. + + --------------------------------- + -- Task_Id related definitions -- + --------------------------------- + + type Ada_Task_Control_Block; + + type Task_Id is access all Ada_Task_Control_Block; + pragma No_Strict_Aliasing (Task_Id); + + for Task_Id'Size use Standard'Address_Size; + + Null_Task : constant Task_Id := null; + + -- type Task_List is array (Positive range <>) of Task_Id; + + function Self return Task_Id; + + -- This is the compiler interface version of this function. Do not call + -- from the run-time system. + + -- function To_Task_Id is + -- new Ada.Unchecked_Conversion + -- (System.Task_Primitives.Task_Address, Task_Id); + -- function To_Address is + -- new Ada.Unchecked_Conversion + -- (Task_Id, System.Task_Primitives.Task_Address); + + ----------------------- + -- Enumeration types -- + ----------------------- + +-- type Task_States is +-- (Unactivated, +-- -- TCB initialized but not task has not been created. +-- -- It cannot be executing. + +-- -- Activating, +-- -- -- ??? Temporarily at end of list for GDB compatibility +-- -- -- Task has been created and is being made Runnable. + +-- -- Active states +-- -- For all states from here down, the task has been activated. +-- -- For all states from here down, except for Terminated, the task +-- -- may be executing. +-- -- Activator = null iff it has not yet completed activating. + +-- Runnable, +-- -- Task is not blocked for any reason known to Ada. +-- -- (It may be waiting for a mutex, though.) +-- -- It is conceptually "executing" in normal mode. + +-- Terminated, +-- -- The task is terminated, in the sense of ARM 9.3 (5). +-- -- Any dependents that were waiting on terminate +-- -- alternatives have been awakened and have terminated themselves. + +-- Activator_Sleep, +-- -- Task is waiting for created tasks to complete activation + +-- Acceptor_Sleep, +-- -- Task is waiting on an accept or select with terminate + +-- -- Acceptor_Delay_Sleep, +-- -- -- ??? Temporarily at end of list for GDB compatibility +-- -- -- Task is waiting on an selective wait statement + +-- Entry_Caller_Sleep, +-- -- Task is waiting on an entry call + +-- Async_Select_Sleep, +-- -- Task is waiting to start the abortable part of an +-- -- asynchronous select statement. + +-- Delay_Sleep, +-- -- Task is waiting on a select statement with only a delay +-- -- alternative open. + +-- Master_Completion_Sleep, +-- -- Master completion has two phases. +-- -- In Phase 1 the task is sleeping in Complete_Master +-- -- having completed a master within itself, +-- -- and is waiting for the tasks dependent on that master to become +-- -- terminated or waiting on a terminate Phase. + +-- Master_Phase_2_Sleep, +-- -- In Phase 2 the task is sleeping in Complete_Master +-- -- waiting for tasks on terminate alternatives to finish +-- -- terminating. + +-- -- The following are special uses of sleep, for server tasks +-- -- within the run-time system. + +-- Interrupt_Server_Idle_Sleep, +-- Interrupt_Server_Blocked_Interrupt_Sleep, +-- Timer_Server_Sleep, +-- AST_Server_Sleep, + +-- Asynchronous_Hold, +-- -- The task has been held by Asynchronous_Task_Control.Hold_Task + +-- Interrupt_Server_Blocked_On_Event_Flag, +-- -- The task has been blocked on a system call waiting for a +-- -- completion event/signal to occur. + +-- Activating, +-- -- Task has been created and is being made Runnable + +-- Acceptor_Delay_Sleep +-- -- Task is waiting on an selective wait statement +-- ); + + -- type Call_Modes is + -- (Simple_Call, Conditional_Call, Asynchronous_Call, Timed_Call); + + -- type Select_Modes is + -- (Simple_Mode, Else_Mode, Terminate_Mode, Delay_Mode); + + -- subtype Delay_Modes is Integer; + + ------------------------------- + -- Entry related definitions -- + ------------------------------- + + Null_Entry : constant := 0; + + Max_Entry : constant := Integer'Last; + + Interrupt_Entry : constant := -2; + + -- Cancelled_Entry : constant := -1; + + type Entry_Index is range Interrupt_Entry .. Max_Entry; + + Null_Task_Entry : constant := Null_Entry; + + Max_Task_Entry : constant := Max_Entry; + + type Task_Entry_Index is new Entry_Index + range Null_Task_Entry .. Max_Task_Entry; + + type Entry_Call_Record; + + type Entry_Call_Link is access all Entry_Call_Record; + + -- type Entry_Queue is record + -- Head : Entry_Call_Link; + -- Tail : Entry_Call_Link; + -- end record; + + -- type Task_Entry_Queue_Array is + -- array (Task_Entry_Index range <>) of Entry_Queue; + + -- A data structure which contains the string names of entries and entry + -- family members. + + -- type String_Access is access all String; + + -- type Task_Entry_Names_Array is + -- array (Entry_Index range <>) of String_Access; + + -- type Task_Entry_Names_Access is access all Task_Entry_Names_Array; + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + -- type Entry_Call_State is + -- (Never_Abortable, + -- -- the call is not abortable, and never can be + + -- Not_Yet_Abortable, + -- -- the call is not abortable, but may become so + + -- Was_Abortable, + -- -- the call is not abortable, but once was + + -- Now_Abortable, + -- -- the call is abortable + + -- Done, + -- -- the call has been completed + + -- Cancelled + -- -- the call was asynchronous, and was cancelled + -- ); + -- pragma Ordered (Entry_Call_State); + + -- Never_Abortable is used for calls that are made in a abort deferred + -- region (see ARM 9.8(5-11), 9.8 (20)). Such a call is never abortable. + + -- The Was_ vs. Not_Yet_ distinction is needed to decide whether it is OK + -- to advance into the abortable part of an async. select stmt. That is + -- allowed iff the mode is Now_ or Was_. + + -- Done indicates the call has been completed, without cancellation, or no + -- call has been made yet at this ATC nesting level, and so aborting the + -- call is no longer an issue. Completion of the call does not necessarily + -- indicate "success"; the call may be returning an exception if + -- Exception_To_Raise is non-null. + + -- Cancelled indicates the call was cancelled, and so aborting the call is + -- no longer an issue. + + -- The call is on an entry queue unless State >= Done, in which case it may + -- or may not be still Onqueue. + + -- Please do not modify the order of the values, without checking all uses + -- of this type. We rely on partial "monotonicity" of + -- Entry_Call_Record.State to avoid locking when we access this value for + -- certain tests. In particular: + + -- 1) Once State >= Done, we can rely that the call has been + -- completed. If State >= Done, it will not + -- change until the task does another entry call at this level. + + -- 2) Once State >= Was_Abortable, we can rely that the call has + -- been queued abortably at least once, and so the check for + -- whether it is OK to advance to the abortable part of an + -- async. select statement does not need to lock anything. + + type Entry_Call_Record is record + Self : Task_Id; + -- ID of the caller + + -- Mode : Call_Modes; + + -- State : Entry_Call_State; + -- pragma Atomic (State); + -- -- Indicates part of the state of the call. + -- -- + -- -- Protection: If the call is not on a queue, it should only be + -- -- accessed by Self, and Self does not need any lock to modify this + -- -- field. + -- -- + -- -- Once the call is on a queue, the value should be something other + -- -- than Done unless it is cancelled, and access is controller by the + -- -- "server" of the queue -- i.e., the lock of Checked_To_Protection + -- -- (Call_Target) if the call record is on the queue of a PO, or the + -- -- lock of Called_Target if the call is on the queue of a task. See + -- -- comments on type declaration for more details. + + Uninterpreted_Data : System.Address; + -- Data passed by the compiler + + -- Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- -- The exception to raise once this call has been completed without + -- -- being aborted. + end record; + pragma Suppress_Initialization (Entry_Call_Record); + + ------------------------------------------- + -- Task termination procedure definition -- + ------------------------------------------- + + -- We need to redefine here these types (already defined in + -- Ada.Task_Termination) for avoiding circular dependencies. + + -- type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception); + -- Possible causes for task termination: + -- + -- Normal means that the task terminates due to completing the + -- last sentence of its body, or as a result of waiting on a + -- terminate alternative. + + -- Abnormal means that the task terminates because it is being aborted + + -- handled_Exception means that the task terminates because of exception + -- raised by the execution of its task_body. + + -- type Termination_Handler is access protected procedure + -- (Cause : Cause_Of_Termination; + -- T : Task_Id; + -- X : Ada.Exceptions.Exception_Occurrence); + -- -- Used to represent protected procedures to be executed when task + -- terminates. + + ------------------------------------ + -- Dispatching domain definitions -- + ------------------------------------ + + -- We need to redefine here these types (already defined in + -- System.Multiprocessor.Dispatching_Domains) for avoiding circular + -- dependencies. + + -- type Dispatching_Domain is + -- array (System.Multiprocessors.CPU range <>) of Boolean; + -- A dispatching domain needs to contain the set of processors belonging + -- to it. This is a processor mask where a True indicates that the + -- processor belongs to the dispatching domain. + -- Do not use the full range of CPU_Range because it would create a very + -- long array. This way we can use the exact range of processors available + -- in the system. + + -- type Dispatching_Domain_Access is access Dispatching_Domain; + + -- System_Domain : Dispatching_Domain_Access; + -- All processors belong to default system dispatching domain at start up. + -- We use a pointer which creates the actual variable for the reasons + -- explained bellow in Dispatching_Domain_Tasks. + + -- Dispatching_Domains_Frozen : Boolean := False; + -- True when the main procedure has been called. Hence, no new dispatching + -- domains can be created when this flag is True. + + -- type Array_Allocated_Tasks is + -- array (System.Multiprocessors.CPU range <>) of Natural; + -- At start-up time, we need to store the number of tasks attached to + -- concrete processors within the system domain (we can only create + -- dispatching domains with processors belonging to the system domain and + -- without tasks allocated). + + -- type Array_Allocated_Tasks_Access is access Array_Allocated_Tasks; + + -- Dispatching_Domain_Tasks : Array_Allocated_Tasks_Access; + -- We need to store whether there are tasks allocated to concrete + -- processors in the default system dispatching domain because we need to + -- check it before creating a new dispatching domain. Two comments about + -- why we use a pointer here and not in package Dispatching_Domains: + -- + -- 1) We use an array created dynamically in procedure Initialize which + -- is called at the beginning of the initialization of the run-time + -- library. Declaring a static array here in the spec would not work + -- across different installations because it would get the value of + -- Number_Of_CPUs from the machine where the run-time library is built, + -- and not from the machine where the application is executed. That is + -- the reason why we create the array (CPU'First .. Number_Of_CPUs) at + -- execution time in the procedure body, ensuring that the function + -- Number_Of_CPUs is executed at execution time (the same trick as we + -- use for System_Domain). + -- + -- 2) We have moved this declaration from package Dispatching_Domains + -- because when we use a pragma CPU, the affinity is passed through the + -- call to Create_Task. Hence, at this point, we may need to update the + -- number of tasks associated to the processor, but we do not want to + -- force a dependency from this package on Dispatching_Domains. + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + type Activation_Chain is limited private; + -- Linked list of to-be-activated tasks, linked through + -- Activation_Link. The order of tasks on the list is irrelevant, because + -- the priority rules will ensure that they actually start activating in + -- priority order. + + type Activation_Chain_Access is access all Activation_Chain; + + type Task_Procedure_Access is access procedure (Arg : System.Address); + + type Access_Boolean is access all Boolean; + + -- function Detect_Blocking return Boolean; + -- pragma Inline (Detect_Blocking); + -- Return whether the Detect_Blocking pragma is enabled + + -- function Storage_Size (T : Task_Id) return System.Parameters.Size_Type; + -- Retrieve from the TCB of the task the allocated size of its stack, + -- either the system default or the size specified by a pragma. This is in + -- general a non-static value that can depend on discriminants of the task. + + -- type Bit_Array is array (Integer range <>) of Boolean; + -- pragma Pack (Bit_Array); + + -- subtype Debug_Event_Array is Bit_Array (1 .. 16); + + -- Global_Task_Debug_Event_Set : Boolean := False; + -- Set True when running under debugger control and a task debug event + -- signal has been requested. + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + -- Notes on protection (synchronization) of TRTS data structures + + -- Any field of the TCB can be written by the activator of a task when the + -- task is created, since no other task can access the new task's + -- state until creation is complete. + + -- The protection for each field is described in a comment starting with + -- "Protection:". + + -- When a lock is used to protect an ATCB field, this lock is simply named + + -- Some protection is described in terms of tasks related to the + -- ATCB being protected. These are: + + -- Self: The task which is controlled by this ATCB + -- Acceptor: A task accepting a call from Self + -- Caller: A task calling an entry of Self + -- Parent: The task executing the master on which Self depends + -- Dependent: A task dependent on Self + -- Activator: The task that created Self and initiated its activation + -- Created: A task created and activated by Self + + -- Note: The order of the fields is important to implement efficiently + -- tasking support under gdb. + -- Currently gdb relies on the order of the State, Parent, Base_Priority, + -- Task_Image, Task_Image_Len, Call and LL fields. + + ------------------------- + -- Common ATCB section -- + ------------------------- + + -- Section used by all GNARL implementations (regular and restricted) + + type Common_ATCB is record + -- State : Task_States; + -- pragma Atomic (State); + -- Encodes some basic information about the state of a task, + -- including whether it has been activated, whether it is sleeping, + -- and whether it is terminated. + -- + -- Protection: Self.L + + -- Parent : Task_Id; + -- The task on which this task depends. + -- See also Master_Level and Master_Within. + + Base_Priority : System.Priority; + -- Base priority, not changed during entry calls, only changed + -- via dynamic priorities package. + -- + -- Protection: Only written by Self, accessed by anyone + + -- Base_CPU : System.Multiprocessors.CPU_Range; + -- Base CPU, only changed via dispatching domains package. + -- + -- Protection: Self.L + + -- Current_Priority : System.Any_Priority; + -- Active priority, except that the effects of protected object + -- priority ceilings are not reflected. This only reflects explicit + -- priority changes and priority inherited through task activation + -- and rendezvous. + -- + -- Ada 95 notes: In Ada 95, this field will be transferred to the + -- Priority field of an Entry_Calls component when an entry call is + -- initiated. The Priority of the Entry_Calls component will not change + -- for the duration of the call. The accepting task can use it to boost + -- its own priority without fear of its changing in the meantime. + -- + -- This can safely be used in the priority ordering of entry queues. + -- Once a call is queued, its priority does not change. + -- + -- Since an entry call cannot be made while executing a protected + -- action, the priority of a task will never reflect a priority ceiling + -- change at the point of an entry call. + -- + -- Protection: Only written by Self, and only accessed when Acceptor + -- accepts an entry or when Created activates, at which points Self is + -- suspended. + + Protected_Action_Nesting : Natural with Atomic; + -- pragma Atomic (Protected_Action_Nesting); + -- The dynamic level of protected action nesting for this task. This + -- field is needed for checking whether potentially blocking operations + -- are invoked from protected actions. pragma Atomic is used because it + -- can be read/written from protected interrupt handlers. + + -- Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); + -- Hold a string that provides a readable id for task, built from the + -- variable of which it is a value or component. + + -- Task_Image_Len : Natural; + -- Actual length of Task_Image + + -- Call : Entry_Call_Link; + -- The entry call that has been accepted by this task. + -- + -- Protection: Self.L. Self will modify this field when Self.Accepting + -- is False, and will not need the mutex to do so. Once a task sets + -- Pending_ATC_Level = 0, no other task can access this field. + + Thread : FreeRTOS.Tasks.Task_Handle; + -- Control block used by the underlying low-level tasking service + -- (GNULLI). + -- + -- Protection: This is used only by the GNULLI implementation, which + -- takes care of all of its synchronization. + + -- Task_Arg : System.Address; + -- The argument to task procedure. Provide a handle for discriminant + -- information. + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Thereafter, + -- Self only reads it. + + -- Task_Alternate_Stack : System.Address; + -- The address of the alternate signal stack for this task, if any + -- + -- Protection: Only accessed by Self + + -- Task_Entry_Point : Task_Procedure_Access; + -- Information needed to call the procedure containing the code for + -- the body of this task. + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Self reads + -- it, once, as part of its execution. + + -- Compiler_Data : System.Soft_Links.TSD; + -- Task-specific data needed by the compiler to store per-task + -- structures. + -- + -- Protection: Only accessed by Self + + All_Tasks_Link : Task_Id; + -- Used to link this task to the list of all tasks in the system. + -- + -- Protection: (Cortex GNAT RTS) Set at task creation, + -- thereafter ony referenced from the debugger. + -- + -- FreeRTOS doesn't provide a straightforward way of accessing + -- tasks queued on protected objects (via semaphores or + -- queues). + + -- Activation_Link : Task_Id; + -- Used to link this task to a list of tasks to be activated + -- + -- Protection: Only used by Activator + + -- Activator : Task_Id; + -- pragma Atomic (Activator); + -- The task that created this task, either by declaring it as a task + -- object or by executing a task allocator. The value is null iff Self + -- has completed activation. + -- + -- Protection: Set by Activator before Self is activated, and + -- only modified by Self after that. Can be read by any task via + -- Ada.Task_Identification.Activation_Is_Complete; hence Atomic. + + -- Wait_Count : Natural; + -- This count is used by a task that is waiting for other tasks. At all + -- other times, the value should be zero. It is used differently in + -- several different states. Since a task cannot be in more than one of + -- these states at the same time, a single counter suffices. + -- + -- Protection: Self.L + + -- Activator_Sleep + + -- This is the number of tasks that this task is activating, i.e. the + -- children that have started activation but have not completed it. + -- + -- Protection: Self.L and Created.L. Both mutexes must be locked, since + -- Self.Activation_Count and Created.State must be synchronized. + + -- Master_Completion_Sleep (phase 1) + + -- This is the number dependent tasks of a master being completed by + -- Self that are activated, but have not yet terminated, and are not + -- waiting on a terminate alternative. + + -- Master_Completion_2_Sleep (phase 2) + + -- This is the count of tasks dependent on a master being completed by + -- Self which are waiting on a terminate alternative. + + -- Elaborated : Access_Boolean; + -- Pointer to a flag indicating that this task's body has been + -- elaborated. The flag is created and managed by the + -- compiler-generated code. + -- + -- Protection: The field itself is only accessed by Activator. The flag + -- that it points to is updated by Master and read by Activator; access + -- is assumed to be atomic. + + -- Activation_Failed : Boolean; + -- Set to True if activation of a chain of tasks fails, + -- so that the activator should raise Tasking_Error. + + -- Task_Info : System.Task_Info.Task_Info_Type; + -- System-specific attributes of the task as specified by the + -- Task_Info pragma. + + -- Analyzer : System.Stack_Usage.Stack_Analyzer; + -- For storing informations used to measure the stack usage + + -- Global_Task_Lock_Nesting : Natural; + -- This is the current nesting level of calls to + -- System.Tasking.Initialization.Lock_Task. This allows a task to call + -- Lock_Task multiple times without deadlocking. A task only locks + -- Global_Task_Lock when its Global_Task_Lock_Nesting goes from 0 to 1, + -- and only unlocked when it goes from 1 to 0. + -- + -- Protection: Only accessed by Self + + -- Fall_Back_Handler : Termination_Handler; + -- This is the fall-back handler that applies to the dependent tasks of + -- the task. + -- + -- Protection: Self.L + + -- Specific_Handler : Termination_Handler; + -- This is the specific handler that applies only to this task, and not + -- any of its dependent tasks. + -- + -- Protection: Self.L + + -- Debug_Events : Debug_Event_Array; + -- Word length array of per task debug events, of which 11 kinds are + -- currently defined in System.Tasking.Debugging package. + + -- Domain : Dispatching_Domain_Access; + -- Domain is the dispatching domain to which the task belongs. It is + -- only changed via dispatching domains package. This field is made + -- part of the Common_ATCB, even when restricted run-times (namely + -- Ravenscar) do not use it, because this way the field is always + -- available to the underlying layers to set the affinity and we do not + -- need to do different things depending on the situation. + -- + -- Protection: Self.L + end record; + + --------------------------------------- + -- Restricted_Ada_Task_Control_Block -- + --------------------------------------- + + -- This type should only be used by the restricted GNARLI and by restricted + -- GNULL implementations to allocate an ATCB (see System.Task_Primitives. + -- Operations.New_ATCB) that will take significantly less memory. + + -- Note that the restricted GNARLI should only access fields that are + -- present in the Restricted_Ada_Task_Control_Block structure. + + -- Note that the compiler requires this type to be called + -- Ada_Task_Control_Block. + type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is + record + Common : Common_ATCB; + -- The common part between various tasking implementations + + Secondary_Stack : System.Secondary_Stack.SS_Stack_Ptr; + -- Protection : only accessed at task creation. + + Entry_Call : aliased Entry_Call_Record; + -- Protection: This field is used on entry call "queues" associated + -- with protected objects, and is protected by the protected object + -- lock. + end record; + pragma Suppress_Initialization (Ada_Task_Control_Block); + + -- Interrupt_Manager_ID : Task_Id; + -- This task ID is declared here to break circular dependencies. + -- Also declare Interrupt_Manager_ID after Task_Id is known, to avoid + -- generating unneeded finalization code. + + ----------------------- + -- List of all Tasks -- + ----------------------- + + -- All_Tasks_List : Task_Id; + -- Global linked list of all tasks + + ------------------------------------------ + -- Regular (non restricted) definitions -- + ------------------------------------------ + + -------------------------------- + -- Master Related Definitions -- + -------------------------------- + + subtype Master_Level is Integer; + subtype Master_ID is Master_Level; + + -- Normally, a task starts out with internal master nesting level one + -- larger than external master nesting level. It is incremented by one by + -- Enter_Master, which is called in the task body only if the compiler + -- thinks the task may have dependent tasks. It is set to 1 for the + -- environment task, the level 2 is reserved for server tasks of the + -- run-time system (the so called "independent tasks"), and the level 3 is + -- for the library level tasks. Foreign threads which are detected by + -- the run-time have a level of 0, allowing these tasks to be easily + -- distinguished if needed. + + Foreign_Task_Level : constant Master_Level := 0; + Environment_Task_Level : constant Master_Level := 1; + Independent_Task_Level : constant Master_Level := 2; + Library_Task_Level : constant Master_Level := 3; + + ------------------- + -- Priority info -- + ------------------- + + Unspecified_Priority : constant Integer := System.Priority'First - 1; + + -- Priority_Not_Boosted : constant Integer := System.Priority'First - 1; + -- Definition of Priority actually has to come from the RTS configuration + + -- subtype Rendezvous_Priority is Integer + -- range Priority_Not_Boosted .. System.Any_Priority'Last; + + ------------------- + -- Affinity info -- + ------------------- + + Unspecified_CPU : constant := -1; + -- No affinity specified + + ------------------------------------ + -- Rendezvous related definitions -- + ------------------------------------ + + -- No_Rendezvous : constant := 0; + + -- Max_Select : constant Integer := Integer'Last; + -- RTS-defined + + -- subtype Select_Index is Integer range No_Rendezvous .. Max_Select; + -- type Select_Index is range No_Rendezvous .. Max_Select; + + -- subtype Positive_Select_Index is + -- Select_Index range 1 .. Select_Index'Last; + + -- type Accept_Alternative is record + -- Null_Body : Boolean; + -- S : Task_Entry_Index; + -- end record; + + -- type Accept_List is + -- array (Positive_Select_Index range <>) of Accept_Alternative; + + -- type Accept_List_Access is access constant Accept_List; + + ----------------------------------- + -- ATC_Level related definitions -- + ----------------------------------- + + -- Max_ATC_Nesting : constant Natural := 20; + + -- subtype ATC_Level_Base is Integer range 0 .. Max_ATC_Nesting; + + -- ATC_Level_Infinity : constant ATC_Level_Base := ATC_Level_Base'Last; + + -- subtype ATC_Level is ATC_Level_Base range 0 .. ATC_Level_Base'Last - 1; + + -- subtype ATC_Level_Index is ATC_Level range 1 .. ATC_Level'Last; + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + -- type Entry_Call_Record is record + -- null; + -- Self : Task_Id; + -- ID of the caller + + -- Mode : Call_Modes; + + -- State : Entry_Call_State; + -- pragma Atomic (State); + -- Indicates part of the state of the call + -- + -- Protection: If the call is not on a queue, it should only be + -- accessed by Self, and Self does not need any lock to modify this + -- field. Once the call is on a queue, the value should be something + -- other than Done unless it is cancelled, and access is controller by + -- the "server" of the queue -- i.e., the lock of Checked_To_Protection + -- (Call_Target) if the call record is on the queue of a PO, or the + -- lock of Called_Target if the call is on the queue of a task. See + -- comments on type declaration for more details. + + -- Uninterpreted_Data : System.Address; + -- Data passed by the compiler + + -- Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- The exception to raise once this call has been completed without + -- being aborted. + + -- Prev : Entry_Call_Link; + + -- Next : Entry_Call_Link; + + -- Level : ATC_Level; + -- One of Self and Level are redundant in this implementation, since + -- each Entry_Call_Record is at Self.Entry_Calls (Level). Since we must + -- have access to the entry call record to be reading this, we could + -- get Self from Level, or Level from Self. However, this requires + -- non-portable address arithmetic. + + -- E : Entry_Index; + + -- Prio : System.Any_Priority; + + -- The above fields are those that there may be some hope of packing. + -- They are gathered together to allow for compilers that lay records + -- out contiguously, to allow for such packing. + + -- Called_Task : Task_Id; + -- pragma Atomic (Called_Task); + -- Use for task entry calls. The value is null if the call record is + -- not in use. Conversely, unless State is Done and Onqueue is false, + -- Called_Task points to an ATCB. + -- + -- Protection: Called_Task.L + + -- Called_PO : System.Address; + -- pragma Atomic (Called_PO); + -- Similar to Called_Task but for protected objects + -- + -- Note that the previous implementation tried to merge both + -- Called_Task and Called_PO but this ended up in many unexpected + -- complications (e.g having to add a magic number in the ATCB, which + -- caused gdb lots of confusion) with no real gain since the + -- Lock_Server implementation still need to loop around chasing for + -- pointer changes even with a single pointer. + + -- Acceptor_Prev_Call : Entry_Call_Link; + -- For task entry calls only + + -- Acceptor_Prev_Priority : Rendezvous_Priority := Priority_Not_Boosted; + -- For task entry calls only. The priority of the most recent prior + -- call being serviced. For protected entry calls, this function should + -- be performed by GNULLI ceiling locking. + + -- Cancellation_Attempted : Boolean := False; + -- pragma Atomic (Cancellation_Attempted); + -- Cancellation of the call has been attempted. + -- Consider merging this into State??? + + -- With_Abort : Boolean := False; + -- Tell caller whether the call may be aborted + -- ??? consider merging this with Was_Abortable state + + -- Needs_Requeue : Boolean := False; + -- Temporary to tell acceptor of task entry call that + -- Exceptional_Complete_Rendezvous needs to do requeue. + -- end record; + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + -- type Access_Address is access all System.Address; + -- Anonymous pointer used to implement task attributes (see s-tataat.adb + -- and a-tasatt.adb) + + -- pragma No_Strict_Aliasing (Access_Address); + -- This type is used in contexts where aliasing may be an issue (see + -- for example s-tataat.adb), so we avoid any incorrect aliasing + -- assumptions. + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + -- type Entry_Call_Array is array (ATC_Level_Index) of + -- aliased Entry_Call_Record; + + -- type Direct_Index is range 0 .. Parameters.Default_Attribute_Count; + -- subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last; + -- Attributes with indexes in this range are stored directly in the task + -- control block. Such attributes must be Address-sized. Other attributes + -- will be held in dynamically allocated records chained off of the task + -- control block. + + -- type Direct_Attribute_Element is mod Memory_Size; + -- pragma Atomic (Direct_Attribute_Element); + + -- type Direct_Attribute_Array is + -- array (Direct_Index_Range) of aliased Direct_Attribute_Element; + + -- type Direct_Index_Vector is mod 2 ** Parameters.Default_Attribute_Count; + -- This is a bit-vector type, used to store information about + -- the usage of the direct attribute fields. + + -- type Task_Serial_Number is mod 2 ** 64; + -- Used to give each task a unique serial number + + -- type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is record + -- Common : Common_ATCB; + -- The common part between various tasking implementations + + -- Entry_Calls : Entry_Call_Array; + -- An array of entry calls + -- + -- Protection: The elements of this array are on entry call queues + -- associated with protected objects or task entries, and are protected + -- by the protected object lock or Acceptor.L, respectively. + + -- Entry_Names : Task_Entry_Names_Access := null; + -- An array of string names which denotes entry [family member] names. + -- The structure is indexed by task entry index and contains Entry_Num + -- components. + -- + -- Protection: The array is populated during task initialization, before + -- the task has been activated. No protection is required in this case. + + -- New_Base_Priority : System.Any_Priority; + -- New value for Base_Priority (for dynamic priorities package) + -- + -- Protection: Self.L + + -- Open_Accepts : Accept_List_Access; + -- This points to the Open_Accepts array of accept alternatives passed + -- to the RTS by the compiler-generated code to Selective_Wait. It is + -- non-null iff this task is ready to accept an entry call. + -- + -- Protection: Self.L + + -- Chosen_Index : Select_Index; + -- The index in Open_Accepts of the entry call accepted by a selective + -- wait executed by this task. + -- + -- Protection: Written by both Self and Caller. Usually protected by + -- Self.L. However, once the selection is known to have been written it + -- can be accessed without protection. This happens after Self has + -- updated it itself using information from a suspended Caller, or + -- after Caller has updated it and awakened Self. + + -- Master_of_Task : Master_Level; + -- The task executing the master of this task, and the ID of this task's + -- master (unique only among masters currently active within Parent). + -- + -- Protection: Set by Activator before Self is activated, and read + -- after Self is activated. + + -- Master_Within : Master_Level; + -- The ID of the master currently executing within this task; that is, + -- the most deeply nested currently active master. + -- + -- Protection: Only written by Self, and only read by Self or by + -- dependents when Self is attempting to exit a master. Since Self will + -- not write this field until the master is complete, the + -- synchronization should be adequate to prevent races. + + -- Alive_Count : Natural := 0; + -- Number of tasks directly dependent on this task (including itself) + -- that are still "alive", i.e. not terminated. + -- + -- Protection: Self.L + + -- Awake_Count : Natural := 0; + -- Number of tasks directly dependent on this task (including itself) + -- still "awake", i.e., are not terminated and not waiting on a + -- terminate alternative. + -- + -- Invariant: Awake_Count <= Alive_Count + + -- Protection: Self.L + + -- Beginning of flags + + -- Aborting : Boolean := False; + -- pragma Atomic (Aborting); + -- Self is in the process of aborting. While set, prevents multiple + -- abort signals from being sent by different aborter while abort + -- is acted upon. This is essential since an aborter which calls + -- Abort_To_Level could set the Pending_ATC_Level to yet a lower level + -- (than the current level), may be preempted and would send the + -- abort signal when resuming execution. At this point, the abortee + -- may have completed abort to the proper level such that the + -- signal (and resulting abort exception) are not handled any more. + -- In other words, the flag prevents a race between multiple aborters + -- + -- Protection: protected by atomic access. + + -- ATC_Hack : Boolean := False; + -- pragma Atomic (ATC_Hack); + -- ????? + -- Temporary fix, to allow Undefer_Abort to reset Aborting in the + -- handler for Abort_Signal that encloses an async. entry call. + -- For the longer term, this should be done via code in the + -- handler itself. + + -- Callable : Boolean := True; + -- It is OK to call entries of this task + + -- Dependents_Aborted : Boolean := False; + -- This is set to True by whichever task takes responsibility for + -- aborting the dependents of this task. + -- + -- Protection: Self.L + + -- Interrupt_Entry : Boolean := False; + -- Indicates if one or more Interrupt Entries are attached to the task. + -- This flag is needed for cleaning up the Interrupt Entry bindings. + + -- Pending_Action : Boolean := False; + -- Unified flag indicating some action needs to be take when abort + -- next becomes undeferred. Currently set if: + -- . Pending_Priority_Change is set + -- . Pending_ATC_Level is changed + -- . Requeue involving POs + -- (Abortable field may have changed and the Wait_Until_Abortable + -- has to recheck the abortable status of the call.) + -- . Exception_To_Raise is non-null + -- + -- Protection: Self.L + -- + -- This should never be reset back to False outside of the procedure + -- Do_Pending_Action, which is called by Undefer_Abort. It should only + -- be set to True by Set_Priority and Abort_To_Level. + + -- Pending_Priority_Change : Boolean := False; + -- Flag to indicate pending priority change (for dynamic priorities + -- package). The base priority is updated on the next abort + -- completion point (aka. synchronization point). + -- + -- Protection: Self.L + + -- Terminate_Alternative : Boolean := False; + -- Task is accepting Select with Terminate Alternative + -- + -- Protection: Self.L + + -- End of flags + + -- Beginning of counts + + -- ATC_Nesting_Level : ATC_Level := 1; + -- The dynamic level of ATC nesting (currently executing nested + -- asynchronous select statements) in this task. + + -- Protection: Self_ID.L. Only Self reads or updates this field. + -- Decrementing it deallocates an Entry_Calls component, and care must + -- be taken that all references to that component are eliminated before + -- doing the decrement. This in turn will require locking a protected + -- object (for a protected entry call) or the Acceptor's lock (for a + -- task entry call). No other task should attempt to read or modify + -- this value. + + -- Deferral_Level : Natural := 1; + -- This is the number of times that Defer_Abort has been called by + -- this task without a matching Undefer_Abort call. Abortion is only + -- allowed when this zero. It is initially 1, to protect the task at + -- startup. + + -- Protection: Only updated by Self; access assumed to be atomic + + -- Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity; + -- The ATC level to which this task is currently being aborted. If the + -- value is zero, the entire task has "completed". That may be via + -- abort, exception propagation, or normal exit. If the value is + -- ATC_Level_Infinity, the task is not being aborted to any level. If + -- the value is positive, the task has not completed. This should ONLY + -- be modified by Abort_To_Level and Exit_One_ATC_Level. + -- + -- Protection: Self.L + + -- Serial_Number : Task_Serial_Number; + -- Monotonic counter to provide some way to check locking rules/ordering + + -- Known_Tasks_Index : Integer := -1; + -- Index in the System.Tasking.Debug.Known_Tasks array + + -- User_State : Long_Integer := 0; + -- User-writeable location, for use in debugging tasks; also provides a + -- simple task specific data. + + -- Direct_Attributes : Direct_Attribute_Array; + -- For task attributes that have same size as Address + + -- Is_Defined : Direct_Index_Vector := 0; + -- Bit I is 1 iff Direct_Attributes (I) is defined + + -- Indirect_Attributes : Access_Address; + -- A pointer to chain of records for other attributes that are not + -- address-sized, including all tagged types. + + -- Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); + -- An array of task entry queues + -- + -- Protection: Self.L. Once a task has set Self.Stage to Completing, it + -- has exclusive access to this field. + + -- Free_On_Termination : Boolean := False; + -- Deallocate the ATCB when the task terminates. This flag is normally + -- False, and is set True when Unchecked_Deallocation is called on a + -- non-terminated task so that the associated storage is automatically + -- reclaimed when the task terminates. + -- end record; + + -------------------- + -- Initialization -- + -------------------- + + -- procedure Initialize; + -- This procedure constitutes the first part of the initialization of the + -- GNARL. This includes creating data structures to make the initial thread + -- into the environment task. The last part of the initialization is done + -- in System.Tasking.Initialization or System.Tasking.Restricted.Stages. + -- All the initializations used to be in Tasking.Initialization, but this + -- is no longer possible with the run time simplification (including + -- optimized PO and the restricted run time) since one cannot rely on + -- System.Tasking.Initialization being present, as was done before. + + -- procedure Initialize_ATCB + -- (Self_ID : Task_Id; + -- Task_Entry_Point : Task_Procedure_Access; + -- Task_Arg : System.Address; + -- Parent : Task_Id; + -- Elaborated : Access_Boolean; + -- Base_Priority : System.Any_Priority; + -- Base_CPU : System.Multiprocessors.CPU_Range; + -- Domain : Dispatching_Domain_Access; + -- Task_Info : System.Task_Info.Task_Info_Type; + -- Stack_Size : System.Parameters.Size_Type; + -- T : Task_Id; + -- Success : out Boolean); + -- Initialize fields of a TCB and link into global TCB structures Call + -- this only with abort deferred and holding RTS_Lock. Need more + -- documentation, mention T, and describe Success ??? + +private + + -- Null_Task : constant Task_Id := null; + + type Activation_Chain is limited record + T_ID : Task_Id; + end record; + + -- Activation_Chain is an in-out parameter of initialization procedures and + -- it must be passed by reference because the init proc may terminate + -- abnormally after creating task components, and these must be properly + -- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces + -- Activation_Chain to be a by-reference type; see RM-6.2(4). + + -- function Number_Of_Entries (Self_Id : Task_Id) return Entry_Index; + -- Given a task, return the number of entries it contains + + -- procedure Set_Entry_Names + -- (Self_Id : Task_Id; + -- Names : Task_Entry_Names_Access); + -- Associate an array of strings denotinge entry [family] names with a task + + Task_Chain : Task_Id; + -- Used in Cortex GNAT RTS as head of a chain through all the + -- tasks, to allow finding them in GDB. FreeRTOS doesn't provide a + -- straightforward way of accessing tasks queued on protected + -- objects (via semaphores or queues). + +end System.Tasking;