------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Cheddar is a GNU GPL real time scheduling analysis tool. -- This program provides services to automatically check performances -- of real time architectures. -- -- Copyright (C) 2002-2010, by Frank Singhoff, Alain Plantec, Jerome Legrand -- -- The Cheddar project was started in 2002 by -- the LISyC Team, University of Western Britanny. -- -- Since 2008, Ellidiss technologies also contributes to the development of -- Cheddar and provides industrial support. -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This program 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. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- Contact : cheddar@listes.univ-brest.fr -- ----------------------------------------------------------------------------- -- Last update : -- $Rev: 523 $ -- $Date: 2012-09-26 15:09:39 +0200 (Wed, 26 Sep 2012) $ -- $Author: fotsing $ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ with Time_Unit_Events; use Time_Unit_Events; use Time_Unit_Events.Time_Unit_Package; with unbounded_strings; use unbounded_strings; with Ada.Exceptions; use Ada.Exceptions; with Translate; use Translate; with Objects; use Objects; with Objects.extended; use Objects.extended; with initialize_framework; use initialize_framework; package body Resource_Set is procedure Task_Begin_End (Task_Name : in Unbounded_String; Resource_Name : in Unbounded_String; A_Resource_Set : in Resources_Set; Starts_Ends : in out Start_End_Table; Elements : in out Resource_accesses_Range) is My_Resource_Iterator : Resources_Iterator; A_Resource : Generic_Resource_Ptr; Index : Resource_accesses_Range := 0; -- looking for a resource and a task the end and the begin of this task on --this resource -- Element is the number of element, must start to 0 -- begin reset_iterator (A_Resource_Set, My_Resource_Iterator); loop current_element (A_Resource_Set, A_Resource, My_Resource_Iterator); if A_Resource.name = Resource_Name then for I in 0 .. A_Resource.critical_sections.nb_entries - 1 loop if (A_Resource.critical_sections.entries (Index).item = Task_Name) then Starts_Ends (Elements + 1).task_begin := A_Resource.critical_sections.entries (Index).data.task_begin; Starts_Ends (Elements + 1).task_end := A_Resource.critical_sections.entries (Index).data.task_end; Elements := Elements + 1; end if; Index := Index + 1; end loop; exit; end if; exit when is_last_element (A_Resource_Set, My_Resource_Iterator); next_element (A_Resource_Set, My_Resource_Iterator); end loop; end Task_Begin_End; procedure Update_Resource (My_Resources : in out Resources_Set; Name : in Unbounded_String; State : in Integer; address : in Integer; size : in Integer; Cpu_Name : in Unbounded_String; Address_Space_Name : in Unbounded_String; Protocol : in Resources_Type; Affected_Tasks : in Resource_accesses_Table; priority : in integer; priority_assignment : in Priority_Assignment_Type) is The_Resource : Generic_Resource_Ptr; begin The_Resource := Search_Resource (My_Resources, Name); Check_Resource (My_Resources, Name, State, address, size, Cpu_Name, Address_Space_Name, Protocol, priority); delete (My_Resources, The_Resource); Add_Resource (My_Resources, Name, State, address, size, Cpu_Name, Address_Space_Name, Protocol, Affected_Tasks, priority, priority_assignment); end Update_Resource; procedure Add_Resource (My_Resources : in out Resources_Set; Name : in Unbounded_String; State : in Integer; address : in Integer; size : in Integer; Cpu_Name : in Unbounded_String; Address_Space_Name : in Unbounded_String; Protocol : in Resources_Type; Affected_Tasks : in Resource_accesses_Table; priority : in integer; priority_assignment : in Priority_Assignment_Type) is A_Resource_Ptr : Generic_Resource_Ptr; begin Add_Resource (My_Resources, A_Resource_Ptr, Name, State, address, size, Cpu_Name, Address_Space_Name, Protocol, Affected_Tasks, priority, priority_assignment); end Add_Resource; procedure Check_Resource (My_Resources : in Resources_Set; Name : in Unbounded_String; State : in Integer; address : in Integer; size : in Integer; Cpu_Name : in Unbounded_String; Address_Space_Name : in Unbounded_String; Protocol : in Resources_Type; Priority : in Integer) is begin if Name = "" then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource_Name (Current_Language) & Lb_Mandatory (Current_Language))); end if; if not Is_A_Valid_Identifier (Name) then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " : " & Lb_Resource_Name (Current_Language) & Lb_Colon & Lb_Invalid_Identifier (Current_Language))); end if; if Cpu_Name = "" then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " : " & Lb_Processor_Name (Current_Language) & Lb_Mandatory (Current_Language))); end if; if Address_Space_Name = "" then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " : " & Lb_Address_Space_Name (Current_Language) & Lb_Mandatory (Current_Language))); end if; if (Protocol /= No_Protocol) and (Protocol /= Priority_Ceiling_Protocol) and (Protocol /= Priority_Inheritance_Protocol) and (Protocol /= Immediate_Priority_Ceiling_Protocol) then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " : " & Lb_Invalid_Protocol (Current_Language))); end if; if (size < 0) then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " ; " & Lb_Size (Current_Language) & Lb_Must_Be (Current_Language) & To_Unbounded_String (" >=0 "))); end if; if (address < 0) then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " ; " & lb_address (Current_Language) & Lb_Must_Be (Current_Language) & To_Unbounded_String (" >=0 "))); end if; if (Priority < Integer (Priority_Range'First)) or (Priority > Integer (Priority_Range'Last)) then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " : " & Lb_Invalid_Priority (Current_Language))); end if; end Check_Resource; procedure Add_Resource (My_Resources : in out Resources_Set; A_Resource : in out Generic_Resource_Ptr; Name : in Unbounded_String; State : in Integer; address : in Integer; size : in Integer; Cpu_Name : in Unbounded_String; Address_Space_Name : in Unbounded_String; Protocol : in Resources_Type; Affected_Tasks : in Resource_accesses_Table; priority : in integer; priority_assignment : in Priority_Assignment_Type) is New_Protocol : Resources_Type; New_Pcp_Resource : Pcp_Resource_Ptr; New_Pip_Resource : Pip_Resource_Ptr; New_Np_Resource : Np_Resource_Ptr; New_IPcp_Resource : IPcp_Resource_Ptr; My_Iterator : iterator; begin check_initialize; Check_Resource (My_Resources, Name, State, address, size, Cpu_Name, Address_Space_Name, Protocol, priority); -- Resource already exist ? -- if (get_number_of_elements (My_Resources) > 0) then reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if (Name = A_Resource.name) then Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Resource (Current_Language) & " " & Name & " : " & Lb_Resource_Name (Current_Language) & Lb_Already_Defined (Current_Language))); end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; end if; if (Protocol = Priority_Ceiling_Protocol) then New_Pcp_Resource := new Pcp_Resource; New_Pcp_Resource.priority := Priority_Range(Priority); New_Protocol := Priority_Ceiling_Protocol; A_Resource := Generic_Resource_Ptr (New_Pcp_Resource); else if (Protocol = Priority_Inheritance_Protocol) then New_Pip_Resource := new Pip_Resource; New_Protocol := Priority_Inheritance_Protocol; A_Resource := Generic_Resource_Ptr (New_Pip_Resource); else if (Protocol = No_Protocol) then New_Np_Resource := new Np_Resource; New_Protocol := No_Protocol; A_Resource := Generic_Resource_Ptr (New_Np_Resource); else New_IPcp_Resource := new IPcp_Resource; New_IPcp_Resource.priority := Priority_Range(Priority); New_Protocol := Immediate_Priority_Ceiling_Protocol; A_Resource := Generic_Resource_Ptr (New_IPcp_Resource); end if; end if; end if; A_Resource.name := Name; A_Resource.state := State; A_Resource.size := size; A_Resource.address := address; A_Resource.cpu_name := Cpu_Name; A_Resource.address_space_name := Address_Space_Name; A_Resource.protocol := New_Protocol; A_Resource.priority := Priority_Range (priority); A_Resource.priority_assignment := priority_assignment; A_Resource.critical_sections := Affected_Tasks; add (My_Resources, A_Resource); exception when full_set => Raise_Exception (Invalid_Parameter'Identity, To_String (Lb_Can_Not_Define_More_Resources (Current_Language))); end Add_Resource; function Search_Resource_by_id (My_Resources : in Resources_Set; id : in Unbounded_String) return Generic_Resource_Ptr is My_Iterator : iterator; A_Resource : Generic_Resource_Ptr; Result : Generic_Resource_Ptr; Found : Boolean := False; begin reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if (A_Resource.cheddar_private_id = id) then Found := True; Result := A_Resource; end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; if not Found then Raise_Exception (Resource_Not_Found'Identity, To_String (Lb_Resource_id (Current_Language) & "=" & id)); end if; return Result; end Search_Resource_by_id; function Search_Resource (My_Resources : in Resources_Set; Name : in Unbounded_String) return Generic_Resource_Ptr is My_Iterator : iterator; A_Resource : Generic_Resource_Ptr; Result : Generic_Resource_Ptr; Found : Boolean := False; begin reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if (A_Resource.name = Name) then Found := True; Result := A_Resource; end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; if not Found then Raise_Exception (Resource_Not_Found'Identity, To_String (Lb_Resource_Name (Current_Language) & "=" & Name)); end if; return Result; end Search_Resource; procedure Delete_Task (My_Resources : in out Resources_Set; A_Task : in Unbounded_String) is A_Resource : Generic_Resource_Ptr; My_Iterator : Resources_Iterator; Index : Resource_accesses_Range := 1; begin if (get_number_of_elements (My_Resources) > 0) then reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); -- Looking for a_task in the task_list and delete it -- Index := 0; while (Index < A_Resource.critical_sections.nb_entries) loop if (A_Resource.critical_sections.entries (Index).item = A_Task) then A_Resource.critical_sections.entries (Index) := A_Resource.critical_sections.entries (A_Resource.critical_sections. nb_entries - 1); A_Resource.critical_sections.nb_entries := A_Resource.critical_sections.nb_entries - 1; end if; Index := Index + 1; end loop; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; end if; end Delete_Task; procedure Delete_Address_Space (My_Resources : in out Resources_Set; A_Addr : in Unbounded_String) is Tmp : Resources_Set; A_Resource : Generic_Resource_Ptr; My_Iterator : Resources_Iterator; begin if (get_number_of_elements (My_Resources) > 0) then reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if (A_Resource.address_space_name = A_Addr) then add (Tmp, A_Resource); end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; if not is_empty (Tmp) then reset_iterator (Tmp, My_Iterator); loop current_element (Tmp, A_Resource, My_Iterator); delete (My_Resources, A_Resource); exit when is_last_element (Tmp, My_Iterator); next_element (Tmp, My_Iterator); end loop; end if; end if; end Delete_Address_Space; procedure Delete_Processor (My_Resources : in out Resources_Set; A_Processor : in Unbounded_String) is Tmp : Resources_Set; A_Resource : Generic_Resource_Ptr; My_Iterator : Resources_Iterator; begin if (get_number_of_elements (My_Resources) > 0) then reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if (A_Resource.cpu_name = A_Processor) then add (Tmp, A_Resource); end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; if not is_empty (Tmp) then reset_iterator (Tmp, My_Iterator); loop current_element (Tmp, A_Resource, My_Iterator); delete (My_Resources, A_Resource); exit when is_last_element (Tmp, My_Iterator); next_element (Tmp, My_Iterator); end loop; reset (Tmp, False); end if; end if; end Delete_Processor; procedure Same_Protocol_Control (My_Resources : in Resources_Set; A_Task : in Unbounded_String) is A_Protocol : Resources_Type; Is_First : Boolean := True; Iterator1 : Resources_Iterator; Resource1 : Generic_Resource_Ptr; begin reset_iterator (My_Resources, Iterator1); loop current_element (My_Resources, Resource1, Iterator1); -- Looking for task user in the task_list index_table -- for I in 0 .. Resource1.critical_sections.nb_entries - 1 loop if A_Task = Resource1.critical_sections.entries (I).item then if Is_First then Is_First := False; A_Protocol := Resource1.protocol; else if A_Protocol /= Resource1.protocol then raise Can_Not_Used_Different_Protocol; end if; end if; end if; end loop; exit when is_last_element (My_Resources, Iterator1); next_element (My_Resources, Iterator1); end loop; end Same_Protocol_Control; function Export_Aadl_Implementations (My_Resources : in Resources_Set) return Unbounded_String is My_Iterator : Resources_Iterator; A_Resource : Generic_Resource_Ptr; Result : Unbounded_String := empty_string; begin if not is_empty (My_Resources) then reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); Result := Result & To_Unbounded_String ("data " & To_String (A_Resource.name)) & unbounded_lf; Result := Result & To_Unbounded_String ("end " & To_String (A_Resource.name) & ";") & unbounded_lf & unbounded_lf; Result := Result & To_Unbounded_String ("data implementation " & To_String (A_Resource.name) & ".Impl") & unbounded_lf; Result := Result & To_Unbounded_String (ASCII.HT & "properties ") & unbounded_lf; Result := Result & To_Unbounded_String (ASCII.HT & ASCII.HT & "Cheddar_Properties::Data_Concurrency_State => " & A_Resource.state'Img & ";") & unbounded_lf; Result := Result & To_Unbounded_String (ASCII.HT & ASCII.HT & "Concurrency_Control_Protocol => " & A_Resource.protocol'Img & ";") & unbounded_lf; Result := Result & To_Unbounded_String ("end " & To_String (A_Resource.name) & ".Impl;") & unbounded_lf & unbounded_lf; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; end if; return Result; end Export_Aadl_Implementations; function Export_Aadl_Declarations (My_Resources : in Resources_Set; Address_Space_Name : Unbounded_String; Number_Of_Ht : in Natural) return Unbounded_String is My_Iterator : Resources_Iterator; A_Resource : Generic_Resource_Ptr; Result : Unbounded_String := empty_string; begin if not is_empty (My_Resources) then reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if A_Resource.address_space_name = Address_Space_Name then for I in 1 .. Number_Of_Ht loop Result := Result & ASCII.HT; end loop; Result := Result & To_Unbounded_String ("instancied_" & To_String (A_Resource.name) & " : data " & To_String (A_Resource.name) & ".Impl;") & unbounded_lf; end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; end if; return Result; end Export_Aadl_Declarations; function Export_Aadl_Connections (My_Resources : in Resources_Set; A_Task_Name : in Unbounded_String; Number_Of_Ht : in Natural) return Unbounded_String is My_Iterator : Resources_Iterator; A_Resource : Generic_Resource_Ptr; Result : Unbounded_String := empty_string; begin if not is_empty (My_Resources) then reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if A_Resource.critical_sections.nb_entries /= 0 then for I in 0 .. A_Resource.critical_sections.nb_entries - 1 loop if A_Resource.critical_sections.entries (I).item = A_Task_Name then for J in 1 .. Number_Of_Ht loop Result := Result & ASCII.HT; end loop; Result := Result & To_Unbounded_String ("data access " & To_String ("instancied_" & To_String (A_Resource.name) & " -> " & "instancied_" & A_Task_Name & "." & A_Resource.name & "_features") & ";") & unbounded_lf; end if; end loop; end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; end if; return Result; end Export_Aadl_Connections; function Get_Number_Of_Resource_From_Processor (My_Resources : in Resources_Set; Processor_Name : in Unbounded_String) return Resources_Range is Number : Resources_Range := 0; A_Resource : Generic_Resource_Ptr; My_Iterator : iterator; begin if is_empty (My_Resources) then return 0; end if; reset_iterator (My_Resources, My_Iterator); loop current_element (My_Resources, A_Resource, My_Iterator); if (A_Resource.cpu_name = Processor_Name) then Number := Number + 1; end if; exit when is_last_element (My_Resources, My_Iterator); next_element (My_Resources, My_Iterator); end loop; return Number; end Get_Number_Of_Resource_From_Processor; end Resource_Set;