Skip to content

R
riscv-gcc-1
Commit 81408d49 by Doug Rupp Committed by Arnaud Charlet
Options

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
parent 9d0aa6ab
Showing with 4261 additions and 277 deletions
gcc/ada/Makefile.rtl
# 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) \
......
gcc/ada/a-elchha.adb
......@@ -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
......
gcc/ada/a-exextr.adb
......@@ -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;
......
gcc/ada/a-taside.adb
......@@ -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;
......
gcc/ada/a-taster.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-taster.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/bindgen.adb
......@@ -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;
......
gcc/ada/bindusg.adb
......@@ -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, ");
......
gcc/ada/g-allein.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . A L T I V E C . L O W _ L E V E L _ I N T E R F A C E --
-- --
-- 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 provides entities to be used internally by the units common to
-- both bindings (Hard or Soft), and relevant to the interfacing with the
-- underlying Low Level support.
-- The set of "services" includes:
--
-- o Imports to the low level routines for which a direct binding is
-- mandatory (or just possible when analyzed as such).
--
-- o Conversion routines (unchecked) between low level types, or between
-- various pointer representations.
with GNAT.Altivec.Vector_Types;
with GNAT.Altivec.Low_Level_Vectors;
with Ada.Unchecked_Conversion;
package GNAT.Altivec.Low_Level_Interface is
----------------------------------------------------------------------------
-- Imports for "argument must be literal" constraints in the Hard binding --
----------------------------------------------------------------------------
use GNAT.Altivec.Vector_Types;
-- vec_ctf --
function vec_ctf_vui_cint_r_vf
(A : vector_unsigned_int;
B : c_int) return vector_float;
pragma Import
(LL_Altivec, vec_ctf_vui_cint_r_vf, "__builtin_altivec_vcfux");
function vec_ctf_vsi_cint_r_vf
(A : vector_signed_int;
B : c_int) return vector_float;
pragma Import
(LL_Altivec, vec_ctf_vsi_cint_r_vf, "__builtin_altivec_vcfsx");
-- vec_vcfsx --
function vec_vcfsx_vsi_cint_r_vf
(A : vector_signed_int;
B : c_int) return vector_float;
pragma Import
(LL_Altivec, vec_vcfsx_vsi_cint_r_vf, "__builtin_altivec_vcfsx");
-- vec_vcfux --
function vec_vcfux_vui_cint_r_vf
(A : vector_unsigned_int;
B : c_int) return vector_float;
pragma Import
(LL_Altivec, vec_vcfux_vui_cint_r_vf, "__builtin_altivec_vcfux");
-- vec_cts --
function vec_cts_vf_cint_r_vsi
(A : vector_float;
B : c_int) return vector_signed_int;
pragma Import
(LL_Altivec, vec_cts_vf_cint_r_vsi, "__builtin_altivec_vctsxs");
-- vec_ctu --
function vec_ctu_vf_cint_r_vui
(A : vector_float;
B : c_int) return vector_unsigned_int;
pragma Import
(LL_Altivec, vec_ctu_vf_cint_r_vui, "__builtin_altivec_vctuxs");
-- vec_dss --
procedure vec_dss_cint
(A : c_int);
pragma Import
(LL_Altivec, vec_dss_cint, "__builtin_altivec_dss");
-- vec_dst --
procedure vec_dst_kvucp_cint_cint
(A : const_vector_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvucp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvscp_cint_cint
(A : const_vector_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvscp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvbcp_cint_cint
(A : const_vector_bool_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvbcp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvusp_cint_cint
(A : const_vector_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvusp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvssp_cint_cint
(A : const_vector_signed_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvssp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvbsp_cint_cint
(A : const_vector_bool_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvbsp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvxp_cint_cint
(A : const_vector_pixel_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvxp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvuip_cint_cint
(A : const_vector_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvuip_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvsip_cint_cint
(A : const_vector_signed_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvsip_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvbip_cint_cint
(A : const_vector_bool_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvbip_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kvfp_cint_cint
(A : const_vector_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kvfp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kucp_cint_cint
(A : const_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kucp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kscp_cint_cint
(A : const_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kscp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kusp_cint_cint
(A : const_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kusp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_ksp_cint_cint
(A : const_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_ksp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kuip_cint_cint
(A : const_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kuip_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kip_cint_cint
(A : const_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kip_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kulongp_cint_cint
(A : const_unsigned_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kulongp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_klongp_cint_cint
(A : const_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_klongp_cint_cint, "__builtin_altivec_dst");
procedure vec_dst_kfp_cint_cint
(A : const_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dst_kfp_cint_cint, "__builtin_altivec_dst");
-- vec_dstst --
procedure vec_dstst_kvucp_cint_cint
(A : const_vector_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvucp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvscp_cint_cint
(A : const_vector_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvscp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvbcp_cint_cint
(A : const_vector_bool_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvbcp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvusp_cint_cint
(A : const_vector_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvusp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvssp_cint_cint
(A : const_vector_signed_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvssp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvbsp_cint_cint
(A : const_vector_bool_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvbsp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvxp_cint_cint
(A : const_vector_pixel_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvxp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvuip_cint_cint
(A : const_vector_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvuip_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvsip_cint_cint
(A : const_vector_signed_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvsip_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvbip_cint_cint
(A : const_vector_bool_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvbip_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kvfp_cint_cint
(A : const_vector_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kvfp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kucp_cint_cint
(A : const_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kucp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kscp_cint_cint
(A : const_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kscp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kusp_cint_cint
(A : const_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kusp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_ksp_cint_cint
(A : const_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_ksp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kuip_cint_cint
(A : const_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kuip_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kip_cint_cint
(A : const_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kip_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kulongp_cint_cint
(A : const_unsigned_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kulongp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_klongp_cint_cint
(A : const_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_klongp_cint_cint, "__builtin_altivec_dstst");
procedure vec_dstst_kfp_cint_cint
(A : const_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstst_kfp_cint_cint, "__builtin_altivec_dstst");
-- vec_dststt --
procedure vec_dststt_kvucp_cint_cint
(A : const_vector_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvucp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvscp_cint_cint
(A : const_vector_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvscp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvbcp_cint_cint
(A : const_vector_bool_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvbcp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvusp_cint_cint
(A : const_vector_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvusp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvssp_cint_cint
(A : const_vector_signed_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvssp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvbsp_cint_cint
(A : const_vector_bool_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvbsp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvxp_cint_cint
(A : const_vector_pixel_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvxp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvuip_cint_cint
(A : const_vector_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvuip_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvsip_cint_cint
(A : const_vector_signed_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvsip_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvbip_cint_cint
(A : const_vector_bool_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvbip_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kvfp_cint_cint
(A : const_vector_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kvfp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kucp_cint_cint
(A : const_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kucp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kscp_cint_cint
(A : const_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kscp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kusp_cint_cint
(A : const_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kusp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_ksp_cint_cint
(A : const_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_ksp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kuip_cint_cint
(A : const_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kuip_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kip_cint_cint
(A : const_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kip_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kulongp_cint_cint
(A : const_unsigned_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kulongp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_klongp_cint_cint
(A : const_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_klongp_cint_cint, "__builtin_altivec_dststt");
procedure vec_dststt_kfp_cint_cint
(A : const_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dststt_kfp_cint_cint, "__builtin_altivec_dststt");
-- vec_dstt --
procedure vec_dstt_kvucp_cint_cint
(A : const_vector_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvucp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvscp_cint_cint
(A : const_vector_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvscp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvbcp_cint_cint
(A : const_vector_bool_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvbcp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvusp_cint_cint
(A : const_vector_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvusp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvssp_cint_cint
(A : const_vector_signed_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvssp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvbsp_cint_cint
(A : const_vector_bool_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvbsp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvxp_cint_cint
(A : const_vector_pixel_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvxp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvuip_cint_cint
(A : const_vector_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvuip_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvsip_cint_cint
(A : const_vector_signed_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvsip_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvbip_cint_cint
(A : const_vector_bool_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvbip_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kvfp_cint_cint
(A : const_vector_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kvfp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kucp_cint_cint
(A : const_unsigned_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kucp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kscp_cint_cint
(A : const_signed_char_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kscp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kusp_cint_cint
(A : const_unsigned_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kusp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_ksp_cint_cint
(A : const_short_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_ksp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kuip_cint_cint
(A : const_unsigned_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kuip_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kip_cint_cint
(A : const_int_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kip_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kulongp_cint_cint
(A : const_unsigned_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kulongp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_klongp_cint_cint
(A : const_long_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_klongp_cint_cint, "__builtin_altivec_dstt");
procedure vec_dstt_kfp_cint_cint
(A : const_float_ptr;
B : c_int;
C : c_int);
pragma Import
(LL_Altivec, vec_dstt_kfp_cint_cint, "__builtin_altivec_dstt");
-- vec_sld --
-- ??? The base GCC implementation maps everything to vsldoi_4si, while
-- it defines builtin variants for all the modes. Adjust here, to avoid
-- the infamous argument mode mismatch.
function vec_sld_vf_vf_cint_r_vf
(A : vector_float;
B : vector_float;
C : c_int) return vector_float;
pragma Import
(LL_Altivec, vec_sld_vf_vf_cint_r_vf, "__builtin_altivec_vsldoi_4sf");
function vec_sld_vsi_vsi_cint_r_vsi
(A : vector_signed_int;
B : vector_signed_int;
C : c_int) return vector_signed_int;
pragma Import
(LL_Altivec, vec_sld_vsi_vsi_cint_r_vsi, "__builtin_altivec_vsldoi_4si");
function vec_sld_vui_vui_cint_r_vui
(A : vector_unsigned_int;
B : vector_unsigned_int;
C : c_int) return vector_unsigned_int;
pragma Import
(LL_Altivec, vec_sld_vui_vui_cint_r_vui, "__builtin_altivec_vsldoi_4si");
function vec_sld_vbi_vbi_cint_r_vbi
(A : vector_bool_int;
B : vector_bool_int;
C : c_int) return vector_bool_int;
pragma Import
(LL_Altivec, vec_sld_vbi_vbi_cint_r_vbi, "__builtin_altivec_vsldoi_4si");
function vec_sld_vss_vss_cint_r_vss
(A : vector_signed_short;
B : vector_signed_short;
C : c_int) return vector_signed_short;
pragma Import
(LL_Altivec, vec_sld_vss_vss_cint_r_vss, "__builtin_altivec_vsldoi_8hi");
function vec_sld_vus_vus_cint_r_vus
(A : vector_unsigned_short;
B : vector_unsigned_short;
C : c_int) return vector_unsigned_short;
pragma Import
(LL_Altivec, vec_sld_vus_vus_cint_r_vus, "__builtin_altivec_vsldoi_8hi");
function vec_sld_vbs_vbs_cint_r_vbs
(A : vector_bool_short;
B : vector_bool_short;
C : c_int) return vector_bool_short;
pragma Import
(LL_Altivec, vec_sld_vbs_vbs_cint_r_vbs, "__builtin_altivec_vsldoi_8hi");
function vec_sld_vx_vx_cint_r_vx
(A : vector_pixel;
B : vector_pixel;
C : c_int) return vector_pixel;
pragma Import
(LL_Altivec, vec_sld_vx_vx_cint_r_vx, "__builtin_altivec_vsldoi_4si");
function vec_sld_vsc_vsc_cint_r_vsc
(A : vector_signed_char;
B : vector_signed_char;
C : c_int) return vector_signed_char;
pragma Import
(LL_Altivec, vec_sld_vsc_vsc_cint_r_vsc, "__builtin_altivec_vsldoi_16qi");
function vec_sld_vuc_vuc_cint_r_vuc
(A : vector_unsigned_char;
B : vector_unsigned_char;
C : c_int) return vector_unsigned_char;
pragma Import
(LL_Altivec, vec_sld_vuc_vuc_cint_r_vuc, "__builtin_altivec_vsldoi_16qi");
function vec_sld_vbc_vbc_cint_r_vbc
(A : vector_bool_char;
B : vector_bool_char;
C : c_int) return vector_bool_char;
pragma Import
(LL_Altivec, vec_sld_vbc_vbc_cint_r_vbc, "__builtin_altivec_vsldoi_16qi");
-- vec_splat --
function vec_splat_vsc_cint_r_vsc
(A : vector_signed_char;
B : c_int) return vector_signed_char;
pragma Import
(LL_Altivec, vec_splat_vsc_cint_r_vsc, "__builtin_altivec_vspltb");
function vec_splat_vuc_cint_r_vuc
(A : vector_unsigned_char;
B : c_int) return vector_unsigned_char;
pragma Import
(LL_Altivec, vec_splat_vuc_cint_r_vuc, "__builtin_altivec_vspltb");
function vec_splat_vbc_cint_r_vbc
(A : vector_bool_char;
B : c_int) return vector_bool_char;
pragma Import
(LL_Altivec, vec_splat_vbc_cint_r_vbc, "__builtin_altivec_vspltb");
function vec_splat_vss_cint_r_vss
(A : vector_signed_short;
B : c_int) return vector_signed_short;
pragma Import
(LL_Altivec, vec_splat_vss_cint_r_vss, "__builtin_altivec_vsplth");
function vec_splat_vus_cint_r_vus
(A : vector_unsigned_short;
B : c_int) return vector_unsigned_short;
pragma Import
(LL_Altivec, vec_splat_vus_cint_r_vus, "__builtin_altivec_vsplth");
function vec_splat_vbs_cint_r_vbs
(A : vector_bool_short;
B : c_int) return vector_bool_short;
pragma Import
(LL_Altivec, vec_splat_vbs_cint_r_vbs, "__builtin_altivec_vsplth");
function vec_splat_vx_cint_r_vx
(A : vector_pixel;
B : c_int) return vector_pixel;
pragma Import
(LL_Altivec, vec_splat_vx_cint_r_vx, "__builtin_altivec_vsplth");
function vec_splat_vf_cint_r_vf
(A : vector_float;
B : c_int) return vector_float;
pragma Import
(LL_Altivec, vec_splat_vf_cint_r_vf, "__builtin_altivec_vspltw");
function vec_splat_vsi_cint_r_vsi
(A : vector_signed_int;
B : c_int) return vector_signed_int;
pragma Import
(LL_Altivec, vec_splat_vsi_cint_r_vsi, "__builtin_altivec_vspltw");
function vec_splat_vui_cint_r_vui
(A : vector_unsigned_int;
B : c_int) return vector_unsigned_int;
pragma Import
(LL_Altivec, vec_splat_vui_cint_r_vui, "__builtin_altivec_vspltw");
function vec_splat_vbi_cint_r_vbi
(A : vector_bool_int;
B : c_int) return vector_bool_int;
pragma Import
(LL_Altivec, vec_splat_vbi_cint_r_vbi, "__builtin_altivec_vspltw");
-- vec_vspltw --
function vec_vspltw_vf_cint_r_vf
(A : vector_float;
B : c_int) return vector_float;
pragma Import
(LL_Altivec, vec_vspltw_vf_cint_r_vf, "__builtin_altivec_vspltw");
function vec_vspltw_vsi_cint_r_vsi
(A : vector_signed_int;
B : c_int) return vector_signed_int;
pragma Import
(LL_Altivec, vec_vspltw_vsi_cint_r_vsi, "__builtin_altivec_vspltw");
function vec_vspltw_vui_cint_r_vui
(A : vector_unsigned_int;
B : c_int) return vector_unsigned_int;
pragma Import
(LL_Altivec, vec_vspltw_vui_cint_r_vui, "__builtin_altivec_vspltw");
function vec_vspltw_vbi_cint_r_vbi
(A : vector_bool_int;
B : c_int) return vector_bool_int;
pragma Import
(LL_Altivec, vec_vspltw_vbi_cint_r_vbi, "__builtin_altivec_vspltw");
-- vec_vsplth --
function vec_vsplth_vbs_cint_r_vbs
(A : vector_bool_short;
B : c_int) return vector_bool_short;
pragma Import
(LL_Altivec, vec_vsplth_vbs_cint_r_vbs, "__builtin_altivec_vsplth");
function vec_vsplth_vss_cint_r_vss
(A : vector_signed_short;
B : c_int) return vector_signed_short;
pragma Import
(LL_Altivec, vec_vsplth_vss_cint_r_vss, "__builtin_altivec_vsplth");
function vec_vsplth_vus_cint_r_vus
(A : vector_unsigned_short;
B : c_int) return vector_unsigned_short;
pragma Import
(LL_Altivec, vec_vsplth_vus_cint_r_vus, "__builtin_altivec_vsplth");
function vec_vsplth_vx_cint_r_vx
(A : vector_pixel;
B : c_int) return vector_pixel;
pragma Import
(LL_Altivec, vec_vsplth_vx_cint_r_vx, "__builtin_altivec_vsplth");
-- vec_vspltb --
function vec_vspltb_vsc_cint_r_vsc
(A : vector_signed_char;
B : c_int) return vector_signed_char;
pragma Import
(LL_Altivec, vec_vspltb_vsc_cint_r_vsc, "__builtin_altivec_vspltb");
function vec_vspltb_vuc_cint_r_vuc
(A : vector_unsigned_char;
B : c_int) return vector_unsigned_char;
pragma Import
(LL_Altivec, vec_vspltb_vuc_cint_r_vuc, "__builtin_altivec_vspltb");
function vec_vspltb_vbc_cint_r_vbc
(A : vector_bool_char;
B : c_int) return vector_bool_char;
pragma Import
(LL_Altivec, vec_vspltb_vbc_cint_r_vbc, "__builtin_altivec_vspltb");
-- vec_splat_s8 --
function vec_splat_s8_cint_r_vsc
(A : c_int) return vector_signed_char;
pragma Import
(LL_Altivec, vec_splat_s8_cint_r_vsc, "__builtin_altivec_vspltisb");
-- vec_splat_s16 --
function vec_splat_s16_cint_r_vss
(A : c_int) return vector_signed_short;
pragma Import
(LL_Altivec, vec_splat_s16_cint_r_vss, "__builtin_altivec_vspltish");
-- vec_splat_s32 --
function vec_splat_s32_cint_r_vsi
(A : c_int) return vector_signed_int;
pragma Import
(LL_Altivec, vec_splat_s32_cint_r_vsi, "__builtin_altivec_vspltisw");
-- vec_splat_u8 --
function vec_splat_u8_cint_r_vuc
(A : c_int) return vector_unsigned_char;
pragma Import
(LL_Altivec, vec_splat_u8_cint_r_vuc, "__builtin_altivec_vspltisb");
-- vec_splat_u16 --
function vec_splat_u16_cint_r_vus
(A : c_int) return vector_unsigned_short;
pragma Import
(LL_Altivec, vec_splat_u16_cint_r_vus, "__builtin_altivec_vspltish");
-- vec_splat_u32 --
function vec_splat_u32_cint_r_vui
(A : c_int) return vector_unsigned_int;
pragma Import
(LL_Altivec, vec_splat_u32_cint_r_vui, "__builtin_altivec_vspltisw");
------------------------------------------------------------
-- Imports for low-level signature consistent subprograms --
------------------------------------------------------------
-- vec_dssall --
procedure vec_dssall;
pragma Import
(LL_Altivec, vec_dssall, "__builtin_altivec_dssall");
-----------------------------------------
-- Conversions between low level types --
-----------------------------------------
use GNAT.Altivec.Low_Level_Vectors;
-- Something like...
--
-- TYPES="LL_VBC LL_VUC LL_VSC LL_VBS LL_VUS LL_VSS \
-- LL_VBI LL_VUI LL_VSI LL_VF LL_VP"
-- for TT in `echo $TYPES`; do
-- for ST in `echo $TYPES`; do
-- echo "function To_$TT is new Ada.Unchecked_Conversion ($ST, $TT);"
-- done
-- echo ""
-- done
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBC, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUC, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSC, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBS, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUS, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSS, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBI, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUI, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSI, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VF, LL_VBC);
function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VP, LL_VBC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBC, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUC, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSC, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBS, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUS, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSS, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBI, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUI, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSI, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VF, LL_VUC);
function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VP, LL_VUC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBC, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUC, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSC, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBS, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUS, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSS, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBI, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUI, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSI, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VF, LL_VSC);
function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VP, LL_VSC);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBC, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUC, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSC, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBS, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUS, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSS, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBI, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUI, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSI, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VF, LL_VBS);
function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VP, LL_VBS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBC, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUC, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSC, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBS, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUS, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSS, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBI, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUI, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSI, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VF, LL_VUS);
function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VP, LL_VUS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBC, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUC, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSC, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBS, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUS, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSS, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBI, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUI, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSI, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VF, LL_VSS);
function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VP, LL_VSS);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBC, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUC, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSC, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBS, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUS, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSS, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBI, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUI, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSI, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VF, LL_VBI);
function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VP, LL_VBI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBC, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUC, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSC, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBS, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUS, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSS, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBI, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUI, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSI, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VF, LL_VUI);
function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VP, LL_VUI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBC, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUC, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSC, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBS, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUS, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSS, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBI, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUI, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSI, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VF, LL_VSI);
function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VP, LL_VSI);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBC, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUC, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSC, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBS, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUS, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSS, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBI, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUI, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSI, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VF, LL_VF);
function To_LL_VF is new Ada.Unchecked_Conversion (LL_VP, LL_VF);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBC, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUC, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSC, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBS, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUS, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSS, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBI, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUI, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSI, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VF, LL_VP);
function To_LL_VP is new Ada.Unchecked_Conversion (LL_VP, LL_VP);
----------------------------------------------
-- Conversions between pointer/access types --
----------------------------------------------
function To_PTR is
new Ada.Unchecked_Conversion (vector_unsigned_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_signed_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_bool_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_unsigned_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_signed_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_bool_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_unsigned_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_signed_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_bool_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_float_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (vector_pixel_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_bool_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_signed_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_unsigned_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_bool_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_signed_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_unsigned_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_bool_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_signed_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_unsigned_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_float_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_vector_pixel_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (c_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (signed_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (unsigned_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (signed_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (unsigned_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (signed_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (unsigned_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (signed_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (unsigned_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (float_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_signed_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_unsigned_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_signed_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_unsigned_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_signed_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_unsigned_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_signed_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_unsigned_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (const_float_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_signed_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_unsigned_char_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_signed_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_unsigned_short_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_signed_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_unsigned_int_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_signed_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_unsigned_long_ptr, c_ptr);
function To_PTR is
new Ada.Unchecked_Conversion (constv_float_ptr, c_ptr);
end GNAT.Altivec.Low_Level_Interface;
gcc/ada/g-alleve.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/g-alleve.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/g-altcon.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/g-altcon.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/g-altive.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/g-alveop.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/g-alveop.ads 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/g-alvety.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/g-alvevi.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/impunit.adb
......@@ -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
......
gcc/ada/opt.ads
......@@ -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
......
gcc/ada/s-finimp.adb
......@@ -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;
gcc/ada/s-io.adb
......@@ -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;
gcc/ada/s-io.ads
......@@ -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;
gcc/ada/s-soflin.adb
......@@ -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 --
......@@ -286,6 +305,16 @@ package body System.Soft_Links is
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 --
-------------------------
......
gcc/ada/s-soflin.ads
......@@ -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;
......
gcc/ada/s-solita.adb
......@@ -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
......
gcc/ada/s-stausa.ads
......@@ -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.
-- Top/Bottom would be much better than inner and outer ???
function To_Stack_Address (Value : Address) return Stack_Address
renames System.Storage_Elements.To_Integer;
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;
gcc/ada/s-tarest.adb
......@@ -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);
......
gcc/ada/s-tasini.adb
......@@ -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;
......
gcc/ada/s-taskin.adb
......@@ -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
......
gcc/ada/s-taskin.ads
......@@ -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
......
gcc/ada/s-tassta.adb
......@@ -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;
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
-- 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;
......
gcc/ada/s-tasuti.adb
......@@ -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);
-- ?????
......
gcc/ada/switch-b.adb
......@@ -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' =>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment