From: Arnaud Charlet Date: Mon, 29 Aug 2011 13:07:49 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b254da66e7a3155dcd88d5ec68b1a75fba1bbced;p=gcc.git [multiple changes] 2011-08-29 Hristian Kirtchev * exp_ch4.adb (Expand_Allocator_Expression): Add code to set attribute Finalize_Address of the access type's finalization master. (Expand_N_Allocator): Add code to set attribute Finalize_Address of the access type's finalization master. Add a guard to prevent Associated_Storage_Pool from being set on .NET/JVM. * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Add code to set attribute Finalize_Address of the access type's finalization master. * exp_ch7.adb (Make_Finalize_Address_Call): New routine. * exp_ch7.ads (Make_Finalize_Address_Call): New routine. * rtsfind.ads: Add RE_Set_Finalize_Address to tables RE_Id and RE_Unit_Table. * s-finmas.adb: Add with clause for System.Address_Image. Add with and use clause for System.IO (Detach): Relax the assertion, to be reinstated later. (Finalize): Rewrite the iteration loop to avoid pointer comparison. Relax the assertion on Finalize_Address, to be reinstated later. (Is_Empty_List): New routine. (pm): New debug routine. (Set_Finalize_Address): New routine. * s-finmas.ads (pm): New debug routine. (Set_Finalize_Address): New routine. * s-stposu.adb (Allocate_Any_Controlled): Code reformatting. 2011-08-29 Tristan Gingold * a-exexpr-gcc.adb (GCC_Exception_Access, GNAT_GCC_Exception_Access): Remove convention C. 2011-08-29 Tristan Gingold * s-taprop-vms.adb (Get_Exc_Stack_Addr): Remove. (Initialize_TCB): Remove Exc_Stack_Ptr initialization. (Finalize_TCB): Remove its finalization. (Initialize): Remove assignment of GET_Exc_Stack_Addr * s-soflin.adb (NT_Exc_Stack): Remove (Get_Exc_Stack_Addr_NT): Likewise. (Get_Exc_Stack_Addr_Soft): Likewise. * s-soflin.ads (Get_Exc_Stack_Addr_NT): Remove. (Get_Exc_Stack_Addr): Likewise. (Get_Exc_Stack_Addr_Soft): Likewise * s-taspri-vms.ads (Exc_Stack_T): Remove. (Exc_Stack_Ptr_T): Likewise. (Private_Data): Remove Exc_Stack_Ptr component. 2011-08-29 Tristan Gingold * raise-gcc.c (get_ip_from_context): New function. Factorize code. 2011-08-29 Tristan Gingold * gnat_ugn.texi: Fix aix and x86-solaris info for run-time. 2011-08-29 Geert Bosch * s-gearop.ads (Back_Substitute, Diagonal, Forward_Eliminate, L2_Norm, Swap_Column): New generic subprograms * s-gearop.adb (Back_Substitute, Diagonal, Forward_Eliminate, L2_Norm, Swap_Column): Implement new subprograms in order to eliminate dependency on BLAS and LAPACK libraries in Ada.Numerics.Generic_Real_Arrays and eventually also the complex version. Forward_Eliminate/Back_Substitute can be used to put a matrix in row echelon or reduced row echelon form using partial pivoting. * a-ngrear.adb: (Back_Substitute, Diagonal, Forward_Eleminate, Swap_Column): Instantiate from System.Generic_Array_Operations. ("*", "abs"): Implement by instantiation from Generic_Array_Operations. (Sqrt): Local function for simple computation of square root without adding dependencies on Generic_Elementary_Functions. (Swap): New subprogram to exchange floating point numbers. (Inverse): Reimplement using Jordan-Gauss elimination. (Jacobi): New procedure implementing Jacobi's method for computation of eigensystems, based on Rutishauser's implementation. (L2_Norm): Implement directly using the inner product. (Sort_Eigensystem): Sort eigenvalue/eigenvector pairs in order of decreasing eigenvalue as required by the Ada RM. (Swap_Column): New helper procedure for Sort_Eigensystem. Remove with of System.Generic_Real_BLAS and System.Generic_Real_LAPACK. Add with of Ada.Containers.Generic_Anonymous_Array_Sort, for Sort_Eigensystems. 2011-08-29 Thomas Quinot * put_scos.adb (Put_SCOs): Do not emit a newline for an empty statements line. From-SVN: r178220 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3d4853fe7ad..705338e194c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,90 @@ +2011-08-29 Hristian Kirtchev + + * exp_ch4.adb (Expand_Allocator_Expression): Add code to set attribute + Finalize_Address of the access type's finalization master. + (Expand_N_Allocator): Add code to set attribute Finalize_Address of the + access type's finalization master. Add a guard to prevent + Associated_Storage_Pool from being set on .NET/JVM. + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Add code to set + attribute Finalize_Address of the access type's finalization master. + * exp_ch7.adb (Make_Finalize_Address_Call): New routine. + * exp_ch7.ads (Make_Finalize_Address_Call): New routine. + * rtsfind.ads: Add RE_Set_Finalize_Address to tables RE_Id and + RE_Unit_Table. + * s-finmas.adb: Add with clause for System.Address_Image. Add with and + use clause for System.IO + (Detach): Relax the assertion, to be reinstated later. + (Finalize): Rewrite the iteration loop to avoid pointer comparison. + Relax the assertion on Finalize_Address, to be reinstated later. + (Is_Empty_List): New routine. + (pm): New debug routine. + (Set_Finalize_Address): New routine. + * s-finmas.ads (pm): New debug routine. + (Set_Finalize_Address): New routine. + * s-stposu.adb (Allocate_Any_Controlled): Code reformatting. + +2011-08-29 Tristan Gingold + + * a-exexpr-gcc.adb (GCC_Exception_Access, GNAT_GCC_Exception_Access): + Remove convention C. + +2011-08-29 Tristan Gingold + + * s-taprop-vms.adb (Get_Exc_Stack_Addr): Remove. + (Initialize_TCB): Remove Exc_Stack_Ptr initialization. + (Finalize_TCB): Remove its finalization. + (Initialize): Remove assignment of GET_Exc_Stack_Addr + * s-soflin.adb (NT_Exc_Stack): Remove + (Get_Exc_Stack_Addr_NT): Likewise. + (Get_Exc_Stack_Addr_Soft): Likewise. + * s-soflin.ads (Get_Exc_Stack_Addr_NT): Remove. + (Get_Exc_Stack_Addr): Likewise. + (Get_Exc_Stack_Addr_Soft): Likewise + * s-taspri-vms.ads (Exc_Stack_T): Remove. + (Exc_Stack_Ptr_T): Likewise. + (Private_Data): Remove Exc_Stack_Ptr component. + +2011-08-29 Tristan Gingold + + * raise-gcc.c (get_ip_from_context): New function. Factorize code. + +2011-08-29 Tristan Gingold + + * gnat_ugn.texi: Fix aix and x86-solaris info for run-time. + +2011-08-29 Geert Bosch + + * s-gearop.ads (Back_Substitute, Diagonal, Forward_Eliminate, + L2_Norm, Swap_Column): New generic subprograms + * s-gearop.adb (Back_Substitute, Diagonal, Forward_Eliminate, + L2_Norm, Swap_Column): Implement new subprograms in order to + eliminate dependency on BLAS and LAPACK libraries in + Ada.Numerics.Generic_Real_Arrays and eventually also the complex + version. Forward_Eliminate/Back_Substitute can be used to put a + matrix in row echelon or reduced row echelon form using partial + pivoting. + * a-ngrear.adb: (Back_Substitute, Diagonal, Forward_Eleminate, + Swap_Column): Instantiate from System.Generic_Array_Operations. + ("*", "abs"): Implement by instantiation from Generic_Array_Operations. + (Sqrt): Local function for simple computation of square root without + adding dependencies on Generic_Elementary_Functions. + (Swap): New subprogram to exchange floating point numbers. + (Inverse): Reimplement using Jordan-Gauss elimination. + (Jacobi): New procedure implementing Jacobi's method for computation + of eigensystems, based on Rutishauser's implementation. + (L2_Norm): Implement directly using the inner product. + (Sort_Eigensystem): Sort eigenvalue/eigenvector pairs in order of + decreasing eigenvalue as required by the Ada RM. + (Swap_Column): New helper procedure for Sort_Eigensystem. + Remove with of System.Generic_Real_BLAS and System.Generic_Real_LAPACK. + Add with of Ada.Containers.Generic_Anonymous_Array_Sort, for + Sort_Eigensystems. + +2011-08-29 Thomas Quinot + + * put_scos.adb (Put_SCOs): Do not emit a newline for an empty + statements line. + 2011-08-29 Hristian Kirtchev * s-finmas.adb (Finalize): Check Finalize_Address of the master rather diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb index 7a460e07738..1f11227c971 100644 --- a/gcc/ada/a-exexpr-gcc.adb +++ b/gcc/ada/a-exexpr-gcc.adb @@ -119,8 +119,8 @@ package body Exception_Propagation is -- alignment below. type GCC_Exception_Access is access all Unwind_Exception; - pragma Convention (C, GCC_Exception_Access); - -- Pointer to a GCC exception + -- Pointer to a GCC exception. Do not use convention C as on VMS this + -- would imply the use of 32-bits pointers. procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); @@ -166,7 +166,6 @@ package body Exception_Propagation is -- to maintain anyway. type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; - pragma Convention (C, GNAT_GCC_Exception_Access); function To_GCC_Exception is new Unchecked_Conversion (GNAT_GCC_Exception_Access, GCC_Exception_Access); diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb index 5c8a0092477..b21f839588e 100644 --- a/gcc/ada/a-ngrear.adb +++ b/gcc/ada/a-ngrear.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2011, 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- -- @@ -29,51 +29,154 @@ -- -- ------------------------------------------------------------------------------ +-- This version of Generic_Real_Arrays avoids the use of BLAS and LAPACK. One +-- reason for this is new Ada 2012 requirements that prohibit algorithms such +-- as Strassen's algorithm, which may be used by some BLAS implementations. In +-- addition, some platforms lacked suitable compilers to compile the reference +-- BLAS/LAPACK implementation. Finally, on many platforms there may be more +-- floating point types than supported by BLAS/LAPACK. + +with Ada.Containers.Generic_Anonymous_Array_Sort; use Ada.Containers; + with System; use System; -with System.Generic_Real_BLAS; -with System.Generic_Real_LAPACK; with System.Generic_Array_Operations; use System.Generic_Array_Operations; package body Ada.Numerics.Generic_Real_Arrays is - -- Operations involving inner products use BLAS library implementations. - -- This allows larger matrices and vectors to be computed efficiently, - -- taking into account memory hierarchy issues and vector instructions - -- that vary widely between machines. - - -- Operations that are defined in terms of operations on the type Real, - -- such as addition, subtraction and scaling, are computed in the canonical - -- way looping over all elements. - - -- Operations for solving linear systems and computing determinant, - -- eigenvalues, eigensystem and inverse, are implemented using the - -- LAPACK library. + package Ops renames System.Generic_Array_Operations; - package BLAS is - new Generic_Real_BLAS (Real'Base, Real_Vector, Real_Matrix); + function Is_Non_Zero (X : Real'Base) return Boolean is (X /= 0.0); - package LAPACK is - new Generic_Real_LAPACK (Real'Base, Real_Vector, Real_Matrix); + procedure Back_Substitute is new Ops.Back_Substitute + (Scalar => Real'Base, + Matrix => Real_Matrix, + Is_Non_Zero => Is_Non_Zero); - use BLAS, LAPACK; + function Diagonal is new Ops.Diagonal + (Scalar => Real'Base, + Vector => Real_Vector, + Matrix => Real_Matrix); - -- Procedure versions of functions returning unconstrained values. - -- This allows for inlining the function wrapper. + procedure Forward_Eliminate is new Ops.Forward_Eliminate + (Scalar => Real'Base, + Matrix => Real_Matrix, + Zero => 0.0, + One => 1.0); - procedure Eigenvalues (A : Real_Matrix; Values : out Real_Vector); - procedure Inverse (A : Real_Matrix; R : out Real_Matrix); - procedure Solve (A : Real_Matrix; X : Real_Vector; B : out Real_Vector); - procedure Solve (A : Real_Matrix; X : Real_Matrix; B : out Real_Matrix); + procedure Swap_Column is new Ops.Swap_Column + (Scalar => Real'Base, + Matrix => Real_Matrix); - procedure Transpose is new - Generic_Array_Operations.Transpose + procedure Transpose is new Ops.Transpose (Scalar => Real'Base, Matrix => Real_Matrix); + function Is_Symmetric (A : Real_Matrix) return Boolean is + (Transpose (A) = A); + -- Return True iff A is symmetric, see RM G.3.1 (90). + + function Is_Tiny (Value, Compared_To : Real) return Boolean is + (abs Compared_To + 100.0 * abs (Value) = abs Compared_To); + -- Return True iff the Value is much smaller in magnitude than the least + -- significant digit of Compared_To. + + procedure Jacobi + (A : Real_Matrix; + Values : out Real_Vector; + Vectors : out Real_Matrix; + Compute_Vectors : Boolean := True); + -- Perform Jacobi's eigensystem algorithm on real symmetric matrix A + + function Length is new Square_Matrix_Length (Real'Base, Real_Matrix); -- Helper function that raises a Constraint_Error is the argument is -- not a square matrix, and otherwise returns its length. - function Length is new Square_Matrix_Length (Real'Base, Real_Matrix); + procedure Rotate (X, Y : in out Real; Sin, Tau : Real); + -- Perform a Givens rotation + + procedure Sort_Eigensystem + (Values : in out Real_Vector; + Vectors : in out Real_Matrix); + -- Sort Values and associated Vectors by decreasing absolute value + + procedure Swap (Left, Right : in out Real); + -- Exchange Left and Right. + + function Sqrt (X : Real) return Real; + -- Sqrt is implemented locally here, in order to avoid dragging in all of + -- the elementary functions. Speed of the square root is not a big concern + -- here. This also avoids depending on a specific floating point type. + + ------------ + -- Rotate -- + ------------ + + procedure Rotate (X, Y : in out Real; Sin, Tau : Real) is + Old_X : constant Real := X; + Old_Y : constant Real := Y; + begin + X := Old_X - Sin * (Old_Y + Old_X * Tau); + Y := Old_Y + Sin * (Old_X - Old_Y * Tau); + end Rotate; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Real) return Real is + Root, Next : Real; + + begin + -- Be defensive: any comparisons with NaN values will yield False. + + if not (X > 0.0) then + if X = 0.0 then + return X; + + else + raise Argument_Error; + end if; + end if; + + -- Compute an initial estimate based on: + + -- X = M * R**E and Sqrt (X) = Sqrt (M) * R**(E / 2.0), + + -- where M is the mantissa, R is the radix and E the exponent. + + -- By ignoring the mantissa and ignoring the case of an odd + -- exponent, we get a final error that is at most R. In other words, + -- the result has about a single bit precision. + + Root := Real (Real'Machine_Radix) ** (Real'Exponent (X) / 2); + + -- Because of the poor initial estimate, use the Babylonian method of + -- computing the square root, as it is stable for all inputs. Every step + -- will roughly double the precision of the result. Just a few steps + -- suffice in most cases. Eight iterations should give about 2**8 bits + -- of precision. + + for J in 1 .. 8 loop + Next := (Root + X / Root) / 2.0; + + exit when Root = Next; + + Root := Next; + end loop; + + return Root; + end Sqrt; + + ---------- + -- Swap -- + ---------- + + procedure Swap (Left, Right : in out Real) is + Temp : constant Real := Left; + begin + Left := Right; + Right := Temp; + end Swap; -- Instantiating the following subprograms directly would lead to -- name clashes, so use a local package. @@ -197,6 +300,45 @@ package body Ada.Numerics.Generic_Real_Arrays is Right_Vector => Real_Vector, Matrix => Real_Matrix); + function "*" is new + Inner_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Right_Vector => Real_Vector, + Zero => 0.0); + + function "*" is new + Matrix_Vector_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Matrix => Real_Matrix, + Right_Vector => Real_Vector, + Result_Vector => Real_Vector, + Zero => 0.0); + + function "*" is new + Vector_Matrix_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Matrix => Real_Matrix, + Result_Vector => Real_Vector, + Zero => 0.0); + + function "*" is new + Matrix_Matrix_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Matrix => Real_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Zero => 0.0); + function "/" is new Vector_Scalar_Elementwise_Operation (Left_Scalar => Real'Base, @@ -215,6 +357,13 @@ package body Ada.Numerics.Generic_Real_Arrays is Result_Matrix => Real_Matrix, Operation => "/"); + function "abs" is new + L2_Norm + (Scalar => Real'Base, + Vector => Real_Vector, + Inner_Product => "*", + Sqrt => Sqrt); + function "abs" is new Vector_Elementwise_Operation (X_Scalar => Real'Base, @@ -299,90 +448,22 @@ package body Ada.Numerics.Generic_Real_Arrays is -- Vector multiplication - function "*" (Left, Right : Real_Vector) return Real'Base is - begin - if Left'Length /= Right'Length then - raise Constraint_Error with - "vectors are of different length in inner product"; - end if; - - return dot (Left'Length, X => Left, Y => Right); - end "*"; + function "*" (Left, Right : Real_Vector) return Real'Base + renames Instantiations."*"; function "*" (Left, Right : Real_Vector) return Real_Matrix renames Instantiations."*"; - function "*" - (Left : Real_Vector; - Right : Real_Matrix) return Real_Vector - is - R : Real_Vector (Right'Range (2)); - - begin - if Left'Length /= Right'Length (1) then - raise Constraint_Error with - "incompatible dimensions in vector-matrix multiplication"; - end if; - - gemv (Trans => No_Trans'Access, - M => Right'Length (2), - N => Right'Length (1), - A => Right, - Ld_A => Right'Length (2), - X => Left, - Y => R); - - return R; - end "*"; - - function "*" - (Left : Real_Matrix; - Right : Real_Vector) return Real_Vector - is - R : Real_Vector (Left'Range (1)); - - begin - if Left'Length (2) /= Right'Length then - raise Constraint_Error with - "incompatible dimensions in matrix-vector multiplication"; - end if; - - gemv (Trans => Trans'Access, - M => Left'Length (2), - N => Left'Length (1), - A => Left, - Ld_A => Left'Length (2), - X => Right, - Y => R); + function "*" (Left : Real_Vector; Right : Real_Matrix) return Real_Vector + renames Instantiations."*"; - return R; - end "*"; + function "*" (Left : Real_Matrix; Right : Real_Vector) return Real_Vector + renames Instantiations."*"; -- Matrix Multiplication - function "*" (Left, Right : Real_Matrix) return Real_Matrix is - R : Real_Matrix (Left'Range (1), Right'Range (2)); - - begin - if Left'Length (2) /= Right'Length (1) then - raise Constraint_Error with - "incompatible dimensions in matrix-matrix multiplication"; - end if; - - gemm (Trans_A => No_Trans'Access, - Trans_B => No_Trans'Access, - M => Right'Length (2), - N => Left'Length (1), - K => Right'Length (1), - A => Right, - Ld_A => Right'Length (2), - B => Left, - Ld_B => Left'Length (2), - C => R, - Ld_C => R'Length (2)); - - return R; - end "*"; + function "*" (Left, Right : Real_Matrix) return Real_Matrix + renames Instantiations."*"; --------- -- "/" -- @@ -398,10 +479,8 @@ package body Ada.Numerics.Generic_Real_Arrays is -- "abs" -- ----------- - function "abs" (Right : Real_Vector) return Real'Base is - begin - return nrm2 (Right'Length, Right); - end "abs"; + function "abs" (Right : Real_Vector) return Real'Base + renames Instantiations."abs"; function "abs" (Right : Real_Vector) return Real_Vector renames Instantiations."abs"; @@ -414,29 +493,14 @@ package body Ada.Numerics.Generic_Real_Arrays is ----------------- function Determinant (A : Real_Matrix) return Real'Base is - N : constant Integer := Length (A); - LU : Real_Matrix (1 .. N, 1 .. N) := A; - Piv : Integer_Vector (1 .. N); - Info : aliased Integer := -1; - Det : Real := 1.0; + M : Real_Matrix := A; + B : Real_Matrix (A'Range (1), 1 .. 0); + R : Real'Base; begin - getrf (M => N, - N => N, - A => LU, - Ld_A => N, - I_Piv => Piv, - Info => Info'Access); - - if Info /= 0 then - raise Constraint_Error with "ill-conditioned matrix"; - end if; + Forward_Eliminate (M, B, R); - for J in 1 .. N loop - Det := (if Piv (J) /= J then -Det * LU (J, J) else Det * LU (J, J)); - end loop; - - return Det; + return R; end Determinant; ----------------- @@ -448,306 +512,319 @@ package body Ada.Numerics.Generic_Real_Arrays is Values : out Real_Vector; Vectors : out Real_Matrix) is - N : constant Natural := Length (A); - Tau : Real_Vector (1 .. N); - L_Work : Real_Vector (1 .. 1); - Info : aliased Integer; - - E : Real_Vector (1 .. N); - pragma Warnings (Off, E); - begin - if Values'Length /= N then - raise Constraint_Error with "wrong length for output vector"; - end if; - - if N = 0 then - return; - end if; - - -- Initialize working matrix and check for symmetric input matrix - - Transpose (A, Vectors); + Jacobi (A, Values, Vectors, Compute_Vectors => True); + Sort_Eigensystem (Values, Vectors); + end Eigensystem; - if A /= Vectors then - raise Argument_Error with "matrix not symmetric"; - end if; + ----------------- + -- Eigenvalues -- + ----------------- - -- Compute size of additional working space + function Eigenvalues (A : Real_Matrix) return Real_Vector is + Values : Real_Vector (A'Range (1)); + Vectors : Real_Matrix (1 .. 0, 1 .. 0); + begin + Jacobi (A, Values, Vectors, Compute_Vectors => False); + Sort_Eigensystem (Values, Vectors); - sytrd (Uplo => Lower'Access, - N => N, - A => Vectors, - Ld_A => N, - D => Values, - E => E, - Tau => Tau, - Work => L_Work, - L_Work => -1, - Info => Info'Access); + return Values; + end Eigenvalues; - declare - Work : Real_Vector (1 .. Integer'Max (Integer (L_Work (1)), 2 * N)); - pragma Warnings (Off, Work); + ------------- + -- Inverse -- + ------------- - Comp_Z : aliased constant Character := 'V'; + function Inverse (A : Real_Matrix) return Real_Matrix is + (Solve (A, Unit_Matrix (Length (A)))); - begin - -- Reduce matrix to tridiagonal form - - sytrd (Uplo => Lower'Access, - N => N, - A => Vectors, - Ld_A => A'Length (1), - D => Values, - E => E, - Tau => Tau, - Work => Work, - L_Work => Work'Length, - Info => Info'Access); - - if Info /= 0 then - raise Program_Error; - end if; + ------------ + -- Jacobi -- + ------------ - -- Generate the real orthogonal matrix determined by sytrd + procedure Jacobi + (A : Real_Matrix; + Values : out Real_Vector; + Vectors : out Real_Matrix; + Compute_Vectors : Boolean := True) + is + -- This subprogram uses Carl Gustav Jacob Jacobi's iterative method + -- for computing eigenvalues and eigenvectors and is based on + -- Rutishauser's implementation. - orgtr (Uplo => Lower'Access, - N => N, - A => Vectors, - Ld_A => N, - Tau => Tau, - Work => Work, - L_Work => Work'Length, - Info => Info'Access); + -- The given real symmetric matrix is transformed iteratively to + -- diagonal form through a sequence of appropriately chosen elementary + -- orthogonal transformations, called Jacobi rotations here. - if Info /= 0 then - raise Program_Error; - end if; + -- The Jacobi method produces a systematic decrease of the sum of the + -- squares of off-diagonal elements. Convergence to zero is quadratic, + -- both for this implementation, as for the classic method that doesn't + -- use row-wise scanning for pivot selection. - -- Compute all eigenvalues and eigenvectors using QR algorithm + -- The numerical stability and accuracy of Jacobi's method make it the + -- best choice here, even though for large matrices other methods will + -- be significantly more efficient in both time and space. - steqr (Comp_Z => Comp_Z'Access, - N => N, - D => Values, - E => E, - Z => Vectors, - Ld_Z => N, - Work => Work, - Info => Info'Access); + -- While the eigensystem computations are absolutely foolproof for all + -- real symmetric matrices, in presence of invalid values, or similar + -- exceptional situations it might not. In such cases the results cannot + -- be trusted and Constraint_Error is raised. - if Info /= 0 then - raise Constraint_Error with - "eigensystem computation failed to converge"; - end if; - end; - end Eigensystem; + -- Note: this implementation needs temporary storage for 2 * N + N**2 + -- values of type Real. - ----------------- - -- Eigenvalues -- - ----------------- + Max_Iterations : constant := 50; - procedure Eigenvalues - (A : Real_Matrix; - Values : out Real_Vector) - is - N : constant Natural := Length (A); - L_Work : Real_Vector (1 .. 1); - Info : aliased Integer; + N : constant Natural := Length (A); - B : Real_Matrix (1 .. N, 1 .. N); - Tau : Real_Vector (1 .. N); - E : Real_Vector (1 .. N); - pragma Warnings (Off, B); - pragma Warnings (Off, Tau); - pragma Warnings (Off, E); + subtype Square_Matrix is Real_Matrix (1 .. N, 1 .. N); - begin - if Values'Length /= N then - raise Constraint_Error with "wrong length for output vector"; - end if; + -- In order to annihilate the M (Row, Col) element, the + -- rotation parameters Cos and Sin are computed as + -- follows: - if N = 0 then - return; - end if; + -- Theta = Cot (2.0 * Phi) + -- = (Diag (Col) - Diag (Row)) / (2.0 * M (Row, Col)) - -- Initialize working matrix and check for symmetric input matrix + -- Then Tan (Phi) as the smaller root (in modulus) of - Transpose (A, B); + -- T**2 + 2 * T * Theta = 1 (or 0.5 / Theta, if Theta is large) - if A /= B then - raise Argument_Error with "matrix not symmetric"; - end if; + function Compute_Tan (Theta : Real) return Real is + (Real'Copy_Sign (1.0 / (abs Theta + Sqrt (1.0 + Theta**2)), Theta)); - -- Find size of work area + function Compute_Tan (P, H : Real) return Real is + (if Is_Tiny (P, Compared_To => H) then P / H + else Compute_Tan (Theta => H / (2.0 * P))); - sytrd (Uplo => Lower'Access, - N => N, - A => B, - Ld_A => N, - D => Values, - E => E, - Tau => Tau, - Work => L_Work, - L_Work => -1, - Info => Info'Access); + function Sum_Strict_Upper (M : Square_Matrix) return Real; + -- Return the sum of all elements in the strict upper triangle of M - declare - Work : Real_Vector (1 .. Integer'Min (Integer (L_Work (1)), 4 * N)); - pragma Warnings (Off, Work); + ---------------------- + -- Sum_Strict_Upper -- + ---------------------- + function Sum_Strict_Upper (M : Square_Matrix) return Real is + Sum : Real := 0.0; begin - -- Reduce matrix to tridiagonal form - - sytrd (Uplo => Lower'Access, - N => N, - A => B, - Ld_A => A'Length (1), - D => Values, - E => E, - Tau => Tau, - Work => Work, - L_Work => Work'Length, - Info => Info'Access); - - if Info /= 0 then - raise Constraint_Error; - end if; - - -- Compute all eigenvalues using QR algorithm - - sterf (N => N, - D => Values, - E => E, - Info => Info'Access); - - if Info /= 0 then - raise Constraint_Error with - "eigenvalues computation failed to converge"; - end if; - end; - end Eigenvalues; - - function Eigenvalues (A : Real_Matrix) return Real_Vector is - R : Real_Vector (A'Range (1)); - begin - Eigenvalues (A, R); - return R; - end Eigenvalues; - - ------------- - -- Inverse -- - ------------- - - procedure Inverse (A : Real_Matrix; R : out Real_Matrix) is - N : constant Integer := Length (A); - Piv : Integer_Vector (1 .. N); - L_Work : Real_Vector (1 .. 1); - Info : aliased Integer := -1; + for Row in 1 .. N - 1 loop + for Col in Row + 1 .. N loop + Sum := Sum + abs M (Row, Col); + end loop; + end loop; + + return Sum; + end Sum_Strict_Upper; + + M : Square_Matrix := A; -- Work space for solving eigensystem + Threshold : Real; + Sum : Real; + Diag : Real_Vector (1 .. N); + Diag_Adj : Real_Vector (1 .. N); + + -- The vector Diag_Adj indicates the amount of change in each value, + -- while Diag tracks the value itself and Values holds the values as + -- they were at the beginning. As the changes typically will be small + -- compared to the absolute value of Diag, at the end of each iteration + -- Diag is computed as Diag + Diag_Adj thus avoiding accumulating + -- rounding errors. This technique is due to Rutishauser. begin - -- All computations are done using column-major order, but this works - -- out fine, because Transpose (Inverse (Transpose (A))) = Inverse (A). - - R := A; + if Compute_Vectors + and then (Vectors'Length (1) /= N or else Vectors'Length (2) /= N) + then + raise Constraint_Error with "incompatible matrix dimensions"; - -- Compute LU decomposition + elsif Values'Length /= N then + raise Constraint_Error with "incompatible vector length"; - getrf (M => N, - N => N, - A => R, - Ld_A => N, - I_Piv => Piv, - Info => Info'Access); + elsif not Is_Symmetric (M) then + raise Constraint_Error with "matrix not symmetric"; + end if; - if Info /= 0 then - raise Constraint_Error with "inverting singular matrix"; + -- Note: Only the locally declared matrix M and vectors (Diag, Diag_Adj) + -- have lower bound equal to 1. The Vectors matrix may have + -- different bounds, so take care indexing elements. Assignment + -- as a whole is fine as sliding is automatic in that case. + + Vectors := (if not Compute_Vectors then (1 .. 0 => (1 .. 0 => 0.0)) + else Unit_Matrix (Vectors'Length (1), Vectors'Length (2))); + Values := Diagonal (M); + + Sweep : for Iteration in 1 .. Max_Iterations loop + + -- The first three iterations, perform rotation for any non-zero + -- element. After this, rotate only for those that are not much + -- smaller than the average off-diagnal element. After the fifth + -- iteration, additionally zero out off-diagonal elements that are + -- very small compared to elements on the diagonal with the same + -- column or row index. + + Sum := Sum_Strict_Upper (M); + + exit Sweep when Sum = 0.0; + + Threshold := (if Iteration < 4 then 0.2 * Sum / Real (N**2) else 0.0); + + -- Iterate over all off-diagonal elements, rotating any that have + -- an absolute value that exceeds the threshold. + + Diag := Values; + Diag_Adj := (others => 0.0); -- Accumulates adjustments to Diag + + for Row in 1 .. N - 1 loop + for Col in Row + 1 .. N loop + + -- If, before the rotation M (Row, Col) is tiny compared to + -- Diag (Row) and Diag (Col), rotation is skipped. This is + -- meaningful, as it produces no larger error than would be + -- produced anyhow if the rotation had been performed. + -- Suppress this optimization in the first four sweeps, so + -- that this procedure can be used for computing eigenvectors + -- of perturbed diagonal matrices. + + if Iteration > 4 + and then Is_Tiny (M (Row, Col), Compared_To => Diag (Row)) + and then Is_Tiny (M (Row, Col), Compared_To => Diag (Col)) + then + M (Row, Col) := 0.0; + + elsif abs M (Row, Col) > Threshold then + Perform_Rotation : declare + Tan : constant Real := Compute_Tan (M (Row, Col), + Diag (Col) - Diag (Row)); + Cos : constant Real := 1.0 / Sqrt (1.0 + Tan**2); + Sin : constant Real := Tan * Cos; + Tau : constant Real := Sin / (1.0 + Cos); + Adj : constant Real := Tan * M (Row, Col); + + begin + Diag_Adj (Row) := Diag_Adj (Row) - Adj; + Diag_Adj (Col) := Diag_Adj (Col) + Adj; + Diag (Row) := Diag (Row) - Adj; + Diag (Col) := Diag (Col) + Adj; + + M (Row, Col) := 0.0; + + for J in 1 .. Row - 1 loop -- 1 <= J < Row + Rotate (M (J, Row), M (J, Col), Sin, Tau); + end loop; + + for J in Row + 1 .. Col - 1 loop -- Row < J < Col + Rotate (M (Row, J), M (J, Col), Sin, Tau); + end loop; + + for J in Col + 1 .. N loop -- Col < J <= N + Rotate (M (Row, J), M (Col, J), Sin, Tau); + end loop; + + for J in Vectors'Range (1) loop + Rotate (Vectors (J, Row - 1 + Vectors'First (2)), + Vectors (J, Col - 1 + Vectors'First (2)), + Sin, Tau); + end loop; + end Perform_Rotation; + end if; + end loop; + end loop; + + Values := Values + Diag_Adj; + end loop Sweep; + + -- All normal matrices with valid values should converge perfectly. + + if Sum /= 0.0 then + raise Constraint_Error with "eigensystem solution does not converge"; end if; + end Jacobi; - -- Determine size of work area + ----------- + -- Solve -- + ----------- - getri (N => N, - A => R, - Ld_A => N, - I_Piv => Piv, - Work => L_Work, - L_Work => -1, - Info => Info'Access); + function Solve (A : Real_Matrix; X : Real_Vector) return Real_Vector is + N : constant Natural := Length (A); + MA : Real_Matrix := A; + MX : Real_Matrix (A'Range (1), 1 .. 1); + R : Real_Vector (A'Range (2)); + Det : Real'Base; - if Info /= 0 then - raise Constraint_Error; + begin + if X'Length /= N then + raise Constraint_Error with "incompatible vector length"; end if; - declare - Work : Real_Vector (1 .. Integer (L_Work (1))); - pragma Warnings (Off, Work); + for J in 0 .. MX'Length (1) - 1 loop + MX (MX'First (1) + J, 1) := X (X'First + J); + end loop; - begin - -- Compute inverse from LU decomposition - - getri (N => N, - A => R, - Ld_A => N, - I_Piv => Piv, - Work => Work, - L_Work => Work'Length, - Info => Info'Access); - - if Info /= 0 then - raise Constraint_Error with "inverting singular matrix"; - end if; + Forward_Eliminate (MA, MX, Det); + Back_Substitute (MA, MX); - -- ??? Should iterate with gerfs, based on implementation advice - end; - end Inverse; + for J in 0 .. R'Length - 1 loop + R (R'First + J) := MX (MX'First (1) + J, 1); + end loop; - function Inverse (A : Real_Matrix) return Real_Matrix is - R : Real_Matrix (A'Range (2), A'Range (1)); - begin - Inverse (A, R); return R; - end Inverse; + end Solve; - ----------- - -- Solve -- - ----------- + function Solve (A, X : Real_Matrix) return Real_Matrix is + N : constant Natural := Length (A); + MA : Real_Matrix (A'Range (2), A'Range (2)); + MB : Real_Matrix (A'Range (2), X'Range (2)); + Det : Real'Base; - procedure Solve (A : Real_Matrix; X : Real_Vector; B : out Real_Vector) is begin - if Length (A) /= X'Length then - raise Constraint_Error with - "incompatible matrix and vector dimensions"; + if X'Length (1) /= N then + raise Constraint_Error with "matrices have unequal number of rows"; end if; - -- ??? Should solve directly, is faster and more accurate + for J in 0 .. A'Length (1) - 1 loop + for K in MA'Range (2) loop + MA (MA'First (1) + J, K) := A (A'First (1) + J, K); + end loop; + + for K in MB'Range (2) loop + MB (MB'First (1) + J, K) := X (X'First (1) + J, K); + end loop; + end loop; + + Forward_Eliminate (MA, MB, Det); + Back_Substitute (MA, MB); - B := Inverse (A) * X; + return MB; end Solve; - procedure Solve (A : Real_Matrix; X : Real_Matrix; B : out Real_Matrix) is - begin - if Length (A) /= X'Length (1) then - raise Constraint_Error with "incompatible matrix dimensions"; - end if; + ---------------------- + -- Sort_Eigensystem -- + ---------------------- - -- ??? Should solve directly, is faster and more accurate + procedure Sort_Eigensystem + (Values : in out Real_Vector; + Vectors : in out Real_Matrix) + is - B := Inverse (A) * X; - end Solve; + procedure Swap (Left, Right : Integer); + -- Swap Values (Left) with Values (Right), and also swap the + -- corresponding eigenvectors. Note that lowerbounds may differ. - function Solve (A : Real_Matrix; X : Real_Vector) return Real_Vector is - B : Real_Vector (A'Range (2)); - begin - Solve (A, X, B); - return B; - end Solve; + function Less (Left, Right : Integer) return Boolean is + (Values (Left) > Values (Right)); + -- Sort by decreasing eigenvalue, see RM G.3.1 (76). + + procedure Sort is new Generic_Anonymous_Array_Sort (Integer); + -- Sorts eigenvalues and eigenvectors by decreasing value + + procedure Swap (Left, Right : Integer) is + begin + Swap (Values (Left), Values (Right)); + Swap_Column (Vectors, Left - Values'First + Vectors'First (2), + Right - Values'First + Vectors'First (2)); + end Swap; - function Solve (A, X : Real_Matrix) return Real_Matrix is - B : Real_Matrix (A'Range (2), X'Range (2)); begin - Solve (A, X, B); - return B; - end Solve; + Sort (Values'First, Values'Last); + end Sort_Eigensystem; --------------- -- Transpose -- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 637e544bcea..c4957222e7d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1042,6 +1042,24 @@ package body Exp_Ch4 is Prefix => New_Reference_To (Temp, Loc))), Typ => T)); end if; + + -- Generate: + -- Set_Finalize_Address (FM, FD'Unrestricted_Access); + + -- Since .NET/JVM compilers do not support address arithmetic, + -- this call is skipped. The same is done for CodePeer because + -- primitive Finalize_Address is never generated. + + if VM_Target = No_VM + and then not CodePeer_Mode + and then Present (Finalization_Master (PtrT)) + then + Insert_Action (N, + Make_Set_Finalize_Address_Call + (Loc => Loc, + Typ => T, + Ptr_Typ => PtrT)); + end if; end if; Rewrite (N, New_Reference_To (Temp, Loc)); @@ -3342,9 +3360,13 @@ package body Exp_Ch4 is if Ekind (PtrT) = E_Anonymous_Access_Type and then Needs_Finalization (Dtyp) then - -- Anonymous access-to-controlled types allocate on the global pool + -- Anonymous access-to-controlled types allocate on the global pool. + -- Do not set this attribute on .NET/JVM since those targets do not + -- support pools. - if No (Associated_Storage_Pool (PtrT)) then + if No (Associated_Storage_Pool (PtrT)) + and then VM_Target = No_VM + then Set_Associated_Storage_Pool (PtrT, Get_Global_Pool_For_Access_Type (PtrT)); end if; @@ -3828,22 +3850,39 @@ package body Exp_Ch4 is (Obj_Ref => New_Copy_Tree (Init_Arg1), Typ => T)); - -- Special processing for .NET/JVM, the allocated object is - -- attached to the finalization master. Generate: + if Present (Finalization_Master (PtrT)) then - -- Attach (FC, Root_Controlled_Ptr (Init_Arg1)); + -- Special processing for .NET/JVM, the allocated object + -- is attached to the finalization master. Generate: - -- Types derived from [Limited_]Controlled are the only - -- ones considered since they have fields Prev and Next. + -- Attach (FM, Root_Controlled_Ptr (Init_Arg1)); - if VM_Target /= No_VM - and then Present (Finalization_Master (PtrT)) - and then Is_Controlled (T) - then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Copy_Tree (Init_Arg1), - Ptr_Typ => PtrT)); + -- Types derived from [Limited_]Controlled are the only + -- ones considered since they have fields Prev and Next. + + if VM_Target /= No_VM + and then Is_Controlled (T) + then + Insert_Action (N, + Make_Attach_Call + (Obj_Ref => New_Copy_Tree (Init_Arg1), + Ptr_Typ => PtrT)); + + -- Default case, generate: + + -- Set_Finalize_Address + -- (FM, FD'Unrestricted_Access); + + -- Do not generate the above for CodePeer compilations + -- because primitive Finalize_Address is never built. + + elsif not CodePeer_Mode then + Insert_Action (N, + Make_Set_Finalize_Address_Call + (Loc => Loc, + Typ => T, + Ptr_Typ => PtrT)); + end if; end if; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 49e471d5f03..8073ff568fd 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7155,6 +7155,33 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Return_Object => Empty); end if; + -- If the build-in-place function call returns a controlled object, + -- the finalization master will require a reference to routine + -- Finalize_Address of the designated type. Setting this attribute + -- is done in the same manner to expansion of allocators. + + if Needs_Finalization (Result_Subt) then + + -- Controlled types with supressed finalization do not need to + -- associate the address of their Finalize_Address primitives with + -- a master since they do not need a master to begin with. + + if Is_Library_Level_Entity (Acc_Type) + and then Finalize_Storage_Only (Result_Subt) + then + null; + + -- Do not generate the call to Make_Set_Finalize_Address for + -- CodePeer compilations because Finalize_Address is never built. + + elsif not CodePeer_Mode then + Insert_Action (Allocator, + Make_Set_Finalize_Address_Call (Loc, + Typ => Etype (Function_Id), + Ptr_Typ => Acc_Type)); + end if; + end if; + -- Finally, replace the allocator node with a reference to the result -- of the function call itself (which will effectively be an access -- to the object created by the allocator). diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index c0c73feb715..62d316631e0 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -7435,6 +7435,83 @@ package body Exp_Ch7 is Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True))); end Make_Local_Deep_Finalize; + ------------------------------------ + -- Make_Set_Finalize_Address_Call -- + ------------------------------------ + + function Make_Set_Finalize_Address_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Ptr_Typ : Entity_Id) return Node_Id + is + Desig_Typ : constant Entity_Id := + Available_View (Designated_Type (Ptr_Typ)); + Utyp : Entity_Id; + + begin + -- If the context is a class-wide allocator, we use the class-wide type + -- to obtain the proper Finalize_Address routine. + + if Is_Class_Wide_Type (Desig_Typ) then + Utyp := Desig_Typ; + + else + Utyp := Typ; + + if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then + Utyp := Full_View (Utyp); + end if; + + if Is_Concurrent_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + + -- Deal with non-tagged derivation of private views. If the parent is + -- now known to be protected, the finalization routine is the one + -- defined on the corresponding record of the ancestor (corresponding + -- records do not automatically inherit operations, but maybe they + -- should???) + + if Is_Untagged_Derivation (Typ) then + if Is_Protected_Type (Typ) then + Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + else + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; + end if; + end if; + + -- If the underlying_type is a subtype, we are dealing with the + -- completion of a private type. We need to access the base type and + -- generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + + Utyp := Base_Type (Utyp); + end if; + + -- Generate: + -- Set_Finalize_Address (FM, FD'Unrestricted_Access); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Set_Finalize_Address), Loc), + Parameter_Associations => New_List ( + New_Reference_To (Finalization_Master (Ptr_Typ), Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc), + Attribute_Name => Name_Unrestricted_Access))); + end Make_Set_Finalize_Address_Call; + -------------------------- -- Make_Transient_Block -- -------------------------- diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index a9fea526c22..1774f69ed78 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -173,6 +173,18 @@ package Exp_Ch7 is -- Create a special version of Deep_Finalize with identifier Nam. The -- routine has state information and can parform partial finalization. + function Make_Set_Finalize_Address_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Ptr_Typ : Entity_Id) return Node_Id; + -- Generate the following call: + -- + -- Set_Finalize_Address (FM, FD'Unrestricted_Access); + -- + -- where Finalize_Address is the corresponding TSS primitive of type Typ + -- and Ptr_Typ is the access type of the related allocation. Loc is the + -- source location of the related allocator. + -------------------------------------------- -- Task and Protected Object finalization -- -------------------------------------------- diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index def9349d4e9..de51c76781e 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21324,6 +21324,10 @@ information about several specific platforms. @item @b{ppc-aix} @item @code{@ @ }@i{rts-native (default)} @item @code{@ @ @ @ }Tasking @tab native AIX threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj} +@item @code{@ @ @ @ }Tasking @tab native AIX threads @item @code{@ @ @ @ }Exceptions @tab SJLJ @* @item @b{ppc-darwin} @@ -21366,6 +21370,10 @@ information about several specific platforms. @item @b{x86-solaris} @item @code{@ @ }@i{rts-native (default)} @item @code{@ @ @ @ }Tasking @tab native Solaris threads +@item @code{@ @ @ @ }Exceptions @tab ZCX +@* +@item @code{@ @ }@i{rts-sjlj} +@item @code{@ @ @ @ }Tasking @tab native Solaris threads library @item @code{@ @ @ @ }Exceptions @tab SJLJ @* @item @b{x86-windows} diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index 95c4609a9a3..4706c0045b1 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -178,7 +178,9 @@ begin pragma Assert (SCO_Table.Table (Start).C1 = 's'); end loop; - Write_Info_Terminate; + if Ctr > 0 then + Write_Info_Terminate; + end if; -- Statement continuations should not occur since they -- are supposed to have been handled in the loop above. diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 6dff0dee205..af4a5e5091d 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -130,7 +130,7 @@ extern void __gnat_setup_current_excep (_Unwind_Exception *); typedef struct { _Unwind_Action phase; - char * description; + const char * description; } phase_descriptor; static const phase_descriptor phase_descriptors[] @@ -511,8 +511,11 @@ typedef struct } region_descriptor; -static void -db_region_for (region_descriptor *region, _Unwind_Context *uw_context) +/* Extract and adjust the IP (instruction pointer) from an exception + context. */ + +static _Unwind_Ptr +get_ip_from_context (_Unwind_Context *uw_context) { int ip_before_insn = 0; #ifdef HAVE_GETIPINFO @@ -520,12 +523,26 @@ db_region_for (region_descriptor *region, _Unwind_Context *uw_context) #else _Unwind_Ptr ip = _Unwind_GetIP (uw_context); #endif + /* Subtract 1 if necessary because GetIPInfo yields a call return address + in this case, while we are interested in information for the call point. + This does not always yield the exact call instruction address but always + brings the IP back within the corresponding region. */ if (!ip_before_insn) ip--; + return ip; +} + +static void +db_region_for (region_descriptor *region, _Unwind_Context *uw_context) +{ + _Unwind_Ptr ip; + if (! (db_accepted_codes () & DB_REGIONS)) return; + ip = get_ip_from_context (uw_context); + db (DB_REGIONS, "For ip @ 0x%08x => ", ip); if (region->lsda) @@ -651,14 +668,7 @@ typedef struct static void db_action_for (action_descriptor *action, _Unwind_Context *uw_context) { - int ip_before_insn = 0; -#ifdef HAVE_GETIPINFO - _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn); -#else - _Unwind_Ptr ip = _Unwind_GetIP (uw_context); -#endif - if (!ip_before_insn) - ip--; + _Unwind_Ptr ip = get_ip_from_context (uw_context); db (DB_ACTIONS, "For ip @ 0x%08x => ", ip); @@ -706,16 +716,7 @@ get_call_site_action_for (_Unwind_Context *uw_context, region_descriptor *region, action_descriptor *action) { - int ip_before_insn = 0; -#ifdef HAVE_GETIPINFO - _Unwind_Ptr call_site = _Unwind_GetIPInfo (uw_context, &ip_before_insn); -#else - _Unwind_Ptr call_site = _Unwind_GetIP (uw_context); -#endif - /* Subtract 1 if necessary because GetIPInfo returns the actual call site - value + 1 in this case. */ - if (!ip_before_insn) - call_site--; + _Unwind_Ptr call_site = get_ip_from_context (uw_context); /* call_site is a direct index into the call-site table, with two special values : -1 for no-action and 0 for "terminate". The latter should never @@ -772,18 +773,7 @@ get_call_site_action_for (_Unwind_Context *uw_context, action_descriptor *action) { const unsigned char *p = region->call_site_table; - int ip_before_insn = 0; -#ifdef HAVE_GETIPINFO - _Unwind_Ptr ip = _Unwind_GetIPInfo (uw_context, &ip_before_insn); -#else - _Unwind_Ptr ip = _Unwind_GetIP (uw_context); -#endif - /* Subtract 1 if necessary because GetIPInfo yields a call return address - in this case, while we are interested in information for the call point. - This does not always yield the exact call instruction address but always - brings the IP back within the corresponding region. */ - if (!ip_before_insn) - ip--; + _Unwind_Ptr ip = get_ip_from_context (uw_context); /* Unless we are able to determine otherwise... */ action->kind = nothing; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 48f4a33ab07..2a0e2deef62 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -801,6 +801,7 @@ package Rtsfind is RE_Finalization_Master, -- System.Finalization_Masters RE_Finalization_Master_Ptr, -- System.Finalization_Masters RE_Set_Base_Pool, -- System.Finalization_Masters + RE_Set_Finalize_Address, -- System.Finalization_Masters RE_Root_Controlled, -- System.Finalization_Root RE_Root_Controlled_Ptr, -- System.Finalization_Root @@ -1987,6 +1988,7 @@ package Rtsfind is RE_Finalization_Master => System_Finalization_Masters, RE_Finalization_Master_Ptr => System_Finalization_Masters, RE_Set_Base_Pool => System_Finalization_Masters, + RE_Set_Finalize_Address => System_Finalization_Masters, RE_Root_Controlled => System_Finalization_Root, RE_Root_Controlled_Ptr => System_Finalization_Root, diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index 71dbeb8ab34..857db696b00 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -30,7 +30,8 @@ ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; - +with System.Address_Image; +with System.IO; use System.IO; with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; @@ -84,16 +85,16 @@ package body System.Finalization_Masters is procedure Detach (N : not null FM_Node_Ptr) is begin - -- N must be attached to some list - - pragma Assert (N.Next /= null and then N.Prev /= null); - - Lock_Task.all; + if N.Prev /= null and then N.Next /= null then + Lock_Task.all; - N.Prev.Next := N.Next; - N.Next.Prev := N.Prev; + N.Prev.Next := N.Next; + N.Next.Prev := N.Prev; + N.Prev := null; + N.Next := null; - Unlock_Task.all; + Unlock_Task.all; + end if; -- Note: No need to unlock in case of an exception because the above -- code can never raise one. @@ -109,6 +110,20 @@ package body System.Finalization_Masters is Obj_Addr : Address; Raised : Boolean := False; + function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean; + -- Determine whether a list contains only one element, the dummy head + + ------------------- + -- Is_Empty_List -- + ------------------- + + function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is + begin + return L.Next = L and then L.Prev = L; + end Is_Empty_List; + + -- Start of processing for Finalize + begin -- It is possible for multiple tasks to cause the finalization of the -- same master. Let only one task finalize the objects. @@ -124,37 +139,29 @@ package body System.Finalization_Masters is Master.Finalization_Started := True; - -- Skip the dummy head + while not Is_Empty_List (Master.Objects'Unchecked_Access) loop + Curr_Ptr := Master.Objects.Next; - Curr_Ptr := Master.Objects.Next; - while Curr_Ptr /= Master.Objects'Unchecked_Access loop + Detach (Curr_Ptr); - -- If primitive Finalize_Address is not set, then the expansion of - -- the designated type or that of the allocator failed. This is a - -- serious error. - - if Master.Finalize_Address = null then - raise Program_Error - with "primitive Finalize_Address not available"; - end if; + if Master.Finalize_Address /= null then - -- Skip the list header in order to offer proper object layout for - -- finalization and call Finalize_Address. + -- Skip the list header in order to offer proper object layout for + -- finalization and call Finalize_Address. - Obj_Addr := Curr_Ptr.all'Address + Header_Offset; + Obj_Addr := Curr_Ptr.all'Address + Header_Offset; - begin - Master.Finalize_Address (Obj_Addr); + begin + Master.Finalize_Address (Obj_Addr); - exception - when Fin_Occur : others => - if not Raised then - Raised := True; - Save_Occurrence (Ex_Occur, Fin_Occur); - end if; - end; - - Curr_Ptr := Curr_Ptr.Next; + exception + when Fin_Occur : others => + if not Raised then + Raised := True; + Save_Occurrence (Ex_Occur, Fin_Occur); + end if; + end; + end if; end loop; -- If the finalization of a particular object failed or Finalize_Address @@ -195,6 +202,127 @@ package body System.Finalization_Masters is Master.Objects.Prev := Master.Objects'Unchecked_Access; end Initialize; + -------- + -- pm -- + -------- + + procedure pm (Master : Finalization_Master) is + Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; + Head_Seen : Boolean := False; + N_Ptr : FM_Node_Ptr; + + begin + -- Output the basic contents of a master + + -- Master : 0x123456789 + -- Base_Pool: null 0x123456789 + -- Fin_Addr : null 0x123456789 + -- Fin_Start: TRUE FALSE + + Put ("Master : "); + Put_Line (Address_Image (Master'Address)); + + Put ("Base_Pool: "); + + if Master.Base_Pool = null then + Put_Line (" null"); + else + Put_Line (Address_Image (Master.Base_Pool'Address)); + end if; + + Put ("Fin_Addr : "); + + if Master.Finalize_Address = null then + Put_Line ("null"); + else + Put_Line (Address_Image (Master.Finalize_Address'Address)); + end if; + + Put ("Fin_Start: "); + Put_Line (Master.Finalization_Started'Img); + + -- Output all chained elements. The format is the following: + + -- ^ ? null + -- |Header: 0x123456789 (dummy head) + -- | Prev: 0x123456789 + -- | Next: 0x123456789 + -- V + + -- ^ - the current element points back to the correct element + -- ? - the current element points back to an erroneous element + -- n - the current element points back to null + + -- Header - the address of the list header + -- Prev - the address of the list header which the current element + -- - points back to + -- Next - the address of the list header which the current element + -- - points to + -- (dummy head) - present if dummy head + + N_Ptr := Head; + while N_Ptr /= null loop -- Should never be null; we being defensive + Put_Line ("V"); + + -- We see the head initially; we want to exit when we see the head a + -- SECOND time. + + if N_Ptr = Head then + exit when Head_Seen; + + Head_Seen := True; + end if; + + -- The current element is null. This should never happen since the + -- list is circular. + + if N_Ptr.Prev = null then + Put_Line ("null (ERROR)"); + + -- The current element points back to the correct element + + elsif N_Ptr.Prev.Next = N_Ptr then + Put_Line ("^"); + + -- The current element points to an erroneous element + + else + Put_Line ("? (ERROR)"); + end if; + + -- Output the header and fields + + Put ("|Header: "); + Put (Address_Image (N_Ptr.all'Address)); + + -- Detect the dummy head + + if N_Ptr = Head then + Put_Line (" (dummy head)"); + else + Put_Line (""); + end if; + + Put ("| Prev: "); + + if N_Ptr.Prev = null then + Put_Line ("null"); + else + Put_Line (Address_Image (N_Ptr.Prev.all'Address)); + end if; + + Put ("| Next: "); + + if N_Ptr.Next = null then + Put_Line ("null"); + else + Put_Line (Address_Image (N_Ptr.Next.all'Address)); + end if; + + N_Ptr := N_Ptr.Next; + end loop; + end pm; + ------------------- -- Set_Base_Pool -- ------------------- @@ -207,4 +335,16 @@ package body System.Finalization_Masters is Master.Base_Pool := Pool_Ptr; end Set_Base_Pool; + -------------------------- + -- Set_Finalize_Address -- + -------------------------- + + procedure Set_Finalize_Address + (Master : in out Finalization_Master; + Fin_Addr_Ptr : Finalize_Address_Ptr) + is + begin + Master.Finalize_Address := Fin_Addr_Ptr; + end Set_Finalize_Address; + end System.Finalization_Masters; diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads index 3932021b734..87a607678bc 100644 --- a/gcc/ada/s-finmas.ads +++ b/gcc/ada/s-finmas.ads @@ -131,9 +131,17 @@ package System.Finalization_Masters is overriding procedure Initialize (Master : in out Finalization_Master); -- Initialize the dummy head of a finalization master + procedure pm (Master : Finalization_Master); + -- Debug routine, outputs the contents of a master + procedure Set_Base_Pool (Master : in out Finalization_Master; Pool_Ptr : Any_Storage_Pool_Ptr); -- Set the underlying pool of a finalization master + procedure Set_Finalize_Address + (Master : in out Finalization_Master; + Fin_Addr_Ptr : Finalize_Address_Ptr); + -- Set the clean up routine of a finalization master + end System.Finalization_Masters; diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb index 8f0d9e84dd0..017392ca6ec 100644 --- a/gcc/ada/s-gearop.adb +++ b/gcc/ada/s-gearop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2011, 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- -- @@ -43,6 +43,27 @@ package body System.Generic_Array_Operations is First : Integer) return Integer; pragma Inline_Always (Check_Unit_Last); + -------------- + -- Diagonal -- + -------------- + + function Diagonal (A : Matrix) return Vector is + + N : constant Natural := Natural'Min (A'Length (1), A'Length (2)); + R : Vector (A'First (1) .. A'First (1) + N - 1); + + begin + for J in 0 .. N - 1 loop + R (R'First + J) := A (A'First (1) + J, A'First (2) + J); + end loop; + + return R; + end Diagonal; + + -------------------------- + -- Square_Matrix_Length -- + -------------------------- + function Square_Matrix_Length (A : Matrix) return Natural is begin if A'Length (1) /= A'Length (2) then @@ -73,6 +94,196 @@ package body System.Generic_Array_Operations is return First + (Order - 1); end Check_Unit_Last; + --------------------- + -- Back_Substitute -- + --------------------- + + procedure Back_Substitute (M, N : in out Matrix) is + pragma Assert (M'First (1) = N'First (1) and then + M'Last (1) = N'Last (1)); + Max_Col : Integer := M'Last (2); + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar); + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar) is + begin + for J in M'Range (2) loop + M (Target, J) := M (Target, J) - Factor * M (Source, J); + end loop; + end Sub_Row; + + begin + for Row in reverse M'Range (1) loop + Find_Non_Zero : for Col in M'First (2) .. Max_Col loop + if Is_Non_Zero (M (Row, Col)) then + -- Found first non-zero element, so subtract a multiple + -- of this row from all higher rows, to reduce all other + -- elements in this column to zero. + + for J in M'First (1) .. Row - 1 loop + Sub_Row (N, J, Row, (M (J, Col) / M (Row, Col))); + Sub_Row (M, J, Row, (M (J, Col) / M (Row, Col))); + end loop; + + Max_Col := Col - 1; + exit Find_Non_Zero; + end if; + end loop Find_Non_Zero; + end loop; + end Back_Substitute; + + ----------------------- + -- Forward_Eliminate -- + ----------------------- + + procedure Forward_Eliminate + (M : in out Matrix; + N : in out Matrix; + Det : out Scalar) + is + pragma Assert (M'First (1) = N'First (1) and then + M'Last (1) = N'Last (1)); + + function "abs" (X : Scalar) return Scalar is + (if X < Zero then Zero - X else X); + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar); + + procedure Divide_Row + (M, N : in out Matrix; + Row : Integer; + Scale : Scalar); + + procedure Switch_Row + (M, N : in out Matrix; + Row_1 : Integer; + Row_2 : Integer); + + ------------- + -- Sub_Row -- + ------------- + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar) is + begin + for J in M'Range (2) loop + M (Target, J) := M (Target, J) - Factor * M (Source, J); + end loop; + end Sub_Row; + + ---------------- + -- Divide_Row -- + ---------------- + + procedure Divide_Row + (M, N : in out Matrix; + Row : Integer; + Scale : Scalar) + is + begin + Det := Det * Scale; + + for J in M'Range (2) loop + M (Row, J) := M (Row, J) / Scale; + end loop; + + for J in N'Range (2) loop + N (Row - M'First (1) + N'First (1), J) + := N (Row - M'First (1) + N'First (1), J) / Scale; + end loop; + end Divide_Row; + + ---------------- + -- Switch_Row -- + ---------------- + + procedure Switch_Row + (M, N : in out Matrix; + Row_1 : Integer; + Row_2 : Integer) + is + procedure Swap (X, Y : in out Scalar); + -- Exchange the values of X and Y + + procedure Swap (X, Y : in out Scalar) is + T : constant Scalar := X; + begin + X := Y; + Y := T; + end Swap; + + begin + if Row_1 /= Row_2 then + Det := Zero - Det; + + for J in M'Range (2) loop + Swap (M (Row_1, J), M (Row_2, J)); + end loop; + + for J in N'Range (2) loop + Swap (N (Row_1 - M'First (1) + N'First (1), J), + N (Row_2 - M'First (1) + N'First (1), J)); + end loop; + end if; + end Switch_Row; + + I : Integer := M'First (1); + + begin -- Forward_Eliminate + Det := One; + + for J in M'Range (2) loop + declare + Max_I : Integer := I; + Max_Abs : Scalar := Zero; + begin + -- Find best pivot in column J, starting in row I. + for K in I .. M'Last (1) loop + declare + New_Abs : constant Scalar := abs M (K, J); + begin + if Max_Abs < New_Abs then + Max_Abs := New_Abs; + Max_I := K; + end if; + end; + end loop; + + if Zero < Max_Abs then + Switch_Row (M, N, I, Max_I); + Divide_Row (M, N, I, M (I, J)); + + for U in I + 1 .. M'Last (1) loop + Sub_Row (N, U, I, M (U, J)); + Sub_Row (M, U, I, M (U, J)); + end loop; + + exit when I >= M'Last (1); + + I := I + 1; + + else + Det := Zero; -- Zero, but we don't have literals + end if; + end; + end loop; + end Forward_Eliminate; + ------------------- -- Inner_Product -- ------------------- @@ -97,6 +308,15 @@ package body System.Generic_Array_Operations is return R; end Inner_Product; + ------------- + -- L2_Norm -- + ------------- + + function L2_Norm (X : Vector) return Scalar is + begin + return Sqrt (Inner_Product (X, X)); + end L2_Norm; + ---------------------------------- -- Matrix_Elementwise_Operation -- ---------------------------------- @@ -402,6 +622,20 @@ package body System.Generic_Array_Operations is return R; end Outer_Product; + ----------------- + -- Swap_Column -- + ----------------- + + procedure Swap_Column (A : in out Matrix; Left, Right : Integer) is + Temp : Scalar; + begin + for J in A'Range (1) loop + Temp := A (J, Left); + A (J, Left) := A (J, Right); + A (J, Right) := Temp; + end loop; + end Swap_Column; + --------------- -- Transpose -- --------------- diff --git a/gcc/ada/s-gearop.ads b/gcc/ada/s-gearop.ads index dfbceb3d058..51e3b92c201 100644 --- a/gcc/ada/s-gearop.ads +++ b/gcc/ada/s-gearop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2011, 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- -- @@ -32,6 +32,50 @@ package System.Generic_Array_Operations is pragma Pure (Generic_Array_Operations); + --------------------- + -- Back_Substitute -- + --------------------- + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + with function "-" (Left, Right : Scalar) return Scalar is <>; + with function "*" (Left, Right : Scalar) return Scalar is <>; + with function "/" (Left, Right : Scalar) return Scalar is <>; + with function Is_Non_Zero (X : Scalar) return Boolean is <>; + procedure Back_Substitute (M, N : in out Matrix); + + -------------- + -- Diagonal -- + -------------- + + generic + type Scalar is private; + type Vector is array (Integer range <>) of Scalar; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + function Diagonal (A : Matrix) return Vector; + + ----------------------- + -- Forward_Eliminate -- + ----------------------- + + -- Use elementary row operations to put square matrix M in row echolon + -- form. Identical row operations are performed on matrix N, must have the + -- same number of rows as M. + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + with function "-" (Left, Right : Scalar) return Scalar is <>; + with function "*" (Left, Right : Scalar) return Scalar is <>; + with function "/" (Left, Right : Scalar) return Scalar is <>; + with function "<" (Left, Right : Scalar) return Boolean is <>; + Zero, One : Scalar; + procedure Forward_Eliminate + (M : in out Matrix; + N : in out Matrix; + Det : out Scalar); + -------------------------- -- Square_Matrix_Length -- -------------------------- @@ -242,6 +286,17 @@ pragma Pure (Generic_Array_Operations); (Left : Left_Vector; Right : Right_Vector) return Result_Scalar; + ------------- + -- L2_Norm -- + ------------- + + generic + type Scalar is private; + type Vector is array (Integer range <>) of Scalar; + with function Inner_Product (Left, Right : Vector) return Scalar is <>; + with function Sqrt (X : Scalar) return Scalar is <>; + function L2_Norm (X : Vector) return Scalar; + ------------------- -- Outer_Product -- ------------------- @@ -332,6 +387,15 @@ pragma Pure (Generic_Array_Operations); (Left : Left_Matrix; Right : Right_Matrix) return Result_Matrix; + ----------------- + -- Swap_Column -- + ----------------- + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + procedure Swap_Column (A : in out Matrix; Left, Right : Integer); + --------------- -- Transpose -- --------------- diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb index 1c0584451d6..27f6e54a575 100644 --- a/gcc/ada/s-soflin.adb +++ b/gcc/ada/s-soflin.adb @@ -46,11 +46,6 @@ package body System.Soft_Links is package SST renames System.Secondary_Stack; - NT_Exc_Stack : array (0 .. 8192) of aliased Character; - for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment; - -- Allocate an exception stack for the main program to use. - -- This is currently only used under VMS. - NT_TSD : TSD; -- Note: we rely on the default initialization of NT_TSD @@ -173,24 +168,6 @@ package body System.Soft_Links is return NT_TSD.Current_Excep'Access; end Get_Current_Excep_NT; - --------------------------- - -- Get_Exc_Stack_Addr_NT -- - --------------------------- - - function Get_Exc_Stack_Addr_NT return Address is - begin - return NT_Exc_Stack (NT_Exc_Stack'Last)'Address; - end Get_Exc_Stack_Addr_NT; - - ----------------------------- - -- Get_Exc_Stack_Addr_Soft -- - ----------------------------- - - function Get_Exc_Stack_Addr_Soft return Address is - begin - return Get_Exc_Stack_Addr.all; - end Get_Exc_Stack_Addr_Soft; - ------------------------ -- Get_GNAT_Exception -- ------------------------ diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index b15f021dbca..f2d858bce8a 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -243,9 +243,6 @@ package System.Soft_Links is Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; - function Get_Exc_Stack_Addr_NT return Address; - Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access; - function Get_Current_Excep_NT return EOA; Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access; @@ -389,8 +386,6 @@ package System.Soft_Links is pragma Inline (Get_Sec_Stack_Addr_Soft); pragma Inline (Set_Sec_Stack_Addr_Soft); - function Get_Exc_Stack_Addr_Soft return Address; - -- The following is a dummy record designed to mimic Communication_Block as -- defined in s-tpobop.ads: diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 4fb0b96cc01..bf3a87e662f 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -250,14 +250,14 @@ package body System.Storage_Pools.Subpools is N_Ptr := Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Offset); - if Master.Finalize_Address = null then - Master.Finalize_Address := Fin_Address; - end if; - -- Prepend the allocated object to the finalization master Attach (N_Ptr, Master.Objects'Unchecked_Access); + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Address; + end if; + -- Move the address from the hidden list header to the start of the -- object. This operation effectively hides the list header. diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index bd19c474eaa..1759c5084c7 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -136,9 +136,6 @@ package body System.Task_Primitives.Operations is new Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); - function Get_Exc_Stack_Addr return Address; - -- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT - procedure Timer_Sleep_AST (ID : Address); pragma Convention (C, Timer_Sleep_AST); -- Signal the condition variable when AST fires @@ -755,7 +752,6 @@ package body System.Task_Primitives.Operations is if Result = 0 then Succeeded := True; - Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T; else if not Single_Lock then @@ -770,15 +766,6 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end Initialize_TCB; - ------------------------ - -- Get_Exc_Stack_Addr -- - ------------------------ - - function Get_Exc_Stack_Addr return Address is - begin - return Self.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address; - end Get_Exc_Stack_Addr; - ----------------- -- Create_Task -- ----------------- @@ -859,9 +846,6 @@ package body System.Task_Primitives.Operations is procedure Free is new Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - procedure Free is new Ada.Unchecked_Deallocation - (Exc_Stack_T, Exc_Stack_Ptr_T); - begin if not Single_Lock then Result := pthread_mutex_destroy (T.Common.LL.L'Access); @@ -875,7 +859,6 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (T.Common.LL.Exc_Stack_Ptr); Free (Tmp); if Is_Self then @@ -1247,8 +1230,6 @@ package body System.Task_Primitives.Operations is begin Environment_Task_Id := Environment_Task; - SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access; - -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); diff --git a/gcc/ada/s-taspri-vms.ads b/gcc/ada/s-taspri-vms.ads index 3d20080e65e..891dee28c9d 100644 --- a/gcc/ada/s-taspri-vms.ads +++ b/gcc/ada/s-taspri-vms.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -78,10 +78,6 @@ package System.Task_Primitives is private - type Exc_Stack_T is array (0 .. 8192) of aliased Character; - for Exc_Stack_T'Alignment use Standard'Maximum_Alignment; - type Exc_Stack_Ptr_T is access all Exc_Stack_T; - type Lock is record L : aliased System.OS_Interface.pthread_mutex_t; Prio : Interfaces.C.int; @@ -121,9 +117,6 @@ private L : aliased RTS_Lock; -- Protection for all components is lock L - Exc_Stack_Ptr : Exc_Stack_Ptr_T; - -- ??? This needs comments - AST_Pending : Boolean; -- Used to detect delay and sleep timeouts