mlib-tgt-vms-ia64.adb, [...] (Is_Interface): Change Ada bind file prefix on VMS from b$ to b__.
2005-12-05 Doug Rupp <rupp@adacore.com>
* mlib-tgt-vms-ia64.adb, mlib-tgt-vms-alpha.adb (Is_Interface): Change
Ada bind file prefix on VMS from b$ to b__.
(Build_Dynamic_Library): Change Init file suffix on VMS from $init to
__init.
* prj-nmsc.adb: Change some Hostparm.OpenVMS checks to
Targparm.OpenVMS_On_Target.
(Object_Suffix): Initialize with target object suffix.
(Get_Unit): Change Ada bind file prefix on VMS from b$ to b__.
* butil.adb: Change some Hostparm.OpenVMS checks to
Targparm.OpenVMS_On_Target.
* clean.adb: Change some Hostparm.OpenVMS checks to
Targparm.OpenVMS_On_Target.
(Object_Suffix): Initialize with call to Get_Target_Object_Suffix.
({declaraction},Delete_Binder_Generated_Files,{initialization}): Change
Ada bind file prefix on VMS from b$ to b__.
* gnatlink.adb (Process_Args): Call Add_Src_Search_Dir for -I in
--GCC so that Get_Target_Parameters can find system.ads.
(Gnatlink): Call Get_Target_Parameters in mainline.
Initialize standard packages for Targparm.
Change some Hostparm.OpenVMS checks to Targparm.OpenVMS_On_Target.
(Process_Args): Also Check for object files with target object
extension.
(Make_Binder_File_Names): Create with target object extension.
(Make_Binder_File_Names): Change Ada bind file prefix on VMS from b$
to b__.
* mlib-prj.adb: Change some Hostparm.OpenVMS checks to
Targparm.OpenVMS_On_Target.
({declaration},Build_Library,Check_Library): Change Ada bind file
prefix on VMS from b$ to b__.
* osint-b.adb: Change some Hostparm.OpenVMS checks to
Targparm.OpenVMS_On_Target.
(Create_Binder_Output): Change Ada bind file prefix on VMS from b$ to
b__.
* targext.c: New file.
* Makefile.in: add support for vxworks653 builds
(../../vxaddr2line): gnatlink with targext.o.
(TOOLS_LIBS): Move targext.o to precede libgnat.
(init.o, initialize.o): Minor clean up in dependencies.
(GNATLINK_OBJS): Add targparm.o, snames.o
Add rules fo building targext.o and linking it explicitly with all
tools.
Also add targext.o to gnatlib.
* Make-lang.in: Add rules for building targext.o and linking it in
with gnat1 and gnatbind.
Add entry for exp_sel.o.
* osint.adb Change some Hostparm.OpenVMS checks to
Targparm.OpenVMS_On_Target.
(Object_File_Name): Use target object suffix.
* osint.ads (Object_Suffix): Remove, no longer used.
(Target_Object_Suffix): Initialize with target object suffix.
* rident.ads: Add special exception to license.
* targparm.adb (Get_Target_Parameters): Set the value of
Multi_Unit_Index_Character after OpenVMS_On_Target gets its definitive
value.
(Get_Target_Parameters): Set OpenVMS_On_Target if openvms.
* targparm.ads: Add special exception to license.
* g-os_lib.ads, g-os_lib.adb (Get_Target_Debuggable_Suffix): New
function.
(Copy_File): Make sure from file is closed if error on to file
(Get_Target_Executable_Suffix, Get_Target_Object_Suffix): New functions.
* make.adb (Object_Suffix): Intialize with Get_Target_Object_Suffix.
(Executable_Suffix): Intialize with Get_Target_Executable_Suffix.
* osint-c.adb (Set_Output_Object_File_Name): Initialize extension with
target object suffix.
From-SVN: r108282
This commit is contained in:
Doug Rupp
Arnaud Charlet
parent
9d0aa6abaf
commit
81408d4928
34 changed files with 27105 additions and 277 deletions
|
|
@ -1,5 +1,5 @@
|
|||
# Makefile.rtl for GNU Ada Compiler (GNAT).
|
||||
# Copyright (C) 2003, 2004 Free Software Foundation, Inc.
|
||||
# Copyright (C) 2003-2005, Free Software Foundation, Inc.
|
||||
|
||||
#This file is part of GCC.
|
||||
|
||||
|
|
@ -35,6 +35,7 @@ GNATRTL_TASKING_OBJS= \
|
|||
a-sytaco$(objext) \
|
||||
a-tasatt$(objext) \
|
||||
a-taside$(objext) \
|
||||
a-taster$(objext) \
|
||||
g-boubuf$(objext) \
|
||||
g-boumai$(objext) \
|
||||
g-semaph$(objext) \
|
||||
|
|
@ -279,6 +280,13 @@ GNATRTL_NONTASKING_OBJS= \
|
|||
a-zzunio$(objext) \
|
||||
ada$(objext) \
|
||||
calendar$(objext) \
|
||||
g-allein$(objext) \
|
||||
g-alleve$(objext) \
|
||||
g-altcon$(objext) \
|
||||
g-altive$(objext) \
|
||||
g-alveop$(objext) \
|
||||
g-alvety$(objext) \
|
||||
g-alvevi$(objext) \
|
||||
g-arrspl$(objext) \
|
||||
g-awk$(objext) \
|
||||
g-bubsor$(objext) \
|
||||
|
|
@ -497,6 +505,7 @@ GNATRTL_NONTASKING_OBJS= \
|
|||
s-sopco4$(objext) \
|
||||
s-sopco5$(objext) \
|
||||
s-stache$(objext) \
|
||||
s-stausa$(objext) \
|
||||
s-stchop$(objext) \
|
||||
s-stalib$(objext) \
|
||||
s-stoele$(objext) \
|
||||
|
|
|
|||
|
|
@ -38,6 +38,11 @@
|
|||
-- Default version for most targets
|
||||
|
||||
with System.Standard_Library; use System.Standard_Library;
|
||||
-- Used for Adafinal
|
||||
|
||||
with System.Soft_Links;
|
||||
-- Used for Task_Termination_Handler
|
||||
-- Task_Termination_NT
|
||||
|
||||
procedure Ada.Exceptions.Last_Chance_Handler
|
||||
(Except : Exception_Occurrence)
|
||||
|
|
@ -72,6 +77,14 @@ is
|
|||
-- Convenient shortcut
|
||||
|
||||
begin
|
||||
-- Do not execute any task termination code when shutting down the system.
|
||||
-- The Adafinal procedure would execute the task termination routine for
|
||||
-- normal termination, but we have already executed the task termination
|
||||
-- procedure because of an unhandled exception.
|
||||
|
||||
System.Soft_Links.Task_Termination_Handler :=
|
||||
System.Soft_Links.Task_Termination_NT'Access;
|
||||
|
||||
-- Let's shutdown the runtime now. The rest of the procedure needs to be
|
||||
-- careful not to use anything that would require runtime support. In
|
||||
-- particular, functions returning strings are banned since the sec stack
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ package body Exception_Traces is
|
|||
-- Hook for GDB to support "break exception unhandled"
|
||||
|
||||
-- For "break exception", GDB uses __gnat_raise_nodefer_with_msg, which
|
||||
-- is not in this section because it fullfills other purposes than a mere
|
||||
-- is not in this section because it functions as more than simply a
|
||||
-- debugger interface.
|
||||
|
||||
--------------------------------
|
||||
|
|
@ -161,8 +161,18 @@ package body Exception_Traces is
|
|||
--------------------------------
|
||||
|
||||
procedure Notify_Unhandled_Exception is
|
||||
Excep : constant EOA := Get_Current_Excep.all;
|
||||
|
||||
begin
|
||||
Notify_Exception (Get_Current_Excep.all, Is_Unhandled => True);
|
||||
-- Check whether there is any termination handler to be executed for
|
||||
-- the environment task, and execute it if needed. Here we handle both
|
||||
-- the Abnormal and Unhandled_Exception task termination. Normal
|
||||
-- task termination routine is executed elsewhere (either in the
|
||||
-- Task_Wrapper or in the Adafinal routine for the environment task).
|
||||
|
||||
Task_Termination_Handler.all (Excep.all);
|
||||
|
||||
Notify_Exception (Excep, Is_Unhandled => True);
|
||||
Unhandled_Exception;
|
||||
end Notify_Unhandled_Exception;
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@ pragma Warnings (Off);
|
|||
-- package will be categorized as Preelaborate. See AI-362 for details.
|
||||
-- It is safe in the context of the run-time to violate the rules!
|
||||
|
||||
with System.Tasking.Stages;
|
||||
with System.Tasking.Utilities;
|
||||
-- Used for Abort_Tasks
|
||||
|
||||
pragma Warnings (On);
|
||||
|
||||
|
|
@ -81,7 +82,7 @@ package body Ada.Task_Identification is
|
|||
if T = Null_Task_Id then
|
||||
raise Program_Error;
|
||||
else
|
||||
System.Tasking.Stages.Abort_Tasks
|
||||
System.Tasking.Utilities.Abort_Tasks
|
||||
(System.Tasking.Task_List'(1 => Convert_Ids (T)));
|
||||
end if;
|
||||
end Abort_Task;
|
||||
|
|
|
|||
128
gcc/ada/a-taster.adb
Normal file
128
gcc/ada/a-taster.adb
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- A D A . T A S K _ T E R M I N A T I O N --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2005, 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 2, 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. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
|
||||
-- Boston, MA 02110-1301, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with System.Tasking;
|
||||
-- used for Task_Id
|
||||
|
||||
with System.Task_Primitives.Operations;
|
||||
-- used for Self
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package body Ada.Task_Termination is
|
||||
|
||||
use type Ada.Task_Identification.Task_Id;
|
||||
|
||||
package STPO renames System.Task_Primitives.Operations;
|
||||
|
||||
-----------------------
|
||||
-- Local subprograms --
|
||||
-----------------------
|
||||
|
||||
function To_TT is new Unchecked_Conversion
|
||||
(System.Tasking.Termination_Handler, Termination_Handler);
|
||||
|
||||
function To_ST is new Unchecked_Conversion
|
||||
(Termination_Handler, System.Tasking.Termination_Handler);
|
||||
|
||||
function To_Task_Id is new Unchecked_Conversion
|
||||
(Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
|
||||
|
||||
-----------------------------------
|
||||
-- Current_Task_Fallback_Handler --
|
||||
-----------------------------------
|
||||
|
||||
function Current_Task_Fallback_Handler return Termination_Handler is
|
||||
begin
|
||||
return To_TT (System.Tasking.Self.Common.Fall_Back_Handler);
|
||||
end Current_Task_Fallback_Handler;
|
||||
|
||||
-------------------------------------
|
||||
-- Set_Dependents_Fallback_Handler --
|
||||
-------------------------------------
|
||||
|
||||
procedure Set_Dependents_Fallback_Handler
|
||||
(Handler : Termination_Handler)
|
||||
is
|
||||
begin
|
||||
STPO.Self.Common.Fall_Back_Handler := To_ST (Handler);
|
||||
end Set_Dependents_Fallback_Handler;
|
||||
|
||||
--------------------------
|
||||
-- Set_Specific_Handler --
|
||||
--------------------------
|
||||
|
||||
procedure Set_Specific_Handler
|
||||
(T : Ada.Task_Identification.Task_Id;
|
||||
Handler : Termination_Handler)
|
||||
is
|
||||
begin
|
||||
-- Tasking_Error is raised if the task identified by T has already
|
||||
-- terminated. Program_Error is raised if the value of T is
|
||||
-- Null_Task_Id.
|
||||
|
||||
if T = Ada.Task_Identification.Null_Task_Id then
|
||||
raise Program_Error;
|
||||
elsif Ada.Task_Identification.Is_Terminated (T) then
|
||||
raise Tasking_Error;
|
||||
else
|
||||
To_Task_Id (T).Common.Specific_Handler := To_ST (Handler);
|
||||
end if;
|
||||
end Set_Specific_Handler;
|
||||
|
||||
----------------------
|
||||
-- Specific_Handler --
|
||||
----------------------
|
||||
|
||||
function Specific_Handler
|
||||
(T : Ada.Task_Identification.Task_Id) return Termination_Handler
|
||||
is
|
||||
begin
|
||||
-- Tasking_Error is raised if the task identified by T has already
|
||||
-- terminated. Program_Error is raised if the value of T is
|
||||
-- Null_Task_Id.
|
||||
|
||||
if T = Ada.Task_Identification.Null_Task_Id then
|
||||
raise Program_Error;
|
||||
elsif Ada.Task_Identification.Is_Terminated (T) then
|
||||
raise Tasking_Error;
|
||||
else
|
||||
return To_TT (To_Task_Id (T).Common.Specific_Handler);
|
||||
end if;
|
||||
end Specific_Handler;
|
||||
|
||||
end Ada.Task_Termination;
|
||||
43
gcc/ada/a-taster.ads
Normal file
43
gcc/ada/a-taster.ads
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- A D A . T A S K _ T E R M I N A T I O N --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2005, 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 was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Task_Identification;
|
||||
with Ada.Exceptions;
|
||||
|
||||
package Ada.Task_Termination is
|
||||
pragma Preelaborate (Task_Termination);
|
||||
|
||||
type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception);
|
||||
|
||||
type Termination_Handler is access protected procedure
|
||||
(Cause : Cause_Of_Termination;
|
||||
T : Ada.Task_Identification.Task_Id;
|
||||
X : Ada.Exceptions.Exception_Occurrence);
|
||||
|
||||
procedure Set_Dependents_Fallback_Handler
|
||||
(Handler : Termination_Handler);
|
||||
function Current_Task_Fallback_Handler return Termination_Handler;
|
||||
|
||||
procedure Set_Specific_Handler
|
||||
(T : Ada.Task_Identification.Task_Id;
|
||||
Handler : Termination_Handler);
|
||||
function Specific_Handler
|
||||
(T : Ada.Task_Identification.Task_Id) return Termination_Handler;
|
||||
|
||||
end Ada.Task_Termination;
|
||||
|
|
@ -1268,6 +1268,22 @@ package body Bindgen is
|
|||
WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
|
||||
end if;
|
||||
|
||||
-- If we want to analyze the stack, we have to import corresponding
|
||||
-- symbols
|
||||
|
||||
if Dynamic_Stack_Measurement then
|
||||
WBI ("");
|
||||
WBI (" procedure Output_Results;");
|
||||
WBI (" pragma Import (C, Output_Results, " &
|
||||
"""__gnat_stack_usage_output_results"");");
|
||||
|
||||
WBI ("");
|
||||
WBI (" " &
|
||||
"procedure Initialize_Stack_Analysis (Buffer_Size : Natural);");
|
||||
WBI (" pragma Import (C, Initialize_Stack_Analysis, " &
|
||||
"""__gnat_stack_usage_initialize"");");
|
||||
end if;
|
||||
|
||||
-- Deal with declarations for main program case
|
||||
|
||||
if not No_Main_Subprogram then
|
||||
|
|
@ -1360,6 +1376,13 @@ package body Bindgen is
|
|||
Write_Statement_Buffer;
|
||||
end if;
|
||||
|
||||
if Dynamic_Stack_Measurement then
|
||||
Set_String (" Initialize_Stack_Analysis (");
|
||||
Set_Int (Dynamic_Stack_Measurement_Array_Size);
|
||||
Set_String (");");
|
||||
Write_Statement_Buffer;
|
||||
end if;
|
||||
|
||||
if not Cumulative_Restrictions.Set (No_Finalization) then
|
||||
|
||||
if not No_Main_Subprogram
|
||||
|
|
@ -1398,6 +1421,12 @@ package body Bindgen is
|
|||
end if;
|
||||
end if;
|
||||
|
||||
-- Prints the result of static stack analysis
|
||||
|
||||
if Dynamic_Stack_Measurement then
|
||||
WBI (" Output_Results;");
|
||||
end if;
|
||||
|
||||
-- Finalize is only called if we have a run time
|
||||
|
||||
if not Cumulative_Restrictions.Set (No_Finalization) then
|
||||
|
|
@ -1506,6 +1535,15 @@ package body Bindgen is
|
|||
Write_Statement_Buffer;
|
||||
end if;
|
||||
|
||||
-- Initializes dynamic stack measurement if needed
|
||||
|
||||
if Dynamic_Stack_Measurement then
|
||||
Set_String (" __gnat_stack_usage_initialize (");
|
||||
Set_Int (Dynamic_Stack_Measurement_Array_Size);
|
||||
Set_String (");");
|
||||
Write_Statement_Buffer;
|
||||
end if;
|
||||
|
||||
-- The __gnat_initialize routine is used only if we have a run-time
|
||||
|
||||
if not Suppress_Standard_Library_On_Target then
|
||||
|
|
@ -1552,6 +1590,12 @@ package body Bindgen is
|
|||
WBI (" system__standard_library__adafinal ();");
|
||||
end if;
|
||||
|
||||
-- Outputs the dynamic stack measurement if needed
|
||||
|
||||
if Dynamic_Stack_Measurement then
|
||||
WBI (" __gnat_stack_usage_output_results ();");
|
||||
end if;
|
||||
|
||||
-- The finalize routine is used only if we have a run-time
|
||||
|
||||
if not Suppress_Standard_Library_On_Target then
|
||||
|
|
@ -1681,7 +1725,7 @@ package body Bindgen is
|
|||
-- filename object is seen. Multiply defined symbols will
|
||||
-- result.
|
||||
|
||||
if Hostparm.OpenVMS
|
||||
if OpenVMS_On_Target
|
||||
and then Is_Internal_File_Name
|
||||
(ALIs.Table
|
||||
(Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
|
||||
|
|
@ -2244,6 +2288,12 @@ package body Bindgen is
|
|||
WBI ("extern void __gnat_install_handler (void);");
|
||||
end if;
|
||||
|
||||
if Dynamic_Stack_Measurement then
|
||||
WBI ("");
|
||||
WBI ("extern void __gnat_stack_usage_output_results (void);");
|
||||
WBI ("extern void __gnat_stack_usage_initialize (int size);");
|
||||
end if;
|
||||
|
||||
WBI ("");
|
||||
|
||||
Gen_Elab_Defs_C;
|
||||
|
|
@ -2780,7 +2830,7 @@ package body Bindgen is
|
|||
With_GNARL := True;
|
||||
end if;
|
||||
|
||||
if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
|
||||
if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then
|
||||
With_DECGNAT := True;
|
||||
end if;
|
||||
end loop;
|
||||
|
|
|
|||
|
|
@ -214,6 +214,12 @@ begin
|
|||
Write_Str (" -Tn Set time slice value to n milliseconds (n >= 0)");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -u switch
|
||||
|
||||
Write_Str (" -un Enable dynamic stack analysis, with n results ");
|
||||
Write_Str ("stored");
|
||||
Write_Eol;
|
||||
|
||||
-- Line for -v switch
|
||||
|
||||
Write_Str (" -v Verbose mode. Error messages, ");
|
||||
|
|
|
|||
1356
gcc/ada/g-allein.ads
Normal file
1356
gcc/ada/g-allein.ads
Normal file
File diff suppressed because it is too large
Load diff
5035
gcc/ada/g-alleve.adb
Normal file
5035
gcc/ada/g-alleve.adb
Normal file
File diff suppressed because it is too large
Load diff
528
gcc/ada/g-alleve.ads
Normal file
528
gcc/ada/g-alleve.ads
Normal file
|
|
@ -0,0 +1,528 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (Soft Binding Version) --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2005, 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 2, 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. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This unit exposes the low level vector support for the Soft binding,
|
||||
-- intended for non AltiVec capable targets. See Altivec.Design for a
|
||||
-- description of what is expected to be exposed.
|
||||
|
||||
with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views;
|
||||
|
||||
package GNAT.Altivec.Low_Level_Vectors is
|
||||
|
||||
----------------------------------------
|
||||
-- Low level vector type declarations --
|
||||
----------------------------------------
|
||||
|
||||
type LL_VUC is private;
|
||||
type LL_VSC is private;
|
||||
type LL_VBC is private;
|
||||
|
||||
type LL_VUS is private;
|
||||
type LL_VSS is private;
|
||||
type LL_VBS is private;
|
||||
|
||||
type LL_VUI is private;
|
||||
type LL_VSI is private;
|
||||
type LL_VBI is private;
|
||||
|
||||
type LL_VF is private;
|
||||
type LL_VP is private;
|
||||
|
||||
------------------------------------
|
||||
-- Low level functional interface --
|
||||
------------------------------------
|
||||
|
||||
function abs_v16qi (A : LL_VSC) return LL_VSC;
|
||||
function abs_v8hi (A : LL_VSS) return LL_VSS;
|
||||
function abs_v4si (A : LL_VSI) return LL_VSI;
|
||||
function abs_v4sf (A : LL_VF) return LL_VF;
|
||||
|
||||
function abss_v16qi (A : LL_VSC) return LL_VSC;
|
||||
function abss_v8hi (A : LL_VSS) return LL_VSS;
|
||||
function abss_v4si (A : LL_VSI) return LL_VSI;
|
||||
|
||||
function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vaddfp (A : LL_VF; B : LL_VF) return LL_VF;
|
||||
|
||||
function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vand (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI;
|
||||
|
||||
function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VSI;
|
||||
|
||||
function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VSI;
|
||||
|
||||
function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VSI;
|
||||
|
||||
function vcfux (A : LL_VSI; B : c_int) return LL_VF;
|
||||
function vcfsx (A : LL_VSI; B : c_int) return LL_VF;
|
||||
|
||||
function vctsxs (A : LL_VF; B : c_int) return LL_VSI;
|
||||
function vctuxs (A : LL_VF; B : c_int) return LL_VSI;
|
||||
|
||||
procedure dss (A : c_int);
|
||||
procedure dssall;
|
||||
|
||||
procedure dst (A : c_ptr; B : c_int; C : c_int);
|
||||
procedure dstst (A : c_ptr; B : c_int; C : c_int);
|
||||
procedure dststt (A : c_ptr; B : c_int; C : c_int);
|
||||
procedure dstt (A : c_ptr; B : c_int; C : c_int);
|
||||
|
||||
function vexptefp (A : LL_VF) return LL_VF;
|
||||
|
||||
function vrfim (A : LL_VF) return LL_VF;
|
||||
|
||||
function lvx (A : c_long; B : c_ptr) return LL_VSI;
|
||||
function lvebx (A : c_long; B : c_ptr) return LL_VSC;
|
||||
function lvehx (A : c_long; B : c_ptr) return LL_VSS;
|
||||
function lvewx (A : c_long; B : c_ptr) return LL_VSI;
|
||||
function lvxl (A : c_long; B : c_ptr) return LL_VSI;
|
||||
|
||||
function vlogefp (A : LL_VF) return LL_VF;
|
||||
|
||||
function lvsl (A : c_long; B : c_ptr) return LL_VSC;
|
||||
function lvsr (A : c_long; B : c_ptr) return LL_VSC;
|
||||
|
||||
function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF;
|
||||
|
||||
function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
|
||||
|
||||
function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF;
|
||||
|
||||
function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function mfvscr return LL_VSS;
|
||||
|
||||
function vminfp (A : LL_VF; B : LL_VF) return LL_VF;
|
||||
function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
|
||||
|
||||
function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
|
||||
|
||||
function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI;
|
||||
function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI;
|
||||
function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
|
||||
function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
|
||||
function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
|
||||
function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
|
||||
|
||||
procedure mtvscr (A : LL_VSI);
|
||||
|
||||
function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS;
|
||||
function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI;
|
||||
function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS;
|
||||
function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI;
|
||||
|
||||
function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS;
|
||||
function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI;
|
||||
function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS;
|
||||
function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI;
|
||||
|
||||
function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF;
|
||||
|
||||
function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vor (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC;
|
||||
function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS;
|
||||
function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS;
|
||||
function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC;
|
||||
function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS;
|
||||
function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC;
|
||||
function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS;
|
||||
function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC;
|
||||
function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS;
|
||||
|
||||
function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI;
|
||||
|
||||
function vrefp (A : LL_VF) return LL_VF;
|
||||
|
||||
function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vrfin (A : LL_VF) return LL_VF;
|
||||
function vrfip (A : LL_VF) return LL_VF;
|
||||
function vrfiz (A : LL_VF) return LL_VF;
|
||||
|
||||
function vrsqrtefp (A : LL_VF) return LL_VF;
|
||||
|
||||
function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI;
|
||||
|
||||
function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI;
|
||||
function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS;
|
||||
function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC;
|
||||
function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF;
|
||||
|
||||
function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vspltb (A : LL_VSC; B : c_int) return LL_VSC;
|
||||
function vsplth (A : LL_VSS; B : c_int) return LL_VSS;
|
||||
function vspltw (A : LL_VSI; B : c_int) return LL_VSI;
|
||||
|
||||
function vspltisb (A : c_int) return LL_VSC;
|
||||
function vspltish (A : c_int) return LL_VSS;
|
||||
function vspltisw (A : c_int) return LL_VSI;
|
||||
|
||||
function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
procedure stvx (A : LL_VSI; B : c_int; C : c_ptr);
|
||||
procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr);
|
||||
procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr);
|
||||
procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr);
|
||||
procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr);
|
||||
|
||||
function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vsubfp (A : LL_VF; B : LL_VF) return LL_VF;
|
||||
|
||||
function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC;
|
||||
function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS;
|
||||
function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI;
|
||||
function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI;
|
||||
function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
|
||||
|
||||
function vupkhsb (A : LL_VSC) return LL_VSS;
|
||||
function vupkhsh (A : LL_VSS) return LL_VSI;
|
||||
function vupkhpx (A : LL_VSS) return LL_VSI;
|
||||
|
||||
function vupklsb (A : LL_VSC) return LL_VSS;
|
||||
function vupklsh (A : LL_VSS) return LL_VSI;
|
||||
function vupklpx (A : LL_VSS) return LL_VSI;
|
||||
|
||||
function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
|
||||
function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
|
||||
function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
|
||||
function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
|
||||
|
||||
function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
|
||||
function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
|
||||
function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
|
||||
function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
|
||||
function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
|
||||
function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
|
||||
function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
|
||||
|
||||
function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
|
||||
function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
|
||||
|
||||
private
|
||||
|
||||
---------------------------------------
|
||||
-- Low level vector type definitions --
|
||||
---------------------------------------
|
||||
|
||||
-- We simply use the natural array definitions corresponding to each
|
||||
-- user-level vector type.
|
||||
|
||||
type LL_VUI is new VUC_View;
|
||||
type LL_VSI is new VUC_View;
|
||||
|
||||
type LL_VUS is new VUC_View;
|
||||
type LL_VSS is new VUC_View;
|
||||
|
||||
type LL_VUC is new VUC_View;
|
||||
type LL_VSC is new VUC_View;
|
||||
|
||||
type LL_VF is new VUC_View;
|
||||
|
||||
type LL_VBC is new VUC_View;
|
||||
type LL_VBS is new VUC_View;
|
||||
type LL_VBI is new VUC_View;
|
||||
type LL_VP is new VUC_View;
|
||||
|
||||
------------------------------------
|
||||
-- Low level functional interface --
|
||||
------------------------------------
|
||||
|
||||
pragma Convention_Identifier (LL_Altivec, C);
|
||||
|
||||
pragma Export (LL_Altivec, dss, "__builtin_altivec_dss");
|
||||
pragma Export (LL_Altivec, dssall, "__builtin_altivec_dssall");
|
||||
pragma Export (LL_Altivec, dst, "__builtin_altivec_dst");
|
||||
pragma Export (LL_Altivec, dstst, "__builtin_altivec_dstst");
|
||||
pragma Export (LL_Altivec, dststt, "__builtin_altivec_dststt");
|
||||
pragma Export (LL_Altivec, dstt, "__builtin_altivec_dstt");
|
||||
pragma Export (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr");
|
||||
pragma Export (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr");
|
||||
pragma Export (LL_Altivec, stvebx, "__builtin_altivec_stvebx");
|
||||
pragma Export (LL_Altivec, stvehx, "__builtin_altivec_stvehx");
|
||||
pragma Export (LL_Altivec, stvewx, "__builtin_altivec_stvewx");
|
||||
pragma Export (LL_Altivec, stvx, "__builtin_altivec_stvx");
|
||||
pragma Export (LL_Altivec, stvxl, "__builtin_altivec_stvxl");
|
||||
pragma Export (LL_Altivec, lvebx, "__builtin_altivec_lvebx");
|
||||
pragma Export (LL_Altivec, lvehx, "__builtin_altivec_lvehx");
|
||||
pragma Export (LL_Altivec, lvewx, "__builtin_altivec_lvewx");
|
||||
pragma Export (LL_Altivec, lvx, "__builtin_altivec_lvx");
|
||||
pragma Export (LL_Altivec, lvxl, "__builtin_altivec_lvxl");
|
||||
pragma Export (LL_Altivec, lvsl, "__builtin_altivec_lvsl");
|
||||
pragma Export (LL_Altivec, lvsr, "__builtin_altivec_lvsr");
|
||||
pragma Export (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi");
|
||||
pragma Export (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi");
|
||||
pragma Export (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si");
|
||||
pragma Export (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf");
|
||||
pragma Export (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi");
|
||||
pragma Export (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi");
|
||||
pragma Export (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si");
|
||||
pragma Export (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw");
|
||||
pragma Export (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp");
|
||||
pragma Export (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs");
|
||||
pragma Export (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs");
|
||||
pragma Export (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws");
|
||||
pragma Export (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm");
|
||||
pragma Export (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs");
|
||||
pragma Export (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm");
|
||||
pragma Export (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs");
|
||||
pragma Export (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm");
|
||||
pragma Export (LL_Altivec, vadduws, "__builtin_altivec_vadduws");
|
||||
pragma Export (LL_Altivec, vand, "__builtin_altivec_vand");
|
||||
pragma Export (LL_Altivec, vandc, "__builtin_altivec_vandc");
|
||||
pragma Export (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb");
|
||||
pragma Export (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh");
|
||||
pragma Export (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw");
|
||||
pragma Export (LL_Altivec, vavgub, "__builtin_altivec_vavgub");
|
||||
pragma Export (LL_Altivec, vavguh, "__builtin_altivec_vavguh");
|
||||
pragma Export (LL_Altivec, vavguw, "__builtin_altivec_vavguw");
|
||||
pragma Export (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx");
|
||||
pragma Export (LL_Altivec, vcfux, "__builtin_altivec_vcfux");
|
||||
pragma Export (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp");
|
||||
pragma Export (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp");
|
||||
pragma Export (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb");
|
||||
pragma Export (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh");
|
||||
pragma Export (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw");
|
||||
pragma Export (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp");
|
||||
pragma Export (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp");
|
||||
pragma Export (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb");
|
||||
pragma Export (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh");
|
||||
pragma Export (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw");
|
||||
pragma Export (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub");
|
||||
pragma Export (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh");
|
||||
pragma Export (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw");
|
||||
pragma Export (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs");
|
||||
pragma Export (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs");
|
||||
pragma Export (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp");
|
||||
pragma Export (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp");
|
||||
pragma Export (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp");
|
||||
pragma Export (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp");
|
||||
pragma Export (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb");
|
||||
pragma Export (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh");
|
||||
pragma Export (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw");
|
||||
pragma Export (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub");
|
||||
pragma Export (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh");
|
||||
pragma Export (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw");
|
||||
pragma Export (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs");
|
||||
pragma Export (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs");
|
||||
pragma Export (LL_Altivec, vminfp, "__builtin_altivec_vminfp");
|
||||
pragma Export (LL_Altivec, vminsb, "__builtin_altivec_vminsb");
|
||||
pragma Export (LL_Altivec, vminsh, "__builtin_altivec_vminsh");
|
||||
pragma Export (LL_Altivec, vminsw, "__builtin_altivec_vminsw");
|
||||
pragma Export (LL_Altivec, vminub, "__builtin_altivec_vminub");
|
||||
pragma Export (LL_Altivec, vminuh, "__builtin_altivec_vminuh");
|
||||
pragma Export (LL_Altivec, vminuw, "__builtin_altivec_vminuw");
|
||||
pragma Export (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm");
|
||||
pragma Export (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb");
|
||||
pragma Export (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh");
|
||||
pragma Export (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw");
|
||||
pragma Export (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb");
|
||||
pragma Export (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh");
|
||||
pragma Export (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw");
|
||||
pragma Export (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm");
|
||||
pragma Export (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm");
|
||||
pragma Export (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs");
|
||||
pragma Export (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm");
|
||||
pragma Export (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm");
|
||||
pragma Export (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs");
|
||||
pragma Export (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb");
|
||||
pragma Export (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh");
|
||||
pragma Export (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub");
|
||||
pragma Export (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh");
|
||||
pragma Export (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb");
|
||||
pragma Export (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh");
|
||||
pragma Export (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub");
|
||||
pragma Export (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh");
|
||||
pragma Export (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp");
|
||||
pragma Export (LL_Altivec, vnor, "__builtin_altivec_vnor");
|
||||
pragma Export (LL_Altivec, vxor, "__builtin_altivec_vxor");
|
||||
pragma Export (LL_Altivec, vor, "__builtin_altivec_vor");
|
||||
pragma Export (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si");
|
||||
pragma Export (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx");
|
||||
pragma Export (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss");
|
||||
pragma Export (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus");
|
||||
pragma Export (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss");
|
||||
pragma Export (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus");
|
||||
pragma Export (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum");
|
||||
pragma Export (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus");
|
||||
pragma Export (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum");
|
||||
pragma Export (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus");
|
||||
pragma Export (LL_Altivec, vrefp, "__builtin_altivec_vrefp");
|
||||
pragma Export (LL_Altivec, vrfim, "__builtin_altivec_vrfim");
|
||||
pragma Export (LL_Altivec, vrfin, "__builtin_altivec_vrfin");
|
||||
pragma Export (LL_Altivec, vrfip, "__builtin_altivec_vrfip");
|
||||
pragma Export (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz");
|
||||
pragma Export (LL_Altivec, vrlb, "__builtin_altivec_vrlb");
|
||||
pragma Export (LL_Altivec, vrlh, "__builtin_altivec_vrlh");
|
||||
pragma Export (LL_Altivec, vrlw, "__builtin_altivec_vrlw");
|
||||
pragma Export (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp");
|
||||
pragma Export (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si");
|
||||
pragma Export (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si");
|
||||
pragma Export (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi");
|
||||
pragma Export (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi");
|
||||
pragma Export (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf");
|
||||
pragma Export (LL_Altivec, vsl, "__builtin_altivec_vsl");
|
||||
pragma Export (LL_Altivec, vslb, "__builtin_altivec_vslb");
|
||||
pragma Export (LL_Altivec, vslh, "__builtin_altivec_vslh");
|
||||
pragma Export (LL_Altivec, vslo, "__builtin_altivec_vslo");
|
||||
pragma Export (LL_Altivec, vslw, "__builtin_altivec_vslw");
|
||||
pragma Export (LL_Altivec, vspltb, "__builtin_altivec_vspltb");
|
||||
pragma Export (LL_Altivec, vsplth, "__builtin_altivec_vsplth");
|
||||
pragma Export (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb");
|
||||
pragma Export (LL_Altivec, vspltish, "__builtin_altivec_vspltish");
|
||||
pragma Export (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw");
|
||||
pragma Export (LL_Altivec, vspltw, "__builtin_altivec_vspltw");
|
||||
pragma Export (LL_Altivec, vsr, "__builtin_altivec_vsr");
|
||||
pragma Export (LL_Altivec, vsrab, "__builtin_altivec_vsrab");
|
||||
pragma Export (LL_Altivec, vsrah, "__builtin_altivec_vsrah");
|
||||
pragma Export (LL_Altivec, vsraw, "__builtin_altivec_vsraw");
|
||||
pragma Export (LL_Altivec, vsrb, "__builtin_altivec_vsrb");
|
||||
pragma Export (LL_Altivec, vsrh, "__builtin_altivec_vsrh");
|
||||
pragma Export (LL_Altivec, vsro, "__builtin_altivec_vsro");
|
||||
pragma Export (LL_Altivec, vsrw, "__builtin_altivec_vsrw");
|
||||
pragma Export (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw");
|
||||
pragma Export (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp");
|
||||
pragma Export (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs");
|
||||
pragma Export (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs");
|
||||
pragma Export (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws");
|
||||
pragma Export (LL_Altivec, vsububm, "__builtin_altivec_vsububm");
|
||||
pragma Export (LL_Altivec, vsububs, "__builtin_altivec_vsububs");
|
||||
pragma Export (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm");
|
||||
pragma Export (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs");
|
||||
pragma Export (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm");
|
||||
pragma Export (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws");
|
||||
pragma Export (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws");
|
||||
pragma Export (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs");
|
||||
pragma Export (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs");
|
||||
pragma Export (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs");
|
||||
pragma Export (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws");
|
||||
pragma Export (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx");
|
||||
pragma Export (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb");
|
||||
pragma Export (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh");
|
||||
pragma Export (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx");
|
||||
pragma Export (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb");
|
||||
pragma Export (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh");
|
||||
pragma Export (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p");
|
||||
pragma Export (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p");
|
||||
pragma Export (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p");
|
||||
pragma Export (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p");
|
||||
pragma Export (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p");
|
||||
pragma Export (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p");
|
||||
pragma Export (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p");
|
||||
pragma Export (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p");
|
||||
pragma Export (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p");
|
||||
pragma Export (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p");
|
||||
pragma Export (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p");
|
||||
pragma Export (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p");
|
||||
pragma Export (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p");
|
||||
|
||||
end GNAT.Altivec.Low_Level_Vectors;
|
||||
486
gcc/ada/g-altcon.adb
Normal file
486
gcc/ada/g-altcon.adb
Normal file
|
|
@ -0,0 +1,486 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . A L T I V E C . C O N V E R S I O N S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2005, 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 2, 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. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Unchecked_Conversion;
|
||||
|
||||
with System; use System;
|
||||
|
||||
with GNAT.Altivec.Low_Level_Interface; use GNAT.Altivec.Low_Level_Interface;
|
||||
with GNAT.Altivec.Low_Level_Vectors; use GNAT.Altivec.Low_Level_Vectors;
|
||||
|
||||
package body GNAT.Altivec.Conversions is
|
||||
|
||||
function To_Varray_unsigned_char is
|
||||
new Ada.Unchecked_Conversion (Varray_signed_char,
|
||||
Varray_unsigned_char);
|
||||
|
||||
function To_Varray_unsigned_char is
|
||||
new Ada.Unchecked_Conversion (Varray_bool_char,
|
||||
Varray_unsigned_char);
|
||||
|
||||
function To_Varray_unsigned_short is
|
||||
new Ada.Unchecked_Conversion (Varray_signed_short,
|
||||
Varray_unsigned_short);
|
||||
|
||||
function To_Varray_unsigned_short is
|
||||
new Ada.Unchecked_Conversion (Varray_bool_short,
|
||||
Varray_unsigned_short);
|
||||
|
||||
function To_Varray_unsigned_short is
|
||||
new Ada.Unchecked_Conversion (Varray_pixel,
|
||||
Varray_unsigned_short);
|
||||
|
||||
function To_Varray_unsigned_int is
|
||||
new Ada.Unchecked_Conversion (Varray_signed_int,
|
||||
Varray_unsigned_int);
|
||||
|
||||
function To_Varray_unsigned_int is
|
||||
new Ada.Unchecked_Conversion (Varray_bool_int,
|
||||
Varray_unsigned_int);
|
||||
|
||||
function To_Varray_unsigned_int is
|
||||
new Ada.Unchecked_Conversion (Varray_float,
|
||||
Varray_unsigned_int);
|
||||
|
||||
function To_Varray_signed_char is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_char,
|
||||
Varray_signed_char);
|
||||
|
||||
function To_Varray_bool_char is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_char,
|
||||
Varray_bool_char);
|
||||
|
||||
function To_Varray_signed_short is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_short,
|
||||
Varray_signed_short);
|
||||
|
||||
function To_Varray_bool_short is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_short,
|
||||
Varray_bool_short);
|
||||
|
||||
function To_Varray_pixel is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_short,
|
||||
Varray_pixel);
|
||||
|
||||
function To_Varray_signed_int is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_int,
|
||||
Varray_signed_int);
|
||||
|
||||
function To_Varray_bool_int is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_int,
|
||||
Varray_bool_int);
|
||||
|
||||
function To_Varray_float is
|
||||
new Ada.Unchecked_Conversion (Varray_unsigned_int,
|
||||
Varray_float);
|
||||
|
||||
function To_VUC is new Ada.Unchecked_Conversion (VUC_View, VUC);
|
||||
function To_VSC is new Ada.Unchecked_Conversion (VSC_View, VSC);
|
||||
function To_VBC is new Ada.Unchecked_Conversion (VBC_View, VBC);
|
||||
function To_VUS is new Ada.Unchecked_Conversion (VUS_View, VUS);
|
||||
function To_VSS is new Ada.Unchecked_Conversion (VSS_View, VSS);
|
||||
function To_VBS is new Ada.Unchecked_Conversion (VBS_View, VBS);
|
||||
function To_VUI is new Ada.Unchecked_Conversion (VUI_View, VUI);
|
||||
function To_VSI is new Ada.Unchecked_Conversion (VSI_View, VSI);
|
||||
function To_VBI is new Ada.Unchecked_Conversion (VBI_View, VBI);
|
||||
function To_VF is new Ada.Unchecked_Conversion (VF_View, VF);
|
||||
function To_VP is new Ada.Unchecked_Conversion (VP_View, VP);
|
||||
|
||||
function To_VUC_View is new Ada.Unchecked_Conversion (VUC, VUC_View);
|
||||
function To_VSC_View is new Ada.Unchecked_Conversion (VSC, VSC_View);
|
||||
function To_VBC_View is new Ada.Unchecked_Conversion (VBC, VBC_View);
|
||||
function To_VUS_View is new Ada.Unchecked_Conversion (VUS, VUS_View);
|
||||
function To_VSS_View is new Ada.Unchecked_Conversion (VSS, VSS_View);
|
||||
function To_VBS_View is new Ada.Unchecked_Conversion (VBS, VBS_View);
|
||||
function To_VUI_View is new Ada.Unchecked_Conversion (VUI, VUI_View);
|
||||
function To_VSI_View is new Ada.Unchecked_Conversion (VSI, VSI_View);
|
||||
function To_VBI_View is new Ada.Unchecked_Conversion (VBI, VBI_View);
|
||||
function To_VF_View is new Ada.Unchecked_Conversion (VF, VF_View);
|
||||
function To_VP_View is new Ada.Unchecked_Conversion (VP, VP_View);
|
||||
|
||||
pragma Warnings (Off, Default_Bit_Order);
|
||||
|
||||
---------------
|
||||
-- To_Vector --
|
||||
---------------
|
||||
|
||||
function To_Vector (S : VSC_View) return VSC is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VSC (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUC;
|
||||
VS : constant VUC_View :=
|
||||
(Values => To_Varray_unsigned_char (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return To_LL_VSC (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VBC_View) return VBC is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VBC (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUC;
|
||||
VS : constant VUC_View :=
|
||||
(Values => To_Varray_unsigned_char (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return To_LL_VBC (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VSS_View) return VSS is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VSS (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUS;
|
||||
VS : constant VUS_View :=
|
||||
(Values => To_Varray_unsigned_short (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return VSS (To_LL_VSS (Result));
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VBS_View) return VBS is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VBS (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUS;
|
||||
VS : constant VUS_View :=
|
||||
(Values => To_Varray_unsigned_short (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return To_LL_VBS (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VP_View) return VP is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VP (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUS;
|
||||
VS : constant VUS_View :=
|
||||
(Values => To_Varray_unsigned_short (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return To_LL_VP (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VSI_View) return VSI is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VSI (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUI;
|
||||
VS : constant VUI_View :=
|
||||
(Values => To_Varray_unsigned_int (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return To_LL_VSI (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VBI_View) return VBI is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VBI (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUI;
|
||||
VS : constant VUI_View :=
|
||||
(Values => To_Varray_unsigned_int (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return To_LL_VBI (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VF_View) return VF is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VF (S);
|
||||
else
|
||||
declare
|
||||
Result : LL_VUI;
|
||||
VS : constant VUI_View :=
|
||||
(Values => To_Varray_unsigned_int (S.Values));
|
||||
begin
|
||||
Result := To_Vector (VS);
|
||||
return To_LL_VF (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VUC_View) return VUC is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VUC (S);
|
||||
else
|
||||
declare
|
||||
Result : VUC_View;
|
||||
begin
|
||||
for J in Vchar_Range'Range loop
|
||||
Result.Values (J) :=
|
||||
S.Values (Vchar_Range'Last - J + Vchar_Range'First);
|
||||
end loop;
|
||||
return To_VUC (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VUS_View) return VUS is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VUS (S);
|
||||
else
|
||||
declare
|
||||
Result : VUS_View;
|
||||
begin
|
||||
for J in Vshort_Range'Range loop
|
||||
Result.Values (J) :=
|
||||
S.Values (Vshort_Range'Last - J + Vshort_Range'First);
|
||||
end loop;
|
||||
return To_VUS (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
function To_Vector (S : VUI_View) return VUI is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VUI (S);
|
||||
else
|
||||
declare
|
||||
Result : VUI_View;
|
||||
begin
|
||||
for J in Vint_Range'Range loop
|
||||
Result.Values (J) :=
|
||||
S.Values (Vint_Range'Last - J + Vint_Range'First);
|
||||
end loop;
|
||||
return To_VUI (Result);
|
||||
end;
|
||||
end if;
|
||||
end To_Vector;
|
||||
|
||||
--------------
|
||||
-- To_View --
|
||||
--------------
|
||||
|
||||
function To_View (S : VSC) return VSC_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VSC_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUC_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUC (S));
|
||||
return (Values => To_Varray_signed_char (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VBC) return VBC_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VBC_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUC_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUC (S));
|
||||
return (Values => To_Varray_bool_char (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VSS) return VSS_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VSS_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUS_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUS (S));
|
||||
return (Values => To_Varray_signed_short (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VBS) return VBS_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VBS_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUS_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUS (S));
|
||||
return (Values => To_Varray_bool_short (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VP) return VP_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VP_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUS_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUS (S));
|
||||
return (Values => To_Varray_pixel (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VSI) return VSI_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VSI_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUI_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUI (S));
|
||||
return (Values => To_Varray_signed_int (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VBI) return VBI_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VBI_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUI_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUI (S));
|
||||
return (Values => To_Varray_bool_int (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VF) return VF_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VF_View (S);
|
||||
else
|
||||
declare
|
||||
Result : VUI_View;
|
||||
begin
|
||||
Result := To_View (To_LL_VUI (S));
|
||||
return (Values => To_Varray_float (Result.Values));
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VUC) return VUC_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VUC_View (S);
|
||||
else
|
||||
declare
|
||||
VS : constant VUC_View := To_VUC_View (S);
|
||||
Result : VUC_View;
|
||||
begin
|
||||
for J in Vchar_Range'Range loop
|
||||
Result.Values (J) :=
|
||||
VS.Values (Vchar_Range'Last - J + Vchar_Range'First);
|
||||
end loop;
|
||||
return Result;
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VUS) return VUS_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VUS_View (S);
|
||||
else
|
||||
declare
|
||||
VS : constant VUS_View := To_VUS_View (S);
|
||||
Result : VUS_View;
|
||||
begin
|
||||
for J in Vshort_Range'Range loop
|
||||
Result.Values (J) :=
|
||||
VS.Values (Vshort_Range'Last - J + Vshort_Range'First);
|
||||
end loop;
|
||||
return Result;
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
function To_View (S : VUI) return VUI_View is
|
||||
begin
|
||||
if Default_Bit_Order = High_Order_First then
|
||||
return To_VUI_View (S);
|
||||
else
|
||||
declare
|
||||
VS : constant VUI_View := To_VUI_View (S);
|
||||
Result : VUI_View;
|
||||
begin
|
||||
for J in Vint_Range'Range loop
|
||||
Result.Values (J) :=
|
||||
VS.Values (Vint_Range'Last - J + Vint_Range'First);
|
||||
end loop;
|
||||
return Result;
|
||||
end;
|
||||
end if;
|
||||
end To_View;
|
||||
|
||||
end GNAT.Altivec.Conversions;
|
||||
103
gcc/ada/g-altcon.ads
Normal file
103
gcc/ada/g-altcon.ads
Normal file
|
|
@ -0,0 +1,103 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . A L T I V E C . C O N V E R S I O N S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2005, 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 2, 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. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This unit provides the Vector/Views conversions
|
||||
|
||||
with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types;
|
||||
with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views;
|
||||
|
||||
package GNAT.Altivec.Conversions is
|
||||
|
||||
---------------------
|
||||
-- char components --
|
||||
---------------------
|
||||
|
||||
function To_Vector (S : VUC_View) return VUC;
|
||||
function To_Vector (S : VSC_View) return VSC;
|
||||
function To_Vector (S : VBC_View) return VBC;
|
||||
|
||||
function To_View (S : VUC) return VUC_View;
|
||||
function To_View (S : VSC) return VSC_View;
|
||||
function To_View (S : VBC) return VBC_View;
|
||||
|
||||
----------------------
|
||||
-- short components --
|
||||
----------------------
|
||||
|
||||
function To_Vector (S : VUS_View) return VUS;
|
||||
function To_Vector (S : VSS_View) return VSS;
|
||||
function To_Vector (S : VBS_View) return VBS;
|
||||
|
||||
function To_View (S : VUS) return VUS_View;
|
||||
function To_View (S : VSS) return VSS_View;
|
||||
function To_View (S : VBS) return VBS_View;
|
||||
|
||||
--------------------
|
||||
-- int components --
|
||||
--------------------
|
||||
|
||||
function To_Vector (S : VUI_View) return VUI;
|
||||
function To_Vector (S : VSI_View) return VSI;
|
||||
function To_Vector (S : VBI_View) return VBI;
|
||||
|
||||
function To_View (S : VUI) return VUI_View;
|
||||
function To_View (S : VSI) return VSI_View;
|
||||
function To_View (S : VBI) return VBI_View;
|
||||
|
||||
----------------------
|
||||
-- float components --
|
||||
----------------------
|
||||
|
||||
function To_Vector (S : VF_View) return VF;
|
||||
|
||||
function To_View (S : VF) return VF_View;
|
||||
|
||||
----------------------
|
||||
-- pixel components --
|
||||
----------------------
|
||||
|
||||
function To_Vector (S : VP_View) return VP;
|
||||
|
||||
function To_View (S : VP) return VP_View;
|
||||
|
||||
private
|
||||
|
||||
-- We want the above subprograms to always be inlined in the case of the
|
||||
-- hard PowerPC AltiVec support in order to avoid the unnecessary function
|
||||
-- call. On the other hand there is no problem with inlining these
|
||||
-- subprograms on little-endian targets.
|
||||
|
||||
pragma Inline_Always (To_Vector);
|
||||
pragma Inline_Always (To_View);
|
||||
|
||||
end GNAT.Altivec.Conversions;
|
||||
455
gcc/ada/g-altive.ads
Normal file
455
gcc/ada/g-altive.ads
Normal file
|
|
@ -0,0 +1,455 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . A L T I V E C --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2005, 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 2, 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. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-------------------------
|
||||
-- General description --
|
||||
-------------------------
|
||||
|
||||
-- This is the root of a package hierarchy offering an Ada binding to the
|
||||
-- PowerPC AltiVec extensions. These extensions basically consist in a set of
|
||||
-- 128bit vector types together with a set of subprograms operating on such
|
||||
-- vectors. On a real Altivec capable target, vector objects map to hardware
|
||||
-- vector registers and the subprograms map to a set of specific hardware
|
||||
-- instructions.
|
||||
|
||||
-- Relevant documents are:
|
||||
|
||||
-- o AltiVec Technology, Programming Interface Manual (1999-06)
|
||||
-- to which we will refer as [PIM], describes the data types, the
|
||||
-- functional interface and the ABI conventions.
|
||||
|
||||
-- o AltiVec Technology, Programming Environments Manual (2002-02)
|
||||
-- to which we will refer as [PEM], describes the hardware architecture
|
||||
-- and instruction set.
|
||||
|
||||
-- These documents, as well as a number of others of general interest on the
|
||||
-- AltiVec technology, are available from the Motorola/AltiVec Web site at
|
||||
|
||||
-- http://www.motorola.com/altivec
|
||||
|
||||
-- We offer two versions of this binding: one for real AltiVec capable
|
||||
-- targets, and one for other targets. In the latter case, everything is
|
||||
-- emulated in software. We will refer to the two bindings as:
|
||||
|
||||
-- o The Hard binding for AltiVec capable targets (with the appropriate
|
||||
-- hardware support and corresponding instruction set)
|
||||
|
||||
-- o The Soft binding for other targets (with the low level primitives
|
||||
-- emulated in software).
|
||||
|
||||
-- The two versions of the binding are expected to be equivalent from the
|
||||
-- functional standpoint. The same client application code should observe no
|
||||
-- difference in operation results, even if the Soft version is used on a
|
||||
-- non-powerpc target. The Hard binding is naturally expected to run faster
|
||||
-- than the Soft version on the same target.
|
||||
|
||||
-- We also offer interfaces not strictly part of the base AltiVec API, such
|
||||
-- as vector conversions to/from array representations, which are of interest
|
||||
-- for client applications (e.g. for vector initialization purposes) and may
|
||||
-- also be used as implementation facilities.
|
||||
|
||||
-----------------------------------------
|
||||
-- General package architecture survey --
|
||||
-----------------------------------------
|
||||
|
||||
-- The various vector representations are all "containers" of elementary
|
||||
-- values, the possible types of which are declared in this root package to
|
||||
-- be generally accessible.
|
||||
|
||||
-- From the user standpoint, the two versions of the binding are available
|
||||
-- through a consistent hierarchy of units providing identical services:
|
||||
|
||||
-- GNAT.Altivec
|
||||
-- (component types)
|
||||
-- |
|
||||
-- o----------------o----------------o-------------o
|
||||
-- | | | |
|
||||
-- Vector_Types Vector_Operations Vector_Views Conversions
|
||||
|
||||
-- The user can manipulate vectors through two families of types: Vector
|
||||
-- types and View types.
|
||||
|
||||
-- Vector types are defined in the GNAT.Altivec.Vector_Types package
|
||||
|
||||
-- On these types, the user can apply the Altivec operations defined in
|
||||
-- GNAT.Altivec.Vector_Operations. Their layout is opaque and may vary across
|
||||
-- configurations, for it is typically target-endianness dependant.
|
||||
|
||||
-- Vector_Types and Vector_Operations implement the core binding to the
|
||||
-- AltiVec API, as described in [PIM-2.1 data types] and [PIM-4 AltiVec
|
||||
-- operations and predicates].
|
||||
|
||||
-- View types are defined in the GNAT.Altivec.Vector_Views package
|
||||
|
||||
-- These types do not represent Altivec vectors per se, in the sense that the
|
||||
-- Altivec_Operations are not available for them. They are intended to allow
|
||||
-- Vector initializations as well as access to the Vector component values.
|
||||
|
||||
-- The GNAT.Altivec.Conversions package is provided to convert a View to the
|
||||
-- corresponding Vector and vice-versa.
|
||||
|
||||
-- The two versions of the binding rely on a low level internal interface,
|
||||
-- and switching from one version to the other amounts to select one low
|
||||
-- level implementation instead of the other.
|
||||
|
||||
-- The bindings are provided as a set of sources together with a project file
|
||||
-- (altivec.gpr). The hard/soft binding selection is controlled by a project
|
||||
-- variable on targets where switching makes sense. See the example usage
|
||||
-- section below.
|
||||
|
||||
---------------------------
|
||||
-- Underlying principles --
|
||||
---------------------------
|
||||
|
||||
-- The general organization sketched above has been devised from a number
|
||||
-- of driving ideas:
|
||||
|
||||
-- o From the clients standpoint, the two versions of the binding should be
|
||||
-- as easily exchangable as possible,
|
||||
|
||||
-- o From the maintenance standpoint, we want to avoid as much code
|
||||
-- duplication as possible.
|
||||
|
||||
-- o From both standpoints above, we want to maintain a clear interface
|
||||
-- separation between the base bindings to the Motorola API and the
|
||||
-- additional facilities.
|
||||
|
||||
-- The identification of the low level interface is directly inspired by the
|
||||
-- the base API organization, basically consisting of a rich set of functions
|
||||
-- around a core of low level primitives mapping to AltiVec instructions.
|
||||
|
||||
-- See for instance "vec_add" in [PIM-4.4 Generic and Specific AltiVec
|
||||
-- operations]: no less than six result/arguments combinations of byte vector
|
||||
-- types map to "vaddubm".
|
||||
|
||||
-- The "hard" version of the low level primitives map to real AltiVec
|
||||
-- instructions via the corresponding GCC builtins. The "soft" version is
|
||||
-- a software emulation of those.
|
||||
|
||||
-------------------
|
||||
-- Example usage --
|
||||
-------------------
|
||||
|
||||
-- Here is a sample program declaring and initializing two vectors, 'add'ing
|
||||
-- them and displaying the result components:
|
||||
|
||||
-- with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types;
|
||||
-- with GNAT.Altivec.Vector_Operations; use GNAT.Altivec.Vector_Operations;
|
||||
-- with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views;
|
||||
-- with GNAT.Altivec.Conversions; use GNAT.Altivec.Conversions;
|
||||
|
||||
-- use GNAT.Altivec;
|
||||
|
||||
-- procedure Sample is
|
||||
-- Va : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4)));
|
||||
-- Vb : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4)));
|
||||
|
||||
-- Vs : Vector_Unsigned_Int;
|
||||
-- Vs_View : VUI_View;
|
||||
-- begin
|
||||
-- Vs := Vec_Add (Va, Vb);
|
||||
-- Vs_View := To_View (Vs);
|
||||
|
||||
-- for I in Vs_View.Values'Range loop
|
||||
-- Put_Line (Unsigned_Int'Image (Vs_View.Values (I)));
|
||||
-- end loop;
|
||||
-- end;
|
||||
|
||||
-- This currently requires the GNAT project management facilities to compile,
|
||||
-- to automatically retrieve the set of necessary sources and switches
|
||||
-- depending on your configuration. For the example above, customizing the
|
||||
-- switches to include -g also, this would be something like:
|
||||
|
||||
-- sample.gpr
|
||||
--
|
||||
-- with "altivec.gpr";
|
||||
--
|
||||
-- project Sample is
|
||||
|
||||
-- for Source_Dirs use (".");
|
||||
-- for Main use ("sample");
|
||||
|
||||
-- package Compiler is
|
||||
-- for Default_Switches ("Ada") use
|
||||
-- Altivec.Compiler'Default_Switches ("Ada") & "-g";
|
||||
-- end Compiler;
|
||||
|
||||
-- end Sample;
|
||||
|
||||
-- $ gnatmake -Psample
|
||||
-- [...]
|
||||
-- $ ./sample
|
||||
-- 2
|
||||
-- 4
|
||||
-- 6
|
||||
-- 8
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with System;
|
||||
|
||||
package GNAT.Altivec is
|
||||
|
||||
-- Definitions of constants and vector/array component types common to all
|
||||
-- the versions of the binding.
|
||||
|
||||
-- All the vector types are 128bits
|
||||
|
||||
VECTOR_BIT : constant := 128;
|
||||
|
||||
-------------------------------------------
|
||||
-- [PIM-2.3.1 Alignment of vector types] --
|
||||
-------------------------------------------
|
||||
|
||||
-- "A defined data item of any vector data type in memory is always
|
||||
-- aligned on a 16-byte boundary. A pointer to any vector data type always
|
||||
-- points to a 16-byte boundary. The compiler is responsible for aligning
|
||||
-- vector data types on 16-byte boundaries."
|
||||
|
||||
VECTOR_ALIGNMENT : constant := 16;
|
||||
|
||||
-------------------------------------------------------
|
||||
-- [PIM-2.1] Data Types - Interpretation of contents --
|
||||
-------------------------------------------------------
|
||||
|
||||
---------------------
|
||||
-- char components --
|
||||
---------------------
|
||||
|
||||
CHAR_BIT : constant := 8;
|
||||
SCHAR_MIN : constant := -2 ** (CHAR_BIT - 1);
|
||||
SCHAR_MAX : constant := 2 ** (CHAR_BIT - 1) - 1;
|
||||
UCHAR_MAX : constant := 2 ** CHAR_BIT - 1;
|
||||
|
||||
type unsigned_char is mod UCHAR_MAX + 1;
|
||||
for unsigned_char'Size use CHAR_BIT;
|
||||
|
||||
type signed_char is range SCHAR_MIN .. SCHAR_MAX;
|
||||
for signed_char'Size use CHAR_BIT;
|
||||
|
||||
subtype bool_char is unsigned_char;
|
||||
-- ??? There is a difference here between what the Altivec Technology
|
||||
-- Programming Interface Manual says and what GCC says. In the manual,
|
||||
-- vector_bool_char is a vector_unsigned_char, while in altivec.h it
|
||||
-- is a vector_signed_char.
|
||||
|
||||
bool_char_True : constant bool_char := bool_char'Last;
|
||||
bool_char_False : constant bool_char := 0;
|
||||
|
||||
----------------------
|
||||
-- short components --
|
||||
----------------------
|
||||
|
||||
SHORT_BIT : constant := 16;
|
||||
SSHORT_MIN : constant := -2 ** (SHORT_BIT - 1);
|
||||
SSHORT_MAX : constant := 2 ** (SHORT_BIT - 1) - 1;
|
||||
USHORT_MAX : constant := 2 ** SHORT_BIT - 1;
|
||||
|
||||
type unsigned_short is mod USHORT_MAX + 1;
|
||||
for unsigned_short'Size use SHORT_BIT;
|
||||
|
||||
subtype unsigned_short_int is unsigned_short;
|
||||
|
||||
type signed_short is range SSHORT_MIN .. SSHORT_MAX;
|
||||
for signed_short'Size use SHORT_BIT;
|
||||
|
||||
subtype signed_short_int is signed_short;
|
||||
|
||||
subtype bool_short is unsigned_short;
|
||||
-- ??? See bool_char
|
||||
|
||||
bool_short_True : constant bool_short := bool_short'Last;
|
||||
bool_short_False : constant bool_short := 0;
|
||||
|
||||
subtype bool_short_int is bool_short;
|
||||
|
||||
--------------------
|
||||
-- int components --
|
||||
--------------------
|
||||
|
||||
INT_BIT : constant := 32;
|
||||
SINT_MIN : constant := -2 ** (INT_BIT - 1);
|
||||
SINT_MAX : constant := 2 ** (INT_BIT - 1) - 1;
|
||||
UINT_MAX : constant := 2 ** INT_BIT - 1;
|
||||
|
||||
type unsigned_int is mod UINT_MAX + 1;
|
||||
for unsigned_int'Size use INT_BIT;
|
||||
|
||||
type signed_int is range SINT_MIN .. SINT_MAX;
|
||||
for signed_int'Size use INT_BIT;
|
||||
|
||||
subtype bool_int is unsigned_int;
|
||||
-- ??? See bool_char
|
||||
|
||||
bool_int_True : constant bool_int := bool_int'Last;
|
||||
bool_int_False : constant bool_int := 0;
|
||||
|
||||
----------------------
|
||||
-- float components --
|
||||
----------------------
|
||||
|
||||
FLOAT_BIT : constant := 32;
|
||||
FLOAT_DIGIT : constant := 6;
|
||||
FLOAT_MIN : constant := -16#0.FFFF_FF#E+32;
|
||||
FLOAT_MAX : constant := 16#0.FFFF_FF#E+32;
|
||||
|
||||
type C_float is digits FLOAT_DIGIT range FLOAT_MIN .. FLOAT_MAX;
|
||||
for C_float'Size use FLOAT_BIT;
|
||||
|
||||
----------------------
|
||||
-- pixel components --
|
||||
----------------------
|
||||
|
||||
subtype pixel is unsigned_short;
|
||||
|
||||
-----------------------------------------------------------
|
||||
-- Subtypes for variants found in the GCC implementation --
|
||||
-----------------------------------------------------------
|
||||
|
||||
subtype c_int is signed_int;
|
||||
subtype c_short is c_int;
|
||||
|
||||
LONG_BIT : constant := 32;
|
||||
-- Some of the GCC builtins are built with "long" arguments and
|
||||
-- expect SImode to come in.
|
||||
|
||||
SLONG_MIN : constant := -2 ** (LONG_BIT - 1);
|
||||
SLONG_MAX : constant := 2 ** (LONG_BIT - 1) - 1;
|
||||
ULONG_MAX : constant := 2 ** LONG_BIT - 1;
|
||||
|
||||
type signed_long is range SLONG_MIN .. SLONG_MAX;
|
||||
type unsigned_long is mod ULONG_MAX + 1;
|
||||
|
||||
subtype c_long is signed_long;
|
||||
|
||||
subtype c_ptr is System.Address;
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Access types, for the sake of some argument passing --
|
||||
---------------------------------------------------------
|
||||
|
||||
type signed_char_ptr is access all signed_char;
|
||||
type unsigned_char_ptr is access all unsigned_char;
|
||||
|
||||
type short_ptr is access all c_short;
|
||||
type signed_short_ptr is access all signed_short;
|
||||
type unsigned_short_ptr is access all unsigned_short;
|
||||
|
||||
type int_ptr is access all c_int;
|
||||
type signed_int_ptr is access all signed_int;
|
||||
type unsigned_int_ptr is access all unsigned_int;
|
||||
|
||||
type long_ptr is access all c_long;
|
||||
type signed_long_ptr is access all signed_long;
|
||||
type unsigned_long_ptr is access all unsigned_long;
|
||||
|
||||
type float_ptr is access all Float;
|
||||
|
||||
--
|
||||
|
||||
type const_signed_char_ptr is access constant signed_char;
|
||||
type const_unsigned_char_ptr is access constant unsigned_char;
|
||||
|
||||
type const_short_ptr is access constant c_short;
|
||||
type const_signed_short_ptr is access constant signed_short;
|
||||
type const_unsigned_short_ptr is access constant unsigned_short;
|
||||
|
||||
type const_int_ptr is access constant c_int;
|
||||
type const_signed_int_ptr is access constant signed_int;
|
||||
type const_unsigned_int_ptr is access constant unsigned_int;
|
||||
|
||||
type const_long_ptr is access constant c_long;
|
||||
type const_signed_long_ptr is access constant signed_long;
|
||||
type const_unsigned_long_ptr is access constant unsigned_long;
|
||||
|
||||
type const_float_ptr is access constant Float;
|
||||
|
||||
-- Access to const volatile arguments need specialized types
|
||||
|
||||
type volatile_float is new Float;
|
||||
pragma Volatile (volatile_float);
|
||||
|
||||
type volatile_signed_char is new signed_char;
|
||||
pragma Volatile (volatile_signed_char);
|
||||
|
||||
type volatile_unsigned_char is new unsigned_char;
|
||||
pragma Volatile (volatile_unsigned_char);
|
||||
|
||||
type volatile_signed_short is new signed_short;
|
||||
pragma Volatile (volatile_signed_short);
|
||||
|
||||
type volatile_unsigned_short is new unsigned_short;
|
||||
pragma Volatile (volatile_unsigned_short);
|
||||
|
||||
type volatile_signed_int is new signed_int;
|
||||
pragma Volatile (volatile_signed_int);
|
||||
|
||||
type volatile_unsigned_int is new unsigned_int;
|
||||
pragma Volatile (volatile_unsigned_int);
|
||||
|
||||
type volatile_signed_long is new signed_long;
|
||||
pragma Volatile (volatile_signed_long);
|
||||
|
||||
type volatile_unsigned_long is new unsigned_long;
|
||||
pragma Volatile (volatile_unsigned_long);
|
||||
|
||||
type constv_char_ptr is access constant volatile_signed_char;
|
||||
type constv_signed_char_ptr is access constant volatile_signed_char;
|
||||
type constv_unsigned_char_ptr is access constant volatile_unsigned_char;
|
||||
|
||||
type constv_short_ptr is access constant volatile_signed_short;
|
||||
type constv_signed_short_ptr is access constant volatile_signed_short;
|
||||
type constv_unsigned_short_ptr is access constant volatile_unsigned_short;
|
||||
|
||||
type constv_int_ptr is access constant volatile_signed_int;
|
||||
type constv_signed_int_ptr is access constant volatile_signed_int;
|
||||
type constv_unsigned_int_ptr is access constant volatile_unsigned_int;
|
||||
|
||||
type constv_long_ptr is access constant volatile_signed_long;
|
||||
type constv_signed_long_ptr is access constant volatile_signed_long;
|
||||
type constv_unsigned_long_ptr is access constant volatile_unsigned_long;
|
||||
|
||||
type constv_float_ptr is access constant volatile_float;
|
||||
|
||||
private
|
||||
|
||||
-----------------------
|
||||
-- Various constants --
|
||||
-----------------------
|
||||
|
||||
CR6_EQ : constant := 0;
|
||||
CR6_EQ_REV : constant := 1;
|
||||
CR6_LT : constant := 2;
|
||||
CR6_LT_REV : constant := 3;
|
||||
|
||||
end GNAT.Altivec;
|
||||
9704
gcc/ada/g-alveop.adb
Normal file
9704
gcc/ada/g-alveop.adb
Normal file
File diff suppressed because it is too large
Load diff
8105
gcc/ada/g-alveop.ads
Normal file
8105
gcc/ada/g-alveop.ads
Normal file
File diff suppressed because it is too large
Load diff
152
gcc/ada/g-alvety.ads
Normal file
152
gcc/ada/g-alvety.ads
Normal file
|
|
@ -0,0 +1,152 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . A L T I V E C . V E C T O R _ T Y P E S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2005, 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 2, 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. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This unit exposes the various vector types part of the Ada binding to
|
||||
-- Altivec facilities.
|
||||
|
||||
with GNAT.Altivec.Low_Level_Vectors;
|
||||
|
||||
package GNAT.Altivec.Vector_Types is
|
||||
|
||||
use GNAT.Altivec.Low_Level_Vectors;
|
||||
|
||||
---------------------------------------------------
|
||||
-- Vector type declarations [PIM-2.1 Data Types] --
|
||||
---------------------------------------------------
|
||||
|
||||
-- Except for assignments and pointer creation/dereference, operations
|
||||
-- on vectors are only performed via subprograms. The vector types are
|
||||
-- then private, and non-limited since assignments are allowed.
|
||||
|
||||
-- The Hard/Soft binding type-structure differentiation is achieved in
|
||||
-- Low_Level_Vectors. Each version only exposes private vector types, that
|
||||
-- we just sub-type here. This is fine from the design standpoint and
|
||||
-- reduces the amount of explicit conversion required in various places
|
||||
-- internally.
|
||||
|
||||
subtype vector_unsigned_char is Low_Level_Vectors.LL_VUC;
|
||||
subtype vector_signed_char is Low_Level_Vectors.LL_VSC;
|
||||
subtype vector_bool_char is Low_Level_Vectors.LL_VBC;
|
||||
|
||||
subtype vector_unsigned_short is Low_Level_Vectors.LL_VUS;
|
||||
subtype vector_signed_short is Low_Level_Vectors.LL_VSS;
|
||||
subtype vector_bool_short is Low_Level_Vectors.LL_VBS;
|
||||
|
||||
subtype vector_unsigned_int is Low_Level_Vectors.LL_VUI;
|
||||
subtype vector_signed_int is Low_Level_Vectors.LL_VSI;
|
||||
subtype vector_bool_int is Low_Level_Vectors.LL_VBI;
|
||||
|
||||
subtype vector_float is Low_Level_Vectors.LL_VF;
|
||||
subtype vector_pixel is Low_Level_Vectors.LL_VP;
|
||||
|
||||
-- [PIM-2.1] shows groups of declarations with exact same component types,
|
||||
-- e.g. vector unsigned short together with vector unsigned short int. It
|
||||
-- so appears tempting to define subtypes for those matches here.
|
||||
--
|
||||
-- [PIM-2.1] does not qualify items in those groups as "the same types",
|
||||
-- though, and [PIM-2.4.2 Assignments] reads: "if either the left hand
|
||||
-- side or the right hand side of an expression has a vector type, then
|
||||
-- both sides of the expression must be of the same vector type".
|
||||
--
|
||||
-- Not so clear what is exactly right, then. We go with subtypes for now
|
||||
-- and can adjust later if need be.
|
||||
|
||||
subtype vector_unsigned_short_int is vector_unsigned_short;
|
||||
subtype vector_signed_short_int is vector_signed_short;
|
||||
|
||||
subtype vector_char is vector_signed_char;
|
||||
subtype vector_short is vector_signed_short;
|
||||
subtype vector_int is vector_signed_int;
|
||||
|
||||
--------------------------------
|
||||
-- Corresponding access types --
|
||||
--------------------------------
|
||||
|
||||
type vector_unsigned_char_ptr is access all vector_unsigned_char;
|
||||
type vector_signed_char_ptr is access all vector_signed_char;
|
||||
type vector_bool_char_ptr is access all vector_bool_char;
|
||||
|
||||
type vector_unsigned_short_ptr is access all vector_unsigned_short;
|
||||
type vector_signed_short_ptr is access all vector_signed_short;
|
||||
type vector_bool_short_ptr is access all vector_bool_short;
|
||||
|
||||
type vector_unsigned_int_ptr is access all vector_unsigned_int;
|
||||
type vector_signed_int_ptr is access all vector_signed_int;
|
||||
type vector_bool_int_ptr is access all vector_bool_int;
|
||||
|
||||
type vector_float_ptr is access all vector_float;
|
||||
type vector_pixel_ptr is access all vector_pixel;
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- Additional access types, for the sake of some argument passing --
|
||||
--------------------------------------------------------------------
|
||||
|
||||
-- ... because some of the operations expect pointers to possibly
|
||||
-- constant objects.
|
||||
|
||||
type const_vector_bool_char_ptr is access constant vector_bool_char;
|
||||
type const_vector_signed_char_ptr is access constant vector_signed_char;
|
||||
type const_vector_unsigned_char_ptr is access constant vector_unsigned_char;
|
||||
|
||||
type const_vector_bool_short_ptr is access constant vector_bool_short;
|
||||
type const_vector_signed_short_ptr is access constant vector_signed_short;
|
||||
type const_vector_unsigned_short_ptr is access
|
||||
constant vector_unsigned_short;
|
||||
|
||||
type const_vector_bool_int_ptr is access constant vector_bool_int;
|
||||
type const_vector_signed_int_ptr is access constant vector_signed_int;
|
||||
type const_vector_unsigned_int_ptr is access constant vector_unsigned_int;
|
||||
|
||||
type const_vector_float_ptr is access constant vector_float;
|
||||
type const_vector_pixel_ptr is access constant vector_pixel;
|
||||
|
||||
----------------------
|
||||
-- Useful shortcuts --
|
||||
----------------------
|
||||
|
||||
subtype VUC is vector_unsigned_char;
|
||||
subtype VSC is vector_signed_char;
|
||||
subtype VBC is vector_bool_char;
|
||||
|
||||
subtype VUS is vector_unsigned_short;
|
||||
subtype VSS is vector_signed_short;
|
||||
subtype VBS is vector_bool_short;
|
||||
|
||||
subtype VUI is vector_unsigned_int;
|
||||
subtype VSI is vector_signed_int;
|
||||
subtype VBI is vector_bool_int;
|
||||
|
||||
subtype VP is vector_pixel;
|
||||
subtype VF is vector_float;
|
||||
|
||||
end GNAT.Altivec.Vector_Types;
|
||||
158
gcc/ada/g-alvevi.ads
Normal file
158
gcc/ada/g-alvevi.ads
Normal file
|
|
@ -0,0 +1,158 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- G N A T . A L T I V E C . V E C T O R _ V I E W S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2005, 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 2, 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. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This unit provides public 'View' data types from/to which private vector
|
||||
-- representations can be converted via Altivec.Conversions. This allows
|
||||
-- convenient access to individual vector elements and provides a simple way
|
||||
-- to initialize vector objects.
|
||||
|
||||
-- Accessing vector contents with direct memory overlays should be avoided
|
||||
-- because actual vector representations may vary across configurations, for
|
||||
-- instance to accomodate different target endianness.
|
||||
|
||||
-- The natural representation of a vector is an array indexed by vector
|
||||
-- component number, which is materialized by the Varray type definitions
|
||||
-- below. The 16byte alignment constraint is unfortunately sometimes not
|
||||
-- properly honored for constant array aggregates, so the View types are
|
||||
-- actually records enclosing such arrays.
|
||||
|
||||
package GNAT.Altivec.Vector_Views is
|
||||
|
||||
---------------------
|
||||
-- char components --
|
||||
---------------------
|
||||
|
||||
type Vchar_Range is range 1 .. 16;
|
||||
|
||||
type Varray_unsigned_char is array (Vchar_Range) of unsigned_char;
|
||||
for Varray_unsigned_char'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VUC_View is record
|
||||
Values : Varray_unsigned_char;
|
||||
end record;
|
||||
|
||||
type Varray_signed_char is array (Vchar_Range) of signed_char;
|
||||
for Varray_signed_char'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VSC_View is record
|
||||
Values : Varray_signed_char;
|
||||
end record;
|
||||
|
||||
type Varray_bool_char is array (Vchar_Range) of bool_char;
|
||||
for Varray_bool_char'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VBC_View is record
|
||||
Values : Varray_bool_char;
|
||||
end record;
|
||||
|
||||
----------------------
|
||||
-- short components --
|
||||
----------------------
|
||||
|
||||
type Vshort_Range is range 1 .. 8;
|
||||
|
||||
type Varray_unsigned_short is array (Vshort_Range) of unsigned_short;
|
||||
for Varray_unsigned_short'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VUS_View is record
|
||||
Values : Varray_unsigned_short;
|
||||
end record;
|
||||
|
||||
type Varray_signed_short is array (Vshort_Range) of signed_short;
|
||||
for Varray_signed_short'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VSS_View is record
|
||||
Values : Varray_signed_short;
|
||||
end record;
|
||||
|
||||
type Varray_bool_short is array (Vshort_Range) of bool_short;
|
||||
for Varray_bool_short'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VBS_View is record
|
||||
Values : Varray_bool_short;
|
||||
end record;
|
||||
|
||||
--------------------
|
||||
-- int components --
|
||||
--------------------
|
||||
|
||||
type Vint_Range is range 1 .. 4;
|
||||
|
||||
type Varray_unsigned_int is array (Vint_Range) of unsigned_int;
|
||||
for Varray_unsigned_int'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VUI_View is record
|
||||
Values : Varray_unsigned_int;
|
||||
end record;
|
||||
|
||||
type Varray_signed_int is array (Vint_Range) of signed_int;
|
||||
for Varray_signed_int'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VSI_View is record
|
||||
Values : Varray_signed_int;
|
||||
end record;
|
||||
|
||||
type Varray_bool_int is array (Vint_Range) of bool_int;
|
||||
for Varray_bool_int'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VBI_View is record
|
||||
Values : Varray_bool_int;
|
||||
end record;
|
||||
|
||||
----------------------
|
||||
-- float components --
|
||||
----------------------
|
||||
|
||||
type Vfloat_Range is range 1 .. 4;
|
||||
|
||||
type Varray_float is array (Vfloat_Range) of C_float;
|
||||
for Varray_float'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VF_View is record
|
||||
Values : Varray_float;
|
||||
end record;
|
||||
|
||||
----------------------
|
||||
-- pixel components --
|
||||
----------------------
|
||||
|
||||
type Vpixel_Range is range 1 .. 8;
|
||||
|
||||
type Varray_pixel is array (Vpixel_Range) of pixel;
|
||||
for Varray_pixel'Alignment use VECTOR_ALIGNMENT;
|
||||
|
||||
type VP_View is record
|
||||
Values : Varray_pixel;
|
||||
end record;
|
||||
|
||||
end GNAT.Altivec.Vector_Views;
|
||||
|
|
@ -195,6 +195,11 @@ package body Impunit is
|
|||
-- GNAT Library Units --
|
||||
------------------------
|
||||
|
||||
"g-altive", -- GNAT.Altivec
|
||||
"g-alvety", -- GNAT.Altivec.Vector_Types
|
||||
"g-alvevi", -- GNAT.Altivec.Vector_Views
|
||||
"g-alveop", -- GNAT.Altivec.Vector_Operations
|
||||
"g-altcon", -- GNAT.Altivec.Conversions
|
||||
"g-arrspl", -- GNAT.Array_Split
|
||||
"g-awk ", -- GNAT.AWK
|
||||
"g-boubuf", -- GNAT.Bounded_Buffers
|
||||
|
|
@ -359,12 +364,13 @@ package body Impunit is
|
|||
"a-stzmap", -- Ada.Strings.Wide_Wide_Maps
|
||||
"a-stzunb", -- Ada.Strings.Wide_Wide_Unbounded
|
||||
"a-swuwha", -- Ada.Strings.Wide_Unbounded.Wide_Hash
|
||||
"a-szmzco", -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants;
|
||||
"a-szmzco", -- Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants
|
||||
"a-szuzha", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash
|
||||
"a-tgdico", -- Ada.Tags.Generic_Dispatching_Constructor;
|
||||
"a-tiunio", -- Ada.Text_IO.Unbounded_IO;
|
||||
"a-taster", -- Ada.Task_Termination
|
||||
"a-tgdico", -- Ada.Tags.Generic_Dispatching_Constructor
|
||||
"a-tiunio", -- Ada.Text_IO.Unbounded_IO
|
||||
"a-wichun", -- Ada.Wide_Characters.Unicode
|
||||
"a-wwunio", -- Ada.Wide_Text_IO.Wide_Unbounded_IO;
|
||||
"a-wwunio", -- Ada.Wide_Text_IO.Wide_Unbounded_IO
|
||||
"a-zchara", -- Ada.Wide_Wide_Characters
|
||||
"a-zttest", -- Ada.Wide_Wide_Text_IO.Text_Streams
|
||||
"a-ztexio", -- Ada.Wide_Wide_Text_IO
|
||||
|
|
|
|||
|
|
@ -344,6 +344,17 @@ package Opt is
|
|||
-- Set True for dynamic elaboration checking mode, as set by the -gnatE
|
||||
-- switch or by the use of pragma Elaboration_Checks (Dynamic).
|
||||
|
||||
Dynamic_Stack_Measurement : Boolean := False;
|
||||
-- GNATBIND
|
||||
-- Set True to enable dynamic stack measurement (-u flag for gnatbind)
|
||||
|
||||
Dynamic_Stack_Measurement_Array_Size : Nat := 100;
|
||||
-- GNATBIND
|
||||
-- Number of measurements we want to store during dynamic stack analysis.
|
||||
-- When the buffer is full, non-storable results will be output on the fly.
|
||||
-- The value is relevant only if Dynamic_Stack_Measurement is set. Set
|
||||
-- by processing of -u flag for gnatbind.
|
||||
|
||||
Elab_Dependency_Output : Boolean := False;
|
||||
-- GNATBIND
|
||||
-- Set to True to output complete list of elaboration constraints
|
||||
|
|
@ -687,15 +698,6 @@ package Opt is
|
|||
-- extension, as set by the appropriate switch. If no switch is given,
|
||||
-- then this value is initialized by Osint to the appropriate value.
|
||||
|
||||
Max_Line_Length : Int := Hostparm.Max_Line_Length;
|
||||
-- This is a copy of Max_Line_Length used by the scanner. It is usually
|
||||
-- set to be a copy of Hostparm.Max_Line_Length, and is used to check
|
||||
-- the maximum line length in the scanner when style checking is inactive.
|
||||
-- The only time it is set to a different value is during the scanning of
|
||||
-- configuration pragma files, where we want to turn off all checking and
|
||||
-- in particular we want to allow long lines. So we reset this value to
|
||||
-- Column_Number'Last during scanning of configuration pragma files.
|
||||
|
||||
Maximum_Processes : Positive := 1;
|
||||
-- GNATMAKE, GPRMAKE
|
||||
-- Maximum number of processes that should be spawned to carry out
|
||||
|
|
|
|||
|
|
@ -594,6 +594,6 @@ package body System.Finalization_Implementation is
|
|||
-- Initialization of package, set Adafinal soft link
|
||||
|
||||
begin
|
||||
SSL.Adafinal := Finalize_Global_List'Access;
|
||||
SSL.Finalize_Global_List := Finalize_Global_List'Access;
|
||||
|
||||
end System.Finalization_Implementation;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2005, 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- --
|
||||
|
|
@ -33,6 +33,10 @@
|
|||
|
||||
package body System.IO is
|
||||
|
||||
Current_Out : File_Type := Stdout;
|
||||
pragma Atomic (Current_Out);
|
||||
-- Current output file (modified by Set_Output)
|
||||
|
||||
--------------
|
||||
-- New_Line --
|
||||
--------------
|
||||
|
|
@ -49,21 +53,35 @@ package body System.IO is
|
|||
---------
|
||||
|
||||
procedure Put (X : Integer) is
|
||||
|
||||
procedure Put_Int (X : Integer);
|
||||
pragma Import (C, Put_Int, "put_int");
|
||||
|
||||
procedure Put_Int_Err (X : Integer);
|
||||
pragma Import (C, Put_Int_Err, "put_int_stderr");
|
||||
|
||||
begin
|
||||
Put_Int (X);
|
||||
case Current_Out is
|
||||
when Stdout =>
|
||||
Put_Int (X);
|
||||
when Stderr =>
|
||||
Put_Int_Err (X);
|
||||
end case;
|
||||
end Put;
|
||||
|
||||
procedure Put (C : Character) is
|
||||
|
||||
procedure Put_Char (C : Character);
|
||||
pragma Import (C, Put_Char, "put_char");
|
||||
|
||||
procedure Put_Char_Stderr (C : Character);
|
||||
pragma Import (C, Put_Char_Stderr, "put_char_stderr");
|
||||
|
||||
begin
|
||||
Put_Char (C);
|
||||
case Current_Out is
|
||||
when Stdout =>
|
||||
Put_Char (C);
|
||||
when Stderr =>
|
||||
Put_Char_Stderr (C);
|
||||
end case;
|
||||
end Put;
|
||||
|
||||
procedure Put (S : String) is
|
||||
|
|
@ -83,4 +101,31 @@ package body System.IO is
|
|||
New_Line;
|
||||
end Put_Line;
|
||||
|
||||
---------------------
|
||||
-- Standard_Output --
|
||||
---------------------
|
||||
|
||||
function Standard_Output return File_Type is
|
||||
begin
|
||||
return Stdout;
|
||||
end Standard_Output;
|
||||
|
||||
--------------------
|
||||
-- Standard_Error --
|
||||
--------------------
|
||||
|
||||
function Standard_Error return File_Type is
|
||||
begin
|
||||
return Stderr;
|
||||
end Standard_Error;
|
||||
|
||||
----------------
|
||||
-- Set_Output --
|
||||
----------------
|
||||
|
||||
procedure Set_Output (File : in File_Type) is
|
||||
begin
|
||||
Current_Out := File;
|
||||
end Set_Output;
|
||||
|
||||
end System.IO;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2005, 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- --
|
||||
|
|
@ -48,4 +48,19 @@ package System.IO is
|
|||
|
||||
procedure New_Line (Spacing : Positive := 1);
|
||||
|
||||
type File_Type is limited private;
|
||||
|
||||
function Standard_Error return File_Type;
|
||||
function Standard_Output return File_Type;
|
||||
|
||||
procedure Set_Output (File : in File_Type);
|
||||
|
||||
private
|
||||
|
||||
type File_Type is (Stdout, Stderr);
|
||||
-- Stdout = Standard_Output, Stderr = Standard_Error
|
||||
|
||||
pragma Inline (Standard_Error);
|
||||
pragma Inline (Standard_Output);
|
||||
|
||||
end System.IO;
|
||||
|
|
|
|||
|
|
@ -83,6 +83,25 @@ package body System.Soft_Links is
|
|||
null;
|
||||
end Abort_Undefer_NT;
|
||||
|
||||
-----------------
|
||||
-- Adafinal_NT --
|
||||
-----------------
|
||||
|
||||
procedure Adafinal_NT is
|
||||
begin
|
||||
-- Handle normal task termination by the environment task, but only
|
||||
-- for the normal task termination. In the case of Abnormal and
|
||||
-- Unhandled_Exception they must have been handled before, and the
|
||||
-- task termination soft link must have been changed so the task
|
||||
-- termination routine is not executed twice.
|
||||
|
||||
Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
|
||||
|
||||
-- Finalize the global list for controlled objects if needed
|
||||
|
||||
Finalize_Global_List.all;
|
||||
end Adafinal_NT;
|
||||
|
||||
---------------------------
|
||||
-- Check_Abort_Status_NT --
|
||||
---------------------------
|
||||
|
|
@ -226,14 +245,14 @@ package body System.Soft_Links is
|
|||
return NT_TSD.Pri_Stack_Info'Access;
|
||||
end Get_Stack_Info_NT;
|
||||
|
||||
-------------------
|
||||
-- Null_Adafinal --
|
||||
-------------------
|
||||
-------------------------------
|
||||
-- Null_Finalize_Global_List --
|
||||
-------------------------------
|
||||
|
||||
procedure Null_Adafinal is
|
||||
procedure Null_Finalize_Global_List is
|
||||
begin
|
||||
null;
|
||||
end Null_Adafinal;
|
||||
end Null_Finalize_Global_List;
|
||||
|
||||
---------------------------
|
||||
-- Set_Jmpbuf_Address_NT --
|
||||
|
|
@ -285,6 +304,16 @@ package body System.Soft_Links is
|
|||
null;
|
||||
end Task_Unlock_NT;
|
||||
|
||||
-------------------------
|
||||
-- Task_Termination_NT --
|
||||
-------------------------
|
||||
|
||||
procedure Task_Termination_NT (Excep : EO) is
|
||||
pragma Warnings (Off, Excep);
|
||||
begin
|
||||
null;
|
||||
end Task_Termination_NT;
|
||||
|
||||
-------------------------
|
||||
-- Update_Exception_NT --
|
||||
-------------------------
|
||||
|
|
|
|||
|
|
@ -62,6 +62,7 @@ package System.Soft_Links is
|
|||
|
||||
type No_Param_Proc is access procedure;
|
||||
type Addr_Param_Proc is access procedure (Addr : Address);
|
||||
type EO_Param_Proc is access procedure (Excep : EO);
|
||||
|
||||
type Get_Address_Call is access function return Address;
|
||||
type Set_Address_Call is access procedure (Addr : Address);
|
||||
|
|
@ -92,6 +93,7 @@ package System.Soft_Links is
|
|||
|
||||
pragma Suppress (Access_Check, No_Param_Proc);
|
||||
pragma Suppress (Access_Check, Addr_Param_Proc);
|
||||
pragma Suppress (Access_Check, EO_Param_Proc);
|
||||
pragma Suppress (Access_Check, Get_Address_Call);
|
||||
pragma Suppress (Access_Check, Set_Address_Call);
|
||||
pragma Suppress (Access_Check, Set_Address_Call2);
|
||||
|
|
@ -139,9 +141,15 @@ package System.Soft_Links is
|
|||
procedure Task_Unlock_NT;
|
||||
-- Release lock set by Task_Lock (non-tasking case, does nothing)
|
||||
|
||||
procedure Null_Adafinal;
|
||||
-- Shuts down the runtime system (non-tasking no-finalization case,
|
||||
-- does nothing)
|
||||
procedure Task_Termination_NT (Excep : EO);
|
||||
-- Handle task termination routines for the environment task (non-tasking
|
||||
-- case, does nothing).
|
||||
|
||||
procedure Null_Finalize_Global_List;
|
||||
-- Finalize global list for controlled objects (does nothing)
|
||||
|
||||
procedure Adafinal_NT;
|
||||
-- Shuts down the runtime system (non-tasking case)
|
||||
|
||||
Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
|
||||
pragma Suppress (Access_Check, Abort_Defer);
|
||||
|
|
@ -197,7 +205,13 @@ package System.Soft_Links is
|
|||
-- This ensures that the lock is not left set if an exception is raised
|
||||
-- explicitly or implicitly during the critical locked region.
|
||||
|
||||
Adafinal : No_Param_Proc := Null_Adafinal'Access;
|
||||
Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
|
||||
-- Handle task termination routines (task/non-task case as appropriate)
|
||||
|
||||
Finalize_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access;
|
||||
-- Performs finalization of global list for controlled objects
|
||||
|
||||
Adafinal : No_Param_Proc := Adafinal_NT'Access;
|
||||
-- Performs the finalization of the Ada Runtime
|
||||
|
||||
function Get_Jmpbuf_Address_NT return Address;
|
||||
|
|
|
|||
|
|
@ -46,12 +46,25 @@ with System.Task_Primitives.Operations;
|
|||
|
||||
with System.Tasking;
|
||||
-- Used for Task_Id
|
||||
-- Cause_Of_Termination
|
||||
|
||||
with Ada.Exceptions;
|
||||
-- Used for Exception_Id
|
||||
-- Exception_Occurrence
|
||||
-- Save_Occurrence
|
||||
|
||||
with Ada.Exceptions.Is_Null_Occurrence;
|
||||
|
||||
package body System.Soft_Links.Tasking is
|
||||
|
||||
package STPO renames System.Task_Primitives.Operations;
|
||||
package SSL renames System.Soft_Links;
|
||||
|
||||
use Ada.Exceptions;
|
||||
|
||||
use type System.Tasking.Task_Id;
|
||||
use type System.Tasking.Termination_Handler;
|
||||
|
||||
----------------
|
||||
-- Local Data --
|
||||
----------------
|
||||
|
|
@ -78,6 +91,9 @@ package body System.Soft_Links.Tasking is
|
|||
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
|
||||
-- Task-safe version of SSL.Timed_Delay
|
||||
|
||||
procedure Task_Termination_Handler_T (Excep : SSL.EO);
|
||||
-- Task-safe version of the task termination procedure
|
||||
|
||||
--------------------------
|
||||
-- Soft-Link Get Bodies --
|
||||
--------------------------
|
||||
|
|
@ -134,6 +150,48 @@ package body System.Soft_Links.Tasking is
|
|||
end if;
|
||||
end Timed_Delay_T;
|
||||
|
||||
--------------------------------
|
||||
-- Task_Termination_Handler_T --
|
||||
--------------------------------
|
||||
|
||||
procedure Task_Termination_Handler_T (Excep : SSL.EO) is
|
||||
Self_Id : constant System.Tasking.Task_Id := STPO.Self;
|
||||
Cause : System.Tasking.Cause_Of_Termination;
|
||||
EO : Ada.Exceptions.Exception_Occurrence;
|
||||
|
||||
begin
|
||||
-- We can only be here because we are terminating the environment task.
|
||||
-- Task termination for the rest of the tasks is handled in the
|
||||
-- Task_Wrapper.
|
||||
|
||||
pragma Assert (Self_Id = STPO.Environment_Task);
|
||||
|
||||
-- Normal task termination
|
||||
|
||||
if Is_Null_Occurrence (Excep) then
|
||||
Cause := System.Tasking.Normal;
|
||||
Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
|
||||
|
||||
-- Abnormal task termination
|
||||
|
||||
elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then
|
||||
Cause := System.Tasking.Abnormal;
|
||||
Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
|
||||
|
||||
-- Termination because of an unhandled exception
|
||||
|
||||
else
|
||||
Cause := System.Tasking.Unhandled_Exception;
|
||||
Ada.Exceptions.Save_Occurrence (EO, Excep);
|
||||
end if;
|
||||
|
||||
if Self_Id.Common.Specific_Handler /= null then
|
||||
Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
|
||||
elsif Self_Id.Common.Fall_Back_Handler /= null then
|
||||
Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO);
|
||||
end if;
|
||||
end Task_Termination_Handler_T;
|
||||
|
||||
-----------------------------
|
||||
-- Init_Tasking_Soft_Links --
|
||||
-----------------------------
|
||||
|
|
@ -151,12 +209,13 @@ package body System.Soft_Links.Tasking is
|
|||
-- The application being executed uses tasking so that the tasking
|
||||
-- version of the following soft links need to be used.
|
||||
|
||||
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
|
||||
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
|
||||
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
|
||||
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
|
||||
SSL.Get_Current_Excep := Get_Current_Excep'Access;
|
||||
SSL.Timed_Delay := Timed_Delay_T'Access;
|
||||
SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
|
||||
SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
|
||||
SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
|
||||
SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
|
||||
SSL.Get_Current_Excep := Get_Current_Excep'Access;
|
||||
SSL.Timed_Delay := Timed_Delay_T'Access;
|
||||
SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access;
|
||||
|
||||
-- No need to create a new Secondary Stack, since we will use the
|
||||
-- default one created in s-secsta.adb
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ with System.Storage_Elements;
|
|||
with System.Address_To_Access_Conversions;
|
||||
|
||||
package System.Stack_Usage is
|
||||
pragma Preelaborate;
|
||||
|
||||
package SSE renames System.Storage_Elements;
|
||||
|
||||
|
|
@ -46,46 +47,43 @@ package System.Stack_Usage is
|
|||
for Word_32'Alignment use 4;
|
||||
|
||||
subtype Stack_Address is SSE.Integer_Address;
|
||||
-- Address on the stack.
|
||||
-- Address on the stack
|
||||
--
|
||||
-- NOTE:
|
||||
-- *****
|
||||
--
|
||||
-- in this package, when comparing two addresses on the
|
||||
-- stack, the comments use the terms "outer", "inner", "outermost"
|
||||
-- and "innermost" instead of the ambigous "higher", "lower",
|
||||
-- "highest" and "lowest". "inner" means "closer to the bottom of
|
||||
-- stack" and is the contrary of "outer". "innermost" means "closest
|
||||
-- address to the bottom of stack". The stack is growing from the
|
||||
-- innermost addresses to the outermost addresses.
|
||||
-- Note: in this package, when comparing two addresses on the stack, the
|
||||
-- comments use the terms "outer", "inner", "outermost" and "innermost"
|
||||
-- instead of the ambigous "higher", "lower", "highest" and "lowest".
|
||||
-- "inner" means "closer to the bottom of stack" and is the contrary of
|
||||
-- "outer". "innermost" means "closest address to the bottom of stack". The
|
||||
-- stack is growing from the inner to the outer.
|
||||
|
||||
function To_Stack_Address (Value : Address) return Stack_Address
|
||||
renames System.Storage_Elements.To_Integer;
|
||||
-- Top/Bottom would be much better than inner and outer ???
|
||||
|
||||
function To_Stack_Address (Value : System.Address) return Stack_Address
|
||||
renames System.Storage_Elements.To_Integer;
|
||||
|
||||
type Stack_Analyzer is private;
|
||||
-- Type of the stack analyzer tool. It is used to fill a portion of
|
||||
-- the stack with Pattern, and to compute the stack used after some
|
||||
-- execution.
|
||||
--
|
||||
-- USAGE:
|
||||
-- ******
|
||||
--
|
||||
-- -- A typical use of the package is something like:
|
||||
--
|
||||
|
||||
-- Usage:
|
||||
|
||||
-- A typical use of the package is something like:
|
||||
|
||||
-- A : Stack_Analyzer;
|
||||
--
|
||||
|
||||
-- task T is
|
||||
-- pragma Storage_Size (A_Storage_Size);
|
||||
-- end T;
|
||||
--
|
||||
|
||||
-- [...]
|
||||
--
|
||||
|
||||
-- Bottom_Of_Stack : aliased Integer;
|
||||
-- -- Bottom_Of_Stack'Address will be used as an approximation of
|
||||
-- -- the bottom of stack. A good practise is to avoid allocating
|
||||
-- -- other local variables on this stack, as it would degrade
|
||||
-- -- the quality of this approximation.
|
||||
--
|
||||
|
||||
-- begin
|
||||
-- Initialize_Analyzer (A,
|
||||
-- "Task t",
|
||||
|
|
@ -96,92 +94,112 @@ package System.Stack_Usage is
|
|||
-- Compute_Result (A);
|
||||
-- Report_Result (A);
|
||||
-- end T;
|
||||
--
|
||||
--
|
||||
|
||||
-- Errors:
|
||||
-- *******
|
||||
--
|
||||
-- We are instrumenting the code to measure the stack used by the user
|
||||
-- code. This method has a number of systematic errors, but several
|
||||
-- methods can be used to evaluate or reduce those errors. Here are
|
||||
-- those errors and the strategy that we use to deal with them:
|
||||
--
|
||||
-- * Bottom offset:
|
||||
-- - Description: The procedure used to fill the stack with a given
|
||||
-- pattern will itself have a stack frame. The value of the stack pointer
|
||||
-- in this procedure is, therefore, different from the value before the
|
||||
-- call to the instrumentation procedure.
|
||||
-- - Strategy: The user of this package shall measure the bottom of stack
|
||||
-- before the call to Fill_Stack and pass it in parameter.
|
||||
--
|
||||
-- * Instrumentation threshold at writing:
|
||||
-- - Description: The procedure used to fill the stack with a given
|
||||
-- pattern will itself have a stack frame. Therefore, it will
|
||||
-- fill the stack after this stack frame. This part of the stack will
|
||||
-- appear as used in the final measure.
|
||||
-- - Strategy: As the user pass the value of the bottom of stack to
|
||||
-- the instrumentation to deal with the bottom offset error, and as
|
||||
-- as the instrumentation procedure knows where the pattern filling
|
||||
-- start on the stack, the difference between the two values is the
|
||||
-- minimum stack usage that the method can measure. If, when the results
|
||||
-- are computed, the pattern zone has been left untouched, we conclude
|
||||
-- that the stack usage is inferior to this minimum stack usage.
|
||||
--
|
||||
-- * Instrumentation threshold at reading:
|
||||
-- - Description: The procedure used to read the stack at the end of the
|
||||
-- execution clobbers the stack by allocating its stack frame. If this
|
||||
-- stack frame is bigger than the total stack used by the user code at
|
||||
-- this point, it will increase the measured stack size.
|
||||
-- - Strategy: We could augment this stack frame and see if it changes the
|
||||
-- measure. However, this error should be negligeable.
|
||||
--
|
||||
-- * Pattern zone overflow:
|
||||
-- - Description: The stack grows outer than the outermost bound of the
|
||||
-- pattern zone. In that case, the outermost region modified in the
|
||||
-- pattern is not the maximum value of the stack pointer during the
|
||||
-- execution.
|
||||
-- - Strategy: At the end of the execution, the difference between the
|
||||
-- outermost memory region modified in the pattern zone and the
|
||||
-- outermost bound of the pattern zone can be understood as the
|
||||
-- biggest allocation that the method could have detect, provided
|
||||
-- that there is no "Untouched allocated zone" error and no "Pattern
|
||||
-- usage in user code" error. If no object in the user code is likely
|
||||
-- to have this size, this is not likely to happen.
|
||||
--
|
||||
-- * Pattern usage in user code:
|
||||
-- - Description: The pattern can be found in the object of the user
|
||||
-- code. Therefore, the address space where this object has been
|
||||
-- allocated will appear as untouched.
|
||||
-- - Strategy: Choose a pattern that is uncommon. 16#0000_0000# is the
|
||||
-- worst choice; 16#DEAD_BEEF# can be a good one. A good choice is an
|
||||
-- address which is not a multiple of 2, and which is not in the
|
||||
-- target address space. You can also change the pattern to see if
|
||||
-- it changes the measure. Note that this error *very* rarely influence
|
||||
-- the measure of the total stack usage: to have some influence, the
|
||||
-- pattern has to be used in the object that has been allocated on the
|
||||
-- outermost address of the used stack.
|
||||
--
|
||||
-- * Stack overflow:
|
||||
-- - Description: The pattern zone does not fit on the stack.
|
||||
-- This may lead to an erroneous execution.
|
||||
-- - Strategy: Specify a storage size that is bigger than the
|
||||
-- size of the pattern. 2 times bigger should be enough.
|
||||
--
|
||||
-- * Augmentation of the user stack frames:
|
||||
-- - Description: The use of instrumentation object or procedure may
|
||||
-- augment the stack frame of the caller.
|
||||
-- - Strategy: Do *not* inline the instrumentation procedures. Do *not*
|
||||
-- allocate the Stack_Analyzer object on the stack.
|
||||
--
|
||||
-- * Untouched allocated zone:
|
||||
-- - Description: The user code may allocate objects that it will never
|
||||
-- touch. In that case, the pattern will not be changed.
|
||||
-- - Strategy: There are no way to detect this error. Fortunately, this
|
||||
-- error is really rare, and it is most probably a bug in the user code,
|
||||
-- e.g. some uninitialized variable. It is (most of the time) harmless:
|
||||
-- it influences the measure only if the untouched allocated zone
|
||||
-- happens to be located at the outermost value of the stack pointer
|
||||
-- for the whole execution.
|
||||
|
||||
-- Bottom offset:
|
||||
|
||||
-- Description: The procedure used to fill the stack with a given
|
||||
-- pattern will itself have a stack frame. The value of the stack
|
||||
-- pointer in this procedure is, therefore, different from the value
|
||||
-- before the call to the instrumentation procedure.
|
||||
|
||||
-- Strategy: The user of this package should measure the bottom of stack
|
||||
-- before the call to Fill_Stack and pass it in parameter.
|
||||
|
||||
-- Instrumentation threshold at writing:
|
||||
|
||||
-- Description: The procedure used to fill the stack with a given
|
||||
-- pattern will itself have a stack frame. Therefore, it will
|
||||
-- fill the stack after this stack frame. This part of the stack will
|
||||
-- appear as used in the final measure.
|
||||
|
||||
-- Strategy: As the user passes the value of the bottom of stack to
|
||||
-- the instrumentation to deal with the bottom offset error, and as as
|
||||
-- the instrumentation procedure knows where the pattern filling start
|
||||
-- on the stack, the difference between the two values is the minimum
|
||||
-- stack usage that the method can measure. If, when the results are
|
||||
-- computed, the pattern zone has been left untouched, we conclude
|
||||
-- that the stack usage is inferior to this minimum stack usage.
|
||||
|
||||
-- Instrumentation threshold at reading:
|
||||
|
||||
-- Description: The procedure used to read the stack at the end of the
|
||||
-- execution clobbers the stack by allocating its stack frame. If this
|
||||
-- stack frame is bigger than the total stack used by the user code at
|
||||
-- this point, it will increase the measured stack size.
|
||||
|
||||
-- Strategy: We could augment this stack frame and see if it changes the
|
||||
-- measure. However, this error should be negligeable.
|
||||
|
||||
-- Pattern zone overflow:
|
||||
|
||||
-- Description: The stack grows outer than the outermost bound of the
|
||||
-- pattern zone. In that case, the outermost region modified in the
|
||||
-- pattern is not the maximum value of the stack pointer during the
|
||||
-- execution.
|
||||
|
||||
-- Strategy: At the end of the execution, the difference between the
|
||||
-- outermost memory region modified in the pattern zone and the
|
||||
-- outermost bound of the pattern zone can be understood as the
|
||||
-- biggest allocation that the method could have detect, provided
|
||||
-- that there is no "Untouched allocated zone" error and no "Pattern
|
||||
-- usage in user code" error. If no object in the user code is likely
|
||||
-- to have this size, this is not likely to happen.
|
||||
|
||||
-- Pattern usage in user code:
|
||||
|
||||
-- Description: The pattern can be found in the object of the user code.
|
||||
-- Therefore, the address space where this object has been allocated
|
||||
-- will appear as untouched.
|
||||
|
||||
-- Strategy: Choose a pattern that is uncommon. 16#0000_0000# is the
|
||||
-- worst choice; 16#DEAD_BEEF# can be a good one. A good choice is an
|
||||
-- address which is not a multiple of 2, and which is not in the
|
||||
-- target address space. You can also change the pattern to see if it
|
||||
-- changes the measure. Note that this error *very* rarely influence
|
||||
-- the measure of the total stack usage: to have some influence, the
|
||||
-- pattern has to be used in the object that has been allocated on the
|
||||
-- outermost address of the used stack.
|
||||
|
||||
-- Stack overflow:
|
||||
|
||||
-- Description: The pattern zone does not fit on the stack. This may
|
||||
-- lead to an erroneous execution.
|
||||
|
||||
-- Strategy: Specify a storage size that is bigger than the size of the
|
||||
-- pattern. 2 times bigger should be enough.
|
||||
|
||||
-- Augmentation of the user stack frames:
|
||||
|
||||
-- Description: The use of instrumentation object or procedure may
|
||||
-- augment the stack frame of the caller.
|
||||
|
||||
-- Strategy: Do *not* inline the instrumentation procedures. Do *not*
|
||||
-- allocate the Stack_Analyzer object on the stack.
|
||||
|
||||
-- Untouched allocated zone:
|
||||
|
||||
-- Description: The user code may allocate objects that it will never
|
||||
-- touch. In that case, the pattern will not be changed.
|
||||
|
||||
-- Strategy: There are no way to detect this error. Fortunately, this
|
||||
-- error is really rare, and it is most probably a bug in the user
|
||||
-- code, e.g. some uninitialized variable. It is (most of the time)
|
||||
-- harmless: it influences the measure only if the untouched allocated
|
||||
-- zone happens to be located at the outermost value of the stack
|
||||
-- pointer for the whole execution.
|
||||
|
||||
procedure Initialize (Buffer_Size : Natural);
|
||||
pragma Export (C, Initialize, "__gnat_stack_usage_initialize");
|
||||
-- Initializes the size of the buffer that stores the results. Only the
|
||||
-- first Buffer_Size results are stored. Any results that do not fit in
|
||||
-- this buffer will be displayed on the fly.
|
||||
|
||||
procedure Fill_Stack (Analyzer : in out Stack_Analyzer);
|
||||
-- Fill an area of the stack with the pattern Analyzer.Pattern. The size
|
||||
|
|
@ -200,13 +218,26 @@ package System.Stack_Usage is
|
|||
-- Analyzer.Inner_Pattern_Mark ^
|
||||
-- Analyzer.Outer_Pattern_Mark
|
||||
|
||||
procedure Initialize_Analyzer
|
||||
(Analyzer : in out Stack_Analyzer;
|
||||
Task_Name : String;
|
||||
Size : Natural;
|
||||
Bottom : Stack_Address;
|
||||
Pattern : Word_32 := 16#DEAD_BEEF#);
|
||||
-- Should be called before any use of a Stack_Analyzer, to initialize it.
|
||||
-- Size is the size of the pattern zone. Bottom should be a close
|
||||
-- approximation of the caller base frame address.
|
||||
|
||||
Is_Enabled : Boolean := False;
|
||||
-- When this flag is true, then stack analysis is enabled
|
||||
|
||||
procedure Compute_Result (Analyzer : in out Stack_Analyzer);
|
||||
-- Read the patern zone and deduce the stack usage. It should
|
||||
-- be called from the same frame as Fill_Stack. If Analyzer.Probe is not
|
||||
-- null, an array of Word_32 with Analyzer.Probe elements is allocated on
|
||||
-- Compute_Result's stack frame. Probe can be used to detect an
|
||||
-- "instrumentation threshold at reading" error; See above.
|
||||
-- After the call to this procedure, the memory will look like:
|
||||
-- Read the patern zone and deduce the stack usage. It should be called
|
||||
-- from the same frame as Fill_Stack. If Analyzer.Probe is not null, an
|
||||
-- array of Word_32 with Analyzer.Probe elements is allocated on
|
||||
-- Compute_Result's stack frame. Probe can be used to detect the error:
|
||||
-- "instrumentation threshold at reading". See above. After the call
|
||||
-- to this procedure, the memory will look like:
|
||||
--
|
||||
-- Stack growing
|
||||
-- ----------------------------------------------------------------------->
|
||||
|
|
@ -224,45 +255,38 @@ package System.Stack_Usage is
|
|||
|
||||
procedure Report_Result (Analyzer : Stack_Analyzer);
|
||||
-- Store the results of the computation in memory, at the address
|
||||
-- corresponding to the symbol __gnat_stack_usage_results.
|
||||
|
||||
type Parameterless_Procedure is access procedure;
|
||||
|
||||
procedure Initialize_Analyzer
|
||||
(Analyzer : in out Stack_Analyzer;
|
||||
Task_Name : String;
|
||||
Size : Natural;
|
||||
Bottom : Stack_Address;
|
||||
Pattern : Word_32 := 16#DEAD_BEEF#);
|
||||
-- Should be called before any use of a Stack_Analyzer, to initialize it.
|
||||
-- Size is the size of the pattern zone.
|
||||
-- Bottom should be a close approximation of the caller base
|
||||
-- frame address.
|
||||
-- corresponding to the symbol __gnat_stack_usage_results. This is not
|
||||
-- done inside Compute_Resuls in order to use as less stack as possible
|
||||
-- within a task.
|
||||
|
||||
procedure Output_Results;
|
||||
-- Print the results computed so far on the standard output. Should be
|
||||
-- called when all tasks are dead.
|
||||
|
||||
pragma Export (C, Output_Results, "__gnat_stack_usage_output_results");
|
||||
|
||||
private
|
||||
|
||||
Task_Name_Length : constant := 32;
|
||||
|
||||
package Word_32_Addr is
|
||||
new System.Address_To_Access_Conversions (Word_32);
|
||||
new System.Address_To_Access_Conversions (Word_32);
|
||||
|
||||
type Result_Array_Id is range 0 .. 1_023;
|
||||
type Stack_Analyzer is record
|
||||
Task_Name : String (1 .. Task_Name_Length);
|
||||
-- Name of the task
|
||||
|
||||
type Stack_Analyzer
|
||||
is record
|
||||
Size : Natural;
|
||||
-- Size of the pattern zone.
|
||||
Size : Natural;
|
||||
-- Size of the pattern zone
|
||||
|
||||
Pattern : Word_32 := 16#DEAD_BEEF#;
|
||||
-- Pattern used to recognize untouched memory.
|
||||
Pattern : Word_32;
|
||||
-- Pattern used to recognize untouched memory
|
||||
|
||||
Inner_Pattern_Mark : Stack_Address;
|
||||
-- Innermost bound of the pattern area on the stack.
|
||||
Inner_Pattern_Mark : Stack_Address;
|
||||
-- Innermost bound of the pattern area on the stack
|
||||
|
||||
Outer_Pattern_Mark : Stack_Address;
|
||||
-- Outermost bound of the pattern area on the stack.
|
||||
Outer_Pattern_Mark : Stack_Address;
|
||||
-- Outermost bound of the pattern area on the stack
|
||||
|
||||
Outermost_Touched_Mark : Stack_Address;
|
||||
-- Outermost address of the pattern area whose value it is pointing
|
||||
|
|
@ -270,20 +294,50 @@ private
|
|||
-- compensated, it is the outermost value of the stack pointer during
|
||||
-- the execution.
|
||||
|
||||
Bottom_Of_Stack : Stack_Address;
|
||||
Bottom_Of_Stack : Stack_Address;
|
||||
-- Address of the bottom of the stack, as given by the caller of
|
||||
-- Initialize_Analyzer.
|
||||
|
||||
Array_Address : Address;
|
||||
-- Address of the array of Word_32 that represents the pattern zone.
|
||||
Array_Address : System.Address;
|
||||
-- Address of the array of Word_32 that represents the pattern zone
|
||||
|
||||
First_Is_Outermost : Boolean;
|
||||
First_Is_Outermost : Boolean;
|
||||
-- Set to true if the first element of the array of Word_32 that
|
||||
-- represents the pattern zone is at the outermost address of the
|
||||
-- pattern zone; false if it is the innermost address.
|
||||
|
||||
Result_Id : Result_Array_Id;
|
||||
-- Location in the result array of the result for the current task.
|
||||
Result_Id : Positive;
|
||||
-- Id of the result. If less than value given to gnatbind -u corresponds
|
||||
-- to the location in the result array of result for the current task.
|
||||
end record;
|
||||
|
||||
Environment_Task_Analyzer : Stack_Analyzer;
|
||||
|
||||
Compute_Environment_Task : Boolean;
|
||||
|
||||
type Task_Result is record
|
||||
Task_Name : String (1 .. Task_Name_Length);
|
||||
Measure : Natural;
|
||||
Max_Size : Natural;
|
||||
end record;
|
||||
|
||||
type Result_Array_Type is array (Positive range <>) of Task_Result;
|
||||
type Result_Array_Ptr is access all Result_Array_Type;
|
||||
|
||||
Result_Array : Result_Array_Ptr;
|
||||
pragma Export (C, Result_Array, "__gnat_stack_usage_results");
|
||||
-- Exported in order to have an easy accessible symbol in when debugging
|
||||
|
||||
Next_Id : Positive := 1;
|
||||
-- Id of the next stack analyzer
|
||||
|
||||
function Stack_Size
|
||||
(SP_Low : Stack_Address;
|
||||
SP_High : Stack_Address) return Natural;
|
||||
pragma Inline (Stack_Size);
|
||||
-- Return the size of a portion of stack delimeted by SP_High and SP_Low
|
||||
-- (), i.e. the difference between SP_High and SP_Low. The storage element
|
||||
-- pointed by SP_Low is not included in the size. Inlined to reduce the
|
||||
-- size of the stack used by the instrumentation code.
|
||||
|
||||
end System.Stack_Usage;
|
||||
|
|
|
|||
|
|
@ -45,6 +45,9 @@ pragma Polling (Off);
|
|||
-- Turn off polling, we do not want ATC polling to take place during
|
||||
-- tasking operations. It causes infinite loops and other problems.
|
||||
|
||||
with Ada.Exceptions;
|
||||
-- used for Exception_Occurrence
|
||||
|
||||
with System.Parameters;
|
||||
-- used for Size_Type
|
||||
-- Single_Lock
|
||||
|
|
@ -83,6 +86,8 @@ package body System.Tasking.Restricted.Stages is
|
|||
package SSE renames System.Storage_Elements;
|
||||
package SST renames System.Secondary_Stack;
|
||||
|
||||
use Ada.Exceptions;
|
||||
|
||||
use Parameters;
|
||||
use Task_Primitives.Operations;
|
||||
use Task_Info;
|
||||
|
|
@ -133,8 +138,15 @@ package body System.Tasking.Restricted.Stages is
|
|||
---------------
|
||||
|
||||
procedure Task_Lock is
|
||||
Self_ID : constant Task_Id := STPO.Self;
|
||||
|
||||
begin
|
||||
STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
|
||||
Self_ID.Common.Global_Task_Lock_Nesting :=
|
||||
Self_ID.Common.Global_Task_Lock_Nesting + 1;
|
||||
|
||||
if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
|
||||
STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
|
||||
end if;
|
||||
end Task_Lock;
|
||||
|
||||
-----------------
|
||||
|
|
@ -142,8 +154,16 @@ package body System.Tasking.Restricted.Stages is
|
|||
-----------------
|
||||
|
||||
procedure Task_Unlock is
|
||||
Self_ID : constant Task_Id := STPO.Self;
|
||||
|
||||
begin
|
||||
STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
|
||||
pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0);
|
||||
Self_ID.Common.Global_Task_Lock_Nesting :=
|
||||
Self_ID.Common.Global_Task_Lock_Nesting - 1;
|
||||
|
||||
if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
|
||||
STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
|
||||
end if;
|
||||
end Task_Unlock;
|
||||
|
||||
------------------
|
||||
|
|
@ -162,21 +182,40 @@ package body System.Tasking.Restricted.Stages is
|
|||
procedure Task_Wrapper (Self_ID : Task_Id) is
|
||||
ID : Task_Id := Self_ID;
|
||||
pragma Volatile (ID);
|
||||
|
||||
pragma Warnings (Off, ID);
|
||||
-- Turn off warnings (stand alone volatile constant has to be
|
||||
-- imported, so we cannot just make ID constant).
|
||||
|
||||
-- Do not delete this variable.
|
||||
-- In some targets, we need this variable to implement a fast Self.
|
||||
-- Variable used on some targets to implement a fast self. We turn off
|
||||
-- warnings because a stand alone volatile constant has to be imported,
|
||||
-- so we don't want warnings about ID not being referenced, and volatile
|
||||
-- having no effect.
|
||||
--
|
||||
-- DO NOT delete ID. As noted, it is needed on some targets.
|
||||
|
||||
use type System.Parameters.Size_Type;
|
||||
use type SSE.Storage_Offset;
|
||||
|
||||
Secondary_Stack : aliased SSE.Storage_Array
|
||||
(1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
|
||||
SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
|
||||
SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
|
||||
|
||||
pragma Warnings (Off);
|
||||
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
|
||||
pragma Warnings (On);
|
||||
-- Address of secondary stack. In the fixed secondary stack case, this
|
||||
-- value is not modified, causing a warning, hence the bracketing with
|
||||
-- Warnings (Off/On).
|
||||
|
||||
Cause : Cause_Of_Termination := Normal;
|
||||
-- Indicates the reason why this task terminates. Normal corresponds to
|
||||
-- a task terminating due to completing the last statement of its body.
|
||||
-- If the task terminates because of an exception raised by the
|
||||
-- execution of its task body, then Cause is set to Unhandled_Exception.
|
||||
-- Aborts are not allowed in the restriced profile to which this file
|
||||
-- belongs.
|
||||
|
||||
EO : Exception_Occurrence;
|
||||
-- If the task terminates because of an exception raised by the
|
||||
-- execution of its task body, then EO will contain the associated
|
||||
-- exception occurrence. Otherwise, it will contain Null_Occurrence.
|
||||
|
||||
begin
|
||||
if not Parameters.Sec_Stack_Dynamic then
|
||||
|
|
@ -190,25 +229,53 @@ package body System.Tasking.Restricted.Stages is
|
|||
|
||||
Enter_Task (Self_ID);
|
||||
|
||||
-- Call the task body procedure.
|
||||
-- Call the task body procedure
|
||||
|
||||
begin
|
||||
-- We are separating the following portion of the code in order to
|
||||
-- place the exception handlers in a different block.
|
||||
-- In this way we do not call Set_Jmpbuf_Address (which needs
|
||||
-- Self) before we set Self in Enter_Task.
|
||||
-- place the exception handlers in a different block. In this way we
|
||||
-- do not call Set_Jmpbuf_Address (which needs Self) before we set
|
||||
-- Self in Enter_Task.
|
||||
|
||||
-- Note that in the case of Ravenscar HI-E where there are no
|
||||
-- exception handlers, the exception handler is suppressed.
|
||||
|
||||
-- Call the task body procedure.
|
||||
-- Call the task body procedure
|
||||
|
||||
Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
|
||||
Terminate_Task (Self_ID);
|
||||
|
||||
-- Normal task termination
|
||||
|
||||
Cause := Normal;
|
||||
Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
|
||||
|
||||
exception
|
||||
when others =>
|
||||
Terminate_Task (Self_ID);
|
||||
when E : others =>
|
||||
|
||||
-- Task terminating because of an unhandled exception
|
||||
|
||||
Cause := Unhandled_Exception;
|
||||
Save_Occurrence (EO, E);
|
||||
end;
|
||||
|
||||
-- Look for a fall-back handler. It can be either in the task itself
|
||||
-- or in the environment task. Note that this code is always executed
|
||||
-- by a task whose master is the environment task. The task termination
|
||||
-- code for the environment task is executed by
|
||||
-- SSL.Task_Termination_Handler.
|
||||
|
||||
-- This package is part of the restricted run time which supports
|
||||
-- neither task hierarchies (No_Task_Hierarchy) nor specific task
|
||||
-- termination handlers (No_Specific_Termination_Handlers).
|
||||
|
||||
if Self_ID.Common.Fall_Back_Handler /= null then
|
||||
Self_ID.Common.Fall_Back_Handler.all (Cause, Self_ID, EO);
|
||||
elsif Self_ID.Common.Parent.Common.Fall_Back_Handler /= null then
|
||||
Self_ID.Common.Parent.Common.Fall_Back_Handler.all
|
||||
(Cause, Self_ID, EO);
|
||||
end if;
|
||||
|
||||
Terminate_Task (Self_ID);
|
||||
end Task_Wrapper;
|
||||
|
||||
-----------------------
|
||||
|
|
@ -219,11 +286,11 @@ package body System.Tasking.Restricted.Stages is
|
|||
-- Activate_Restricted_Tasks --
|
||||
-------------------------------
|
||||
|
||||
-- Note that locks of activator and activated task are both locked
|
||||
-- here. This is necessary because C.State and Self.Wait_Count
|
||||
-- have to be synchronized. This is safe from deadlock because
|
||||
-- the activator is always created before the activated task.
|
||||
-- That satisfies our in-order-of-creation ATCB locking policy.
|
||||
-- Note that locks of activator and activated task are both locked here.
|
||||
-- This is necessary because C.State and Self.Wait_Count have to be
|
||||
-- synchronized. This is safe from deadlock because the activator is always
|
||||
-- created before the activated task. That satisfies our
|
||||
-- in-order-of-creation ATCB locking policy.
|
||||
|
||||
procedure Activate_Restricted_Tasks
|
||||
(Chain_Access : Activation_Chain_Access)
|
||||
|
|
@ -241,14 +308,13 @@ package body System.Tasking.Restricted.Stages is
|
|||
Lock_RTS;
|
||||
end if;
|
||||
|
||||
-- Lock self, to prevent activated tasks
|
||||
-- from racing ahead before we finish activating the chain.
|
||||
-- Lock self, to prevent activated tasks from racing ahead before we
|
||||
-- finish activating the chain.
|
||||
|
||||
Write_Lock (Self_ID);
|
||||
|
||||
-- Activate all the tasks in the chain.
|
||||
-- Creation of the thread of control was deferred until
|
||||
-- activation. So create it now.
|
||||
-- Activate all the tasks in the chain. Creation of the thread of
|
||||
-- control was deferred until activation. So create it now.
|
||||
|
||||
C := Chain_Access.T_ID;
|
||||
|
||||
|
|
@ -286,9 +352,8 @@ package body System.Tasking.Restricted.Stages is
|
|||
|
||||
Self_ID.Common.State := Activator_Sleep;
|
||||
|
||||
-- Wait for the activated tasks to complete activation.
|
||||
-- It is unsafe to abort any of these tasks until the count goes to
|
||||
-- zero.
|
||||
-- Wait for the activated tasks to complete activation. It is unsafe to
|
||||
-- abort any of these tasks until the count goes to zero.
|
||||
|
||||
loop
|
||||
exit when Self_ID.Common.Wait_Count = 0;
|
||||
|
|
@ -302,7 +367,7 @@ package body System.Tasking.Restricted.Stages is
|
|||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
-- Remove the tasks from the chain.
|
||||
-- Remove the tasks from the chain
|
||||
|
||||
Chain_Access.T_ID := null;
|
||||
end Activate_Restricted_Tasks;
|
||||
|
|
@ -328,14 +393,13 @@ package body System.Tasking.Restricted.Stages is
|
|||
Write_Lock (Activator);
|
||||
Write_Lock (Self_ID);
|
||||
|
||||
-- Remove dangling reference to Activator,
|
||||
-- since a task may outlive its activator.
|
||||
-- Remove dangling reference to Activator, since a task may outlive its
|
||||
-- activator.
|
||||
|
||||
Self_ID.Common.Activator := null;
|
||||
|
||||
-- Wake up the activator, if it is waiting for a chain
|
||||
-- of tasks to activate, and we are the last in the chain
|
||||
-- to complete activation
|
||||
-- Wake up the activator, if it is waiting for a chain of tasks to
|
||||
-- activate, and we are the last in the chain to complete activation
|
||||
|
||||
if Activator.Common.State = Activator_Sleep then
|
||||
Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
|
||||
|
|
@ -352,9 +416,9 @@ package body System.Tasking.Restricted.Stages is
|
|||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
-- After the activation, active priority should be the same
|
||||
-- as base priority. We must unlock the Activator first,
|
||||
-- though, since it should not wait if we have lower priority.
|
||||
-- After the activation, active priority should be the same as base
|
||||
-- priority. We must unlock the Activator first, though, since it should
|
||||
-- not wait if we have lower priority.
|
||||
|
||||
if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
|
||||
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
|
||||
|
|
@ -391,8 +455,8 @@ package body System.Tasking.Restricted.Stages is
|
|||
Success : Boolean;
|
||||
|
||||
begin
|
||||
-- Stack is not preallocated on this target, so that
|
||||
-- Stack_Address must be null.
|
||||
-- Stack is not preallocated on this target, so that Stack_Address must
|
||||
-- be null.
|
||||
|
||||
pragma Assert (Stack_Address = Null_Address);
|
||||
|
||||
|
|
@ -415,9 +479,9 @@ package body System.Tasking.Restricted.Stages is
|
|||
(Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
|
||||
Task_Info, Size, Created_Task, Success);
|
||||
|
||||
-- If we do our job right then there should never be any failures,
|
||||
-- which was probably said about the Titanic; so just to be safe,
|
||||
-- let's retain this code for now
|
||||
-- If we do our job right then there should never be any failures, which
|
||||
-- was probably said about the Titanic; so just to be safe, let's retain
|
||||
-- this code for now
|
||||
|
||||
if not Success then
|
||||
Unlock (Self_ID);
|
||||
|
|
@ -468,6 +532,22 @@ package body System.Tasking.Restricted.Stages is
|
|||
Lock_RTS;
|
||||
end if;
|
||||
|
||||
-- Handle normal task termination by the environment task, but only for
|
||||
-- the normal task termination. In the case of Abnormal and
|
||||
-- Unhandled_Exception they must have been handled before, and the task
|
||||
-- termination soft link must have been changed so the task termination
|
||||
-- routine is not executed twice.
|
||||
|
||||
-- Note that in the "normal" implementation in s-tassta.adb the task
|
||||
-- termination procedure for the environment task should be executed
|
||||
-- after termination of library-level tasks. However, this
|
||||
-- implementation is to be used when the Ravenscar restrictions are in
|
||||
-- effect, and AI-394 says that if there is a fall-back handler set for
|
||||
-- the partition it should be called when the first task (including the
|
||||
-- environment task) attempts to terminate.
|
||||
|
||||
SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
|
||||
|
||||
Write_Lock (Self_ID);
|
||||
Sleep (Self_ID, Master_Completion_Sleep);
|
||||
Unlock (Self_ID);
|
||||
|
|
|
|||
|
|
@ -323,7 +323,7 @@ package body System.Tasking.Initialization is
|
|||
|
||||
procedure Final_Task_Unlock (Self_ID : Task_Id) is
|
||||
begin
|
||||
pragma Assert (Self_ID.Global_Task_Lock_Nesting = 1);
|
||||
pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1);
|
||||
Unlock (Global_Task_Lock'Access, Global_Lock => True);
|
||||
end Final_Task_Unlock;
|
||||
|
||||
|
|
@ -624,9 +624,10 @@ package body System.Tasking.Initialization is
|
|||
|
||||
procedure Task_Lock (Self_ID : Task_Id) is
|
||||
begin
|
||||
Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting + 1;
|
||||
Self_ID.Common.Global_Task_Lock_Nesting :=
|
||||
Self_ID.Common.Global_Task_Lock_Nesting + 1;
|
||||
|
||||
if Self_ID.Global_Task_Lock_Nesting = 1 then
|
||||
if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
|
||||
Defer_Abort_Nestable (Self_ID);
|
||||
Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
|
||||
end if;
|
||||
|
|
@ -654,10 +655,11 @@ package body System.Tasking.Initialization is
|
|||
|
||||
procedure Task_Unlock (Self_ID : Task_Id) is
|
||||
begin
|
||||
pragma Assert (Self_ID.Global_Task_Lock_Nesting > 0);
|
||||
Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting - 1;
|
||||
pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0);
|
||||
Self_ID.Common.Global_Task_Lock_Nesting :=
|
||||
Self_ID.Common.Global_Task_Lock_Nesting - 1;
|
||||
|
||||
if Self_ID.Global_Task_Lock_Nesting = 0 then
|
||||
if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
|
||||
Unlock (Global_Task_Lock'Access, Global_Lock => True);
|
||||
Undefer_Abort_Nestable (Self_ID);
|
||||
end if;
|
||||
|
|
|
|||
|
|
@ -107,6 +107,9 @@ package body System.Tasking is
|
|||
T.Common.Elaborated := Elaborated;
|
||||
T.Common.Activation_Failed := False;
|
||||
T.Common.Task_Info := Task_Info;
|
||||
T.Common.Global_Task_Lock_Nesting := 0;
|
||||
T.Common.Fall_Back_Handler := null;
|
||||
T.Common.Specific_Handler := null;
|
||||
|
||||
if T.Common.Parent = null then
|
||||
-- For the environment task, the adjusted stack size is
|
||||
|
|
|
|||
|
|
@ -37,7 +37,8 @@
|
|||
-- Any changes to this interface may require corresponding compiler changes.
|
||||
|
||||
with Ada.Exceptions;
|
||||
-- Used for: Exception_Id
|
||||
-- Used for Exception_Id
|
||||
-- Exception_Occurrence
|
||||
|
||||
with System.Parameters;
|
||||
-- used for Size_Type
|
||||
|
|
@ -51,6 +52,9 @@ with System.Soft_Links;
|
|||
with System.Task_Primitives;
|
||||
-- used for Private_Data
|
||||
|
||||
with System.Stack_Usage;
|
||||
-- used for Stack_Analyzer
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package System.Tasking is
|
||||
|
|
@ -329,6 +333,32 @@ package System.Tasking is
|
|||
end record;
|
||||
pragma Suppress_Initialization (Restricted_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 by the execution of its task_body.
|
||||
|
||||
type Termination_Handler is access protected procedure
|
||||
(Cause : in Cause_Of_Termination;
|
||||
T : in Task_Id;
|
||||
X : in Ada.Exceptions.Exception_Occurrence);
|
||||
-- Used to represent protected procedures to be executed when task
|
||||
-- terminates.
|
||||
|
||||
------------------------------------
|
||||
-- Task related other definitions --
|
||||
------------------------------------
|
||||
|
|
@ -539,6 +569,32 @@ package System.Tasking is
|
|||
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;
|
||||
pragma Atomic (Fall_Back_Handler);
|
||||
-- This is the fall-back handler that applies to the dependent tasks of
|
||||
-- the task.
|
||||
--
|
||||
-- Protection: atomic access
|
||||
|
||||
Specific_Handler : Termination_Handler;
|
||||
pragma Atomic (Specific_Handler);
|
||||
-- This is the specific handler that applies only to this task, and not
|
||||
-- any of its dependent tasks.
|
||||
--
|
||||
-- Protection: atomic access
|
||||
end record;
|
||||
|
||||
---------------------------------------
|
||||
|
|
@ -796,15 +852,6 @@ package System.Tasking is
|
|||
--
|
||||
-- Protection: Self.L
|
||||
|
||||
Global_Task_Lock_Nesting : Natural := 0;
|
||||
-- This is the current nesting level of calls to
|
||||
-- System.Tasking.Stages.Lock_Task_T. This allows a task to call
|
||||
-- Lock_Task_T multiple times without deadlocking. A task only locks
|
||||
-- All_Task_Lock when its All_Tasks_Nesting goes from 0 to 1, and only
|
||||
-- unlocked when it goes from 1 to 0.
|
||||
--
|
||||
-- Protection: Only accessed by Self
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ with System.Soft_Links;
|
|||
-- specific data. In the absence of tasking, these routines refer to global
|
||||
-- data. In the presense of tasking, they must be replaced with pointers to
|
||||
-- task-specific versions. Also used for Create_TSD, Destroy_TSD,
|
||||
-- Get_Current_Excep
|
||||
-- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler.
|
||||
|
||||
with System.Tasking.Initialization;
|
||||
-- Used for Remove_From_All_Tasks_List
|
||||
|
|
@ -84,6 +84,7 @@ pragma Elaborate_All (System.Tasking.Initialization);
|
|||
with System.Tasking.Utilities;
|
||||
-- Used for Make_Passive
|
||||
-- Abort_One_Task
|
||||
-- Abort_Tasks
|
||||
|
||||
with System.Tasking.Queuing;
|
||||
-- Used for Dequeue_Head
|
||||
|
|
@ -94,9 +95,6 @@ with System.Tasking.Rendezvous;
|
|||
with System.OS_Primitives;
|
||||
-- Used for Delay_Modes
|
||||
|
||||
with System.Finalization_Implementation;
|
||||
-- Used for System.Finalization_Implementation.Finalize_Global_List
|
||||
|
||||
with System.Secondary_Stack;
|
||||
-- Used for SS_Init
|
||||
|
||||
|
|
@ -115,6 +113,8 @@ with System.Traces.Tasking;
|
|||
with Unchecked_Deallocation;
|
||||
-- To recover from failure of ATCB initialization
|
||||
|
||||
with System.Stack_Usage;
|
||||
|
||||
package body System.Tasking.Stages is
|
||||
|
||||
package STPO renames System.Task_Primitives.Operations;
|
||||
|
|
@ -232,17 +232,6 @@ package body System.Tasking.Stages is
|
|||
|
||||
procedure Abort_Tasks (Tasks : Task_List) is
|
||||
begin
|
||||
-- If pragma Detect_Blocking is active then Program_Error must be
|
||||
-- raised if this potentially blocking operation is called from a
|
||||
-- protected action.
|
||||
|
||||
if System.Tasking.Detect_Blocking
|
||||
and then STPO.Self.Common.Protected_Action_Nesting > 0
|
||||
then
|
||||
Ada.Exceptions.Raise_Exception
|
||||
(Program_Error'Identity, "potentially blocking operation");
|
||||
end if;
|
||||
|
||||
Utilities.Abort_Tasks (Tasks);
|
||||
end Abort_Tasks;
|
||||
|
||||
|
|
@ -826,7 +815,19 @@ package body System.Tasking.Stages is
|
|||
|
||||
Vulnerable_Complete_Task (Self_ID);
|
||||
|
||||
System.Finalization_Implementation.Finalize_Global_List;
|
||||
-- Handle normal task termination by the environment task, but only
|
||||
-- for the normal task termination. In the case of Abnormal and
|
||||
-- Unhandled_Exception they must have been handled before, and the
|
||||
-- task termination soft link must have been changed so the task
|
||||
-- termination routine is not executed twice.
|
||||
|
||||
SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
|
||||
|
||||
-- Finalize the global list for controlled objects if needed
|
||||
|
||||
SSL.Finalize_Global_List.all;
|
||||
|
||||
-- Reset the soft links to non-tasking
|
||||
|
||||
SSL.Abort_Defer := SSL.Abort_Defer_NT'Access;
|
||||
SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access;
|
||||
|
|
@ -890,14 +891,32 @@ package body System.Tasking.Stages is
|
|||
use type System.Parameters.Size_Type;
|
||||
use type SSE.Storage_Offset;
|
||||
use System.Standard_Library;
|
||||
use System.Stack_Usage;
|
||||
|
||||
Bottom_Of_Stack : aliased Integer;
|
||||
|
||||
Secondary_Stack_Size :
|
||||
constant SSE.Storage_Offset :=
|
||||
Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
|
||||
SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100;
|
||||
|
||||
Secondary_Stack :
|
||||
aliased SSE.Storage_Array
|
||||
(1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
|
||||
SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
|
||||
(1 .. Secondary_Stack_Size);
|
||||
|
||||
pragma Warnings (Off);
|
||||
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
|
||||
|
||||
Overflow_Guard : constant := 16#1_000#;
|
||||
|
||||
Size :
|
||||
Natural := Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size);
|
||||
|
||||
pragma Warnings (On);
|
||||
-- Address of secondary stack. In the fixed secondary stack case, this
|
||||
-- value is not modified, causing a warning, hence the bracketing with
|
||||
-- Warnings (Off/On).
|
||||
|
||||
SEH_Table : aliased SSE.Storage_Array (1 .. 8);
|
||||
-- Structured Exception Registration table (2 words)
|
||||
|
||||
|
|
@ -905,6 +924,43 @@ package body System.Tasking.Stages is
|
|||
pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
|
||||
-- Install the SEH (Structured Exception Handling) handler
|
||||
|
||||
Cause : Cause_Of_Termination := Normal;
|
||||
-- Indicates the reason why this task terminates. Normal corresponds to
|
||||
-- a task terminating due to completing the last statement of its body,
|
||||
-- or as a result of waiting on a terminate alternative. If the task
|
||||
-- terminates because it is being aborted then Cause will be set to
|
||||
-- Abnormal. If the task terminates because of an exception raised by
|
||||
-- the execution of its task body, then Cause is set to
|
||||
-- Unhandled_Exception.
|
||||
|
||||
EO : Exception_Occurrence;
|
||||
-- If the task terminates because of an exception raised by the
|
||||
-- execution of its task body, then EO will contain the associated
|
||||
-- exception occurrence. Otherwise, it will contain Null_Occurrence.
|
||||
|
||||
procedure Search_Fall_Back_Handler (ID : Task_Id);
|
||||
-- Procedure that searches recursively a fall-back handler through the
|
||||
-- master relationship.
|
||||
|
||||
procedure Search_Fall_Back_Handler (ID : Task_Id) is
|
||||
begin
|
||||
-- If there is a fall back handler, execute it
|
||||
|
||||
if ID.Common.Fall_Back_Handler /= null then
|
||||
ID.Common.Fall_Back_Handler.all (Cause, Self_ID, EO);
|
||||
|
||||
-- Otherwise look for a fall back handler in the parent
|
||||
|
||||
elsif ID.Common.Parent /= null then
|
||||
Search_Fall_Back_Handler (ID.Common.Parent);
|
||||
|
||||
-- Otherwise, do nothing
|
||||
|
||||
else
|
||||
return;
|
||||
end if;
|
||||
end Search_Fall_Back_Handler;
|
||||
|
||||
begin
|
||||
pragma Assert (Self_ID.Deferral_Level = 1);
|
||||
|
||||
|
|
@ -912,10 +968,24 @@ package body System.Tasking.Stages is
|
|||
Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
|
||||
Secondary_Stack'Address;
|
||||
SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
|
||||
Size := Size - Natural (Secondary_Stack_Size);
|
||||
end if;
|
||||
|
||||
-- Set the guard page at the bottom of the stack. The call to
|
||||
-- unprotect the page is done in Terminate_Task
|
||||
Size := Size - Overflow_Guard;
|
||||
|
||||
if System.Stack_Usage.Is_Enabled then
|
||||
STPO.Lock_RTS;
|
||||
Initialize_Analyzer (Self_ID.Common.Analyzer,
|
||||
Self_ID.Common.Task_Image
|
||||
(1 .. Self_ID.Common.Task_Image_Len),
|
||||
Size,
|
||||
SSE.To_Integer (Bottom_Of_Stack'Address));
|
||||
STPO.Unlock_RTS;
|
||||
Fill_Stack (Self_ID.Common.Analyzer);
|
||||
end if;
|
||||
|
||||
-- Set the guard page at the bottom of the stack. The call to unprotect
|
||||
-- the page is done in Terminate_Task
|
||||
|
||||
Stack_Guard (Self_ID, True);
|
||||
|
||||
|
|
@ -930,9 +1000,13 @@ package body System.Tasking.Stages is
|
|||
|
||||
Install_SEH_Handler (SEH_Table'Address);
|
||||
|
||||
-- We lock RTS_Lock to wait for activator to finish activating
|
||||
-- the rest of the chain, so that everyone in the chain comes out
|
||||
-- in priority order.
|
||||
-- Initialize exception occurrence
|
||||
|
||||
Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
|
||||
|
||||
-- We lock RTS_Lock to wait for activator to finish activating the rest
|
||||
-- of the chain, so that everyone in the chain comes out in priority
|
||||
-- order.
|
||||
|
||||
-- This also protects the value of
|
||||
-- Self_ID.Common.Activator.Common.Wait_Count.
|
||||
|
|
@ -980,6 +1054,17 @@ package body System.Tasking.Stages is
|
|||
when Standard'Abort_Signal =>
|
||||
Initialization.Defer_Abort_Nestable (Self_ID);
|
||||
|
||||
-- Update the cause that motivated the task termination so that
|
||||
-- the appropriate information is passed to the task termination
|
||||
-- procedure. Task termination as a result of waiting on a
|
||||
-- terminate alternative is a normal termination, although it is
|
||||
-- implemented using the abort mechanisms.
|
||||
|
||||
if Self_ID.Terminate_Alternative then
|
||||
Cause := Normal;
|
||||
else
|
||||
Cause := Abnormal;
|
||||
end if;
|
||||
when others =>
|
||||
-- ??? Using an E : others here causes CD2C11A to fail on
|
||||
-- DEC Unix, see 7925-005.
|
||||
|
|
@ -998,8 +1083,33 @@ package body System.Tasking.Stages is
|
|||
if Exception_Trace = Unhandled_Raise then
|
||||
Trace_Unhandled_Exception_In_Task (Self_ID);
|
||||
end if;
|
||||
|
||||
-- Update the cause that motivated the task termination so that
|
||||
-- the appropriate information is passed to the task termination
|
||||
-- procedure, as well as the associated Exception_Occurrence.
|
||||
|
||||
Cause := Unhandled_Exception;
|
||||
Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
|
||||
end;
|
||||
|
||||
-- Look for a task termination handler. This code is for all tasks but
|
||||
-- the environment task. The task termination code for the environment
|
||||
-- task is executed by SSL.Task_Termination_Handler.
|
||||
|
||||
if Self_ID.Common.Specific_Handler /= null then
|
||||
Self_ID.Common.Specific_Handler.all (Cause, Self_ID, EO);
|
||||
else
|
||||
-- Look for a fall-back handler following the master relationship
|
||||
-- for the task.
|
||||
|
||||
Search_Fall_Back_Handler (Self_ID);
|
||||
end if;
|
||||
|
||||
if System.Stack_Usage.Is_Enabled then
|
||||
Compute_Result (Self_ID.Common.Analyzer);
|
||||
Report_Result (Self_ID.Common.Analyzer);
|
||||
end if;
|
||||
|
||||
Terminate_Task (Self_ID);
|
||||
end Task_Wrapper;
|
||||
|
||||
|
|
@ -1021,16 +1131,16 @@ package body System.Tasking.Stages is
|
|||
-- We can't call Destroy_TSD while we are holding any other locks, because
|
||||
-- it locks Global_Task_Lock, and our deadlock prevention rules require
|
||||
-- that to be the outermost lock. Our first "solution" was to just lock
|
||||
-- Global_Task_Lock in addition to the other locks, and force the parent
|
||||
-- to also lock this lock between its wakeup and its freeing of the ATCB.
|
||||
-- See Complete_Task for the parent-side of the code that has the matching
|
||||
-- Global_Task_Lock in addition to the other locks, and force the parent to
|
||||
-- also lock this lock between its wakeup and its freeing of the ATCB. See
|
||||
-- Complete_Task for the parent-side of the code that has the matching
|
||||
-- calls to Task_Lock and Task_Unlock. That was not really a solution,
|
||||
-- since the operation Task_Unlock continued to access the ATCB after
|
||||
-- unlocking, after which the parent was observed to race ahead,
|
||||
-- deallocate the ATCB, and then reallocate it to another task. The
|
||||
-- call to Undefer_Abortion in Task_Unlock by the "terminated" task was
|
||||
-- overwriting the data of the new task that reused the ATCB! To solve
|
||||
-- this problem, we introduced the new operation Final_Task_Unlock.
|
||||
-- unlocking, after which the parent was observed to race ahead, deallocate
|
||||
-- the ATCB, and then reallocate it to another task. The call to
|
||||
-- Undefer_Abortion in Task_Unlock by the "terminated" task was overwriting
|
||||
-- the data of the new task that reused the ATCB! To solve this problem, we
|
||||
-- introduced the new operation Final_Task_Unlock.
|
||||
|
||||
procedure Terminate_Task (Self_ID : Task_Id) is
|
||||
Environment_Task : constant Task_Id := STPO.Environment_Task;
|
||||
|
|
|
|||
|
|
@ -117,9 +117,6 @@ package body System.Tasking.Utilities is
|
|||
-- Abort_Tasks --
|
||||
-----------------
|
||||
|
||||
-- Compiler interface only: Do not call from within the RTS,
|
||||
|
||||
-- except in the implementation of Ada.Task_Identification.
|
||||
-- This must be called to implement the abort statement.
|
||||
-- Much of the actual work of the abort is done by the abortee,
|
||||
-- via the Abort_Handler signal handler, and propagation of the
|
||||
|
|
@ -131,6 +128,17 @@ package body System.Tasking.Utilities is
|
|||
P : Task_Id;
|
||||
|
||||
begin
|
||||
-- If pragma Detect_Blocking is active then Program_Error must be
|
||||
-- raised if this potentially blocking operation is called from a
|
||||
-- protected action.
|
||||
|
||||
if System.Tasking.Detect_Blocking
|
||||
and then Self_Id.Common.Protected_Action_Nesting > 0
|
||||
then
|
||||
Ada.Exceptions.Raise_Exception
|
||||
(Program_Error'Identity, "potentially blocking operation");
|
||||
end if;
|
||||
|
||||
Initialization.Defer_Abort_Nestable (Self_Id);
|
||||
|
||||
-- ?????
|
||||
|
|
|
|||
|
|
@ -286,6 +286,18 @@ package body Switch.B is
|
|||
Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value, C);
|
||||
Time_Slice_Value := Time_Slice_Value * 1_000;
|
||||
|
||||
-- Processing for u switch
|
||||
|
||||
when 'u' =>
|
||||
Ptr := Ptr + 1;
|
||||
Dynamic_Stack_Measurement := True;
|
||||
Scan_Nat
|
||||
(Switch_Chars,
|
||||
Max,
|
||||
Ptr,
|
||||
Dynamic_Stack_Measurement_Array_Size,
|
||||
C);
|
||||
|
||||
-- Processing for v switch
|
||||
|
||||
when 'v' =>
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue