And a Workaround: Was: A smaller test case / Compiler Bug

[M E Leypold <development-2006-8ecbb5cc8aREMOVETHIS@ANDTHATm-e-leypold.de>]

Dear All,

Here is a workaround for the problem with reading/writing variant
records with finalizers which I reported before.

One should override the read/write attributes of the record in
question. The substituted procedures should 

  - write the discriminant first, then the appropriate variant part.

  - read the discriminant value, explicitly set the discriminant field
    in the buffer variable and then read the appropriate variant part.

"Fixed" test case has been attached.

Presently my idea about the source of the bug is, that the compiler
generates wrong code for reading records with discriminants.

Before it sets the discriminant field in the variable, it doesn't run
appropriate finalizers and initializers on possibly changed variant
parts, but just sets the discriminant field and the invokes the read
procedure for the appropriate variant part. Of course at that time the
bit patterns in record representation are not appropriate for the
discriminant (the representation is invalid) but mostly that doesn't
matter since the invalid representation is overwritten anyway. It does
matter though in the case that the variant part visible after changing
the discriminant value contains fields with controlled data types:
Then finalizers are run on invalid variable content. In my case that
triggered a problem in the underlying libc malloc().

The problem should only happen if there are variant parts where a
variant part has fields with finalizers _AND_ the representation
doesn't overlap with that of the other variant parts (in my test case
the problem goes away if the fields with finalizers are just 2
Unbounded_Strings, one at the beginning of every variant part, which
could be explained by the finalizer running as a finalizer of the
wrong variant part but still being a finalizer of Unbounded_String and
thus correctly finalizing the Unbounded_String in the now hidden
variant part.)

Depending on the finalizers all that leads to erronous memory
deallocation or that some finalization action is dropped (I've not
verfied this, but I predict that will probably happen).

The bug should in example result in memory leaks if the variant part
incoreectly hidden during reading contains finalizers concerned with
freeing memory which then are not run.

All that is conjecture at the moment but well in agreement with the
evidence so far.


Regards -- Markus


----

    with Ada.Streams.Stream_IO; use  Ada.Streams.Stream_IO;
    with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

    procedure Demo.Bug3 is

       type Customer_Description( Is_Company : Boolean := True ) is record

          case Is_Company Is

             when  True   =>

                Foo                 : Integer := 0;       -- remove these and the
                Bar                 : Integer := 0;       -- SIGSEGV goes away
                Company_Name        : Unbounded_String ;

             when  False  =>

                Persons_Name        : Unbounded_String;

             when   others  =>  null;
          end case;
       end record;

       procedure Write_Customer_Description
         ( S : access Ada.Streams.Root_Stream_Type'Class;
           R : in Customer_Description
         );

       procedure Read_Customer_Description
         ( S : access Ada.Streams.Root_Stream_Type'Class;
           R : out Customer_Description
         );


       for Customer_Description'Write use Write_Customer_Description;
       for Customer_Description'Read  use Read_Customer_Description;


       procedure Set_Zugang ( D :  in out Customer_Description ; Z : Boolean ) is begin

          if Z /= D.Is_Company then

             case Z is

                when True      =>
                   declare New_D : Customer_Description(True);
                   begin
                      D := New_D ;
                   end;

                when False  =>
                   declare New_D : Customer_Description(False);
                   begin   D := New_D ; end;

             end case;
          end if;
       end;


       procedure Write_Customer_Description
         ( S : access Ada.Streams.Root_Stream_Type'Class;
           R : in Customer_Description
         )
       is begin
          Boolean'Write(S,R.Is_Company);
          case R.Is_Company is

             when True =>
                Integer'Write( S, R.Foo );
                Integer'Write( S, R.Bar );
                Unbounded_String'Write( S, R.Company_Name );

             when False =>
                Unbounded_String'Write( S, R.Persons_Name );
          end case;
       end;


       procedure Read_Customer_Description
         ( S : access Ada.Streams.Root_Stream_Type'Class;
           R : out Customer_Description
         )
       is
          B : Boolean;
       begin
          Boolean'Read(S,B);
          Set_Zugang( R, B);

          case R.Is_Company is

             when True =>
                Integer'Read( S, R.Foo );
                Integer'Read( S, R.Bar );
                Unbounded_String'Read( S, R.Company_Name );

             when False =>
                Unbounded_String'Read( S, R.Persons_Name );
          end case;
       end;


       procedure Write_Record
       is
         F : File_Type;
         S : Stream_Access;
         R : Customer_Description;
       begin
          Create( F , Name => "tmp-bug3" );
          S := Stream(F);
          Set_Zugang(R, False);                   -- remove this and the SIGSEGV goes away

          for I in 1 .. 400 loop
             Customer_Description'Write(S,R);     -- [1a]
          end loop;

          Close(F);
       end;


       procedure Get_Record
       is
          F : File_Type;
          S : Stream_Access;
       begin

          Open( F , Mode => In_File, Name => "tmp-bug3" );
          S := Stream(F);

          for I in 1 .. 400 loop
             declare R : Customer_Description;
             begin
                Customer_Description'Read(S,R);        -- [1b]
             end;
          end loop;

          Close( F );
       end;

       R : Customer_Description;

    begin
       Write_Record;
       Get_Record;
    end;