[Bug fortran/94788] Severe regression leading to double free in tcache

[juergen.reuter at desy dot de]

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=94788

--- Comment #2 from Jürgen Reuter <juergen.reuter at desy dot de> ---
This is our unit test, we now confirmed that this is the only problem, so the
only failing test: it really looks like that the finalizer for the subroutine
crashes, all routines inside the subroutine get executed correctly:
  subroutine simulations_10 (u)
    integer, intent(in) :: u
    type(string_t) :: libname, procname1, expr_text
    type(rt_data_t), target :: global
    type(rt_data_t), dimension(1), target :: alt_env
    type(ifile_t) :: ifile
    type(stream_t) :: stream
    type(parse_tree_t) :: pt_weight
    type(simulation_t), target :: simulation
    type(event_sample_data_t) :: data

    write (u, "(A)")  "* Test output: simulations_10"
    write (u, "(A)")  "*   Purpose: reweight event"
    write (u, "(A)")

    write (u, "(A)")  "* Initialize processes"
    write (u, "(A)")

    call syntax_model_file_init ()
    call syntax_pexpr_init ()

    call global%global_init ()
    call global%set_log (var_str ("?omega_openmp"), &
         .false., is_known = .true.)
    call global%set_int (var_str ("seed"), &
         0, is_known = .true.)

    libname = "simulation_10a"
    procname1 = "simulation_10p"

    call prepare_test_library (global, libname, 1, [procname1])
    call compile_library (libname, global)

    call global%append_log (&
         var_str ("?rebuild_phase_space"), .true., intrinsic = .true.)
    call global%append_log (&
         var_str ("?rebuild_grids"), .true., intrinsic = .true.)
    call global%append_log (&
         var_str ("?rebuild_events"), .true., intrinsic = .true.)

    call global%set_string (var_str ("$method"), &
         var_str ("unit_test"), is_known = .true.)
    call global%set_string (var_str ("$phs_method"), &
         var_str ("single"), is_known = .true.)
    call global%set_string (var_str ("$integration_method"),&
         var_str ("midpoint"), is_known = .true.)
    call global%set_log (var_str ("?vis_history"),&
         .false., is_known = .true.)
    call global%set_log (var_str ("?integration_timer"),&
         .false., is_known = .true.)
    call global%set_log (var_str ("?recover_beams"), &
         .false., is_known = .true.)

    call global%set_real (var_str ("sqrts"),&
         1000._default, is_known = .true.)

    call global%it_list%init ([1], [1000])

    call global%set_string (var_str ("$run_id"), &
         var_str ("simulations1"), is_known = .true.)
    call integrate_process (procname1, global, local_stack=.true.)

    write (u, "(A)")  "* Initialize alternative environment with custom weight"
    write (u, "(A)")

    call alt_env(1)%local_init (global)
    call alt_env(1)%activate ()

    expr_text = "2"
    write (u, "(A,A)")  "weight = ", char (expr_text)
    write (u, *)

    call ifile_clear (ifile)
    call ifile_append (ifile, expr_text)
    call stream_init (stream, ifile)
    call parse_tree_init_expr (pt_weight, stream, .true.)
    call stream_final (stream)
    alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr ()
    call alt_env(1)%write_expr (u)

    write (u, "(A)")
    write (u, "(A)")  "* Initialize event generation"
    write (u, "(A)")

    call global%set_log (var_str ("?unweighted"), &
         .false., is_known = .true.)
    call simulation%init ([procname1], .true., .true., global, alt_env=alt_env)
    call simulation%init_process_selector ()

    data = simulation%get_data ()
    call data%write (u)

    write (u, "(A)")
    write (u, "(A)")  "* Generate an event"
    write (u, "(A)")

    call simulation%generate (1)
    call simulation%write (u)

    write (u, "(A)")
    write (u, "(A)")  "* Write the event record for the last event"
    write (u, "(A)")

    call simulation%write_event (u)

    write (u, "(A)")
    write (u, "(A)")  "* Write the event record for the alternative setup"
    write (u, "(A)")

    call simulation%write_alt_event (u)

    print *, "written alt_event, starting cleanup ..."

    write (u, "(A)")
    write (u, "(A)")  "* Cleanup"

    call simulation%final ()
    print *, "simulation finalized"
    call global%final ()
    print *, "global finalized"

    call syntax_model_file_final ()
    print *, "syntax_model_file finalized"
    call syntax_pexpr_final ()
    print *, "syntax pexpr finalized"

    write (u, "(A)")
    write (u, "(A)")  "* Test output end: simulations_10"

  end subroutine simulations_10