Patchwork [Ada] Extensions of constrained discriminated with other progenitors

login
register
mail settings
Submitter Arnaud Charlet
Date June 14, 2010, 3:05 p.m.
Message ID <20100614150504.GA7590@adacore.com>
Download mbox | patch
Permalink /patch/55545/
State New
Headers show

Comments

Arnaud Charlet - June 14, 2010, 3:05 p.m.
If the parent type in a type extension is a discriminated type with constraints,
the compiler creates an anonymous base type for it, and makes the source type
into a subtype of it. If the derived type declaration includes an interface
list, it is attached to the anonymous base type. However, the extension may
contain current instances of the source type, whose subtype declaration has not
been elaborated yet. The interface list must be linked to the source type as
soon as constructed for the base. The presence of the anonymous base type must
also be taken into account when building the interface thunks for overridden 
interface operations: the overriding operation is declared on the subtype, but
the inherited primitive has the signature of the anonymous base.

The following must compile and execute quietly:

---
with Ref; use Ref;
procedure Proc is
   Obj :Grand_Child;
begin
   Dispatch (I'Class (Obj));
end;
---
package Ref is
   type I is interface;
   procedure Check (Obj : I) is null;
   procedure Dispatch (Obj : I'class);
   type C is record
      V : access I'Class;
   end record;

   type Root (V : Integer) is tagged null record;

   type Child is new Root (1) with null record;

   type Grand_Child is new Child and I with record
      X : C := (V => Grand_Child'Unrestricted_Access);
   end record;
   procedure Check (Obj : Grand_Child);
end Ref;
---
package body Ref is
   procedure Dispatch (Obj : I'class) is
   begin
      Check (Obj);
   end;

   procedure Check (Obj : Grand_Child) is
   begin
      if Obj.X.V /= Obj'Unrestricted_Access then raise Program_Error; end if;
   end;
end Ref;
---

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-14  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): if derived type is an
	anonymous base generated when the parent is a constrained discriminated
	type, propagate interface list to first subtype because it may appear
	in a current instance within the extension part of the derived type
	declaration, and its own subtype declaration has not been elaborated
	yet.
	* exp_disp.adb (Build_Interface_Thunk): Use base type of formal to
	determine whether it has the controlling type.
Richard Guenther - June 15, 2010, 9:31 a.m.
On Mon, Jun 14, 2010 at 5:05 PM, Arnaud Charlet <charlet@adacore.com> wrote:
[...]

For some reason this batch of changes caused parallel bootstrap
on x86_64 to fail for me with linker errors linking the RTS complaining
about x86_64_32 relocs and missing -fPIC.  A rm gcc/ada/rts/*.o and
a build re-start gets me past this error.

Richard.
Richard Guenther - June 15, 2010, 9:42 a.m.
On Tue, Jun 15, 2010 at 11:31 AM, Richard Guenther
<richard.guenther@gmail.com> wrote:
> On Mon, Jun 14, 2010 at 5:05 PM, Arnaud Charlet <charlet@adacore.com> wrote:
> [...]
>
> For some reason this batch of changes caused parallel bootstrap
> on x86_64 to fail for me with linker errors linking the RTS complaining
> about x86_64_32 relocs and missing -fPIC.  A rm gcc/ada/rts/*.o and
> a build re-start gets me past this error.

For reference:

touch ../stamp-gnatlib-rts
make[6]: Leaving directory `/home/abuild/rguenther/obj/gcc/ada'
rm -f rts/libgna*.so
cd rts; ../../xgcc -B../../ -shared -g -O2  \
                -fPIC \
                -o libgnat-4.5.so \
                a-assert.o a-calari.o a-calcon.o a-caldel.o a-calend.o
...
seh_init.o cal.o arit64.o final.o tracebak.o expect.o mkdir.o socket.o
targext.o raise-gcc.o \
                -Wl,-soname,libgnat-4.5.so \
                 -lm
/usr/lib64/gcc/x86_64-suse-linux/4.3/../../../../x86_64-suse-linux/bin/ld:
a-assert.o: relocation R_X86_64_32 against `.rodata' can not be used
when making a shared object; recompile with -fPIC
a-assert.o: could not read symbols: Bad value
collect2: ld returned 1 exit status
make[5]: *** [gnatlib-shared-default] Error 1
make[5]: Leaving directory `/home/abuild/rguenther/obj/gcc/ada'
make[4]: *** [gnatlib-shared-dual] Error 2
make[4]: Leaving directory `/home/abuild/rguenther/obj/gcc/ada'
make[3]: *** [gnatlib-shared] Error 2
make[3]: Leaving directory `/home/abuild/rguenther/obj/gcc/ada'
make[2]: *** [gnatlib-shared] Error 2
make[2]: Leaving directory
`/home/abuild/rguenther/obj/x86_64-unknown-linux-gnu/libada'
make[1]: *** [all-target-libada] Error 2
make[1]: Leaving directory `/home/abuild/rguenther/obj'
make: *** [all] Error 2


> Richard.
>
Arnaud Charlet - June 15, 2010, 9:45 a.m.
> For some reason this batch of changes caused parallel bootstrap
> on x86_64 to fail for me with linker errors linking the RTS complaining
> about x86_64_32 relocs and missing -fPIC.  A rm gcc/ada/rts/*.o and
> a build re-start gets me past this error.

I suspect this is a latent bug in the Makefile, unrelated to my changes.
FWIW, I always do a

rm -f x86_64-unknown-linux-gnu/libada/stamp-libada gcc/stamp-*

before starting a build, since since timestamp business simply does not
work in my experience and causes all kinds of troubles (such as the one
you've experienced I suspect).

Arno
Richard Guenther - June 15, 2010, 9:47 a.m.
On Tue, Jun 15, 2010 at 11:45 AM, Arnaud Charlet <charlet@adacore.com> wrote:
>> For some reason this batch of changes caused parallel bootstrap
>> on x86_64 to fail for me with linker errors linking the RTS complaining
>> about x86_64_32 relocs and missing -fPIC.  A rm gcc/ada/rts/*.o and
>> a build re-start gets me past this error.
>
> I suspect this is a latent bug in the Makefile, unrelated to my changes.
> FWIW, I always do a
>
> rm -f x86_64-unknown-linux-gnu/libada/stamp-libada gcc/stamp-*
>
> before starting a build, since since timestamp business simply does not
> work in my experience and causes all kinds of troubles (such as the one
> you've experienced I suspect).

Oh, this is clean bootstraps from an empty object directory, not some
fancy re-builds.  I'm currently trying to reproduce on another machine,
just to make sure ...

> Arno
>
Richard Guenther - June 15, 2010, 10:16 a.m.
On Tue, Jun 15, 2010 at 11:47 AM, Richard Guenther
<richard.guenther@gmail.com> wrote:
> On Tue, Jun 15, 2010 at 11:45 AM, Arnaud Charlet <charlet@adacore.com> wrote:
>>> For some reason this batch of changes caused parallel bootstrap
>>> on x86_64 to fail for me with linker errors linking the RTS complaining
>>> about x86_64_32 relocs and missing -fPIC.  A rm gcc/ada/rts/*.o and
>>> a build re-start gets me past this error.
>>
>> I suspect this is a latent bug in the Makefile, unrelated to my changes.
>> FWIW, I always do a
>>
>> rm -f x86_64-unknown-linux-gnu/libada/stamp-libada gcc/stamp-*
>>
>> before starting a build, since since timestamp business simply does not
>> work in my experience and causes all kinds of troubles (such as the one
>> you've experienced I suspect).
>
> Oh, this is clean bootstraps from an empty object directory, not some
> fancy re-builds.  I'm currently trying to reproduce on another machine,
> just to make sure ...

It seems this is caused by a local patch of mine - weird, this will be
fun to track down.

Sorry for the noise.

Richard.
Arnaud Charlet - June 15, 2010, 10:44 a.m.
> It seems this is caused by a local patch of mine - weird, this will be
> fun to track down.
> 
> Sorry for the noise.

OK, no problem.

The issues I mentioned are indeed related to incremental builds, a build from
scratch should of course always work.

Arno

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 160731)
+++ sem_ch3.adb	(working copy)
@@ -3750,10 +3750,10 @@ 
       if Present (Generic_Parent_Type (N))
         and then
           (Nkind
-             (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
+            (Parent (Generic_Parent_Type (N))) /= N_Formal_Type_Declaration
             or else Nkind
               (Formal_Type_Definition (Parent (Generic_Parent_Type (N))))
-                /=  N_Formal_Private_Type_Definition)
+                /= N_Formal_Private_Type_Definition)
       then
          if Is_Tagged_Type (Id) then
 
@@ -7356,6 +7356,27 @@ 
                   Exclude_Parents => True);
 
                Set_Interfaces (Derived_Type, Ifaces_List);
+
+               --  If the derived type is the anonymous type created for
+               --  a declaration whose parent has a constraint, propagate
+               --  the interface list to the source type. This must be done
+               --  prior to the completion of the analysis of the source type
+               --  because the components in the extension may contain current
+               --  instances whose legality depends on some ancestor.
+
+               if Is_Itype (Derived_Type) then
+                  declare
+                     Def : constant Node_Id :=
+                       Associated_Node_For_Itype (Derived_Type);
+                  begin
+                     if Present (Def)
+                       and then Nkind (Def) = N_Full_Type_Declaration
+                     then
+                        Set_Interfaces
+                          (Defining_Identifier (Def), Ifaces_List);
+                     end if;
+                  end;
+               end if;
             end;
          end if;
 
Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 160705)
+++ exp_disp.adb	(working copy)
@@ -1528,14 +1528,19 @@ 
       Formal        := First (Formals);
       while Present (Formal) loop
 
-         --  Handle concurrent types
+         --  Handle concurrent types.
 
          if Ekind (Target_Formal) = E_In_Parameter
            and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
          then
             Ftyp := Directly_Designated_Type (Etype (Target_Formal));
          else
-            Ftyp := Etype (Target_Formal);
+
+            --  if the parent is a constrained discriminated type. the
+            --  primitive operation will have been defined on a first subtype.
+            --  for proper matching with controlling type, use base type.
+
+            Ftyp := Base_Type (Etype (Target_Formal));
          end if;
 
          if Is_Concurrent_Type (Ftyp) then