Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/test/tasking.src

Text File | 1988-05-03 | 65.3 KB | 2,299 lines

::::::::::
cpu_body.ada
::::::::::
With SYSTEM;
package body Cpu is

Type Time_Val is record  -- how unix represents cpu time
           Seconds : INTEGER;
       Micro_Seconds : INTEGER;
     end record;

type Filler is array (INTEGER range <>) of INTEGER;

type RUsage is record     -- unix structure
      User_Time : Time_Val;
      System_Time : Time_Val;
      Junk        : Filler (1 .. 100);  -- not used here
    end record;

  -- unix procedure to return the resource utilization information
procedure getrusage (Who : INTEGER; Rec_Addr : in SYSTEM.ADDRESS);
Pragma INTERFACE (C, getrusage);


  -- implementation of package specification routine
function Milliseconds return INTEGER is
  Unix_Info : RUsage;
begin
    -- ask unix for the resource utilization information
  getrusage (0,                  -- this process
         Unix_Info'ADDRESS); -- where to put the results

    -- add together the user and system time and convert to milliseconds
  return (Unix_Info.User_Time.Micro_Seconds +
      Unix_Info.System_Time.Micro_Seconds) / 1000 +
     (Unix_Info.User_Time.Seconds +
      Unix_Info.System_Time.Seconds) * 1000;
end Milliseconds;

function Clock return Time is
begin
  return Time(Time(Milliseconds) * Time(0.001));
end Clock;

function "-" (Stop_Time, Start_Time : Time) return DURATION is
begin
  return DURATION (DURATION (Stop_Time) - DURATION (Start_Time));
end "-";

begin
  null;
end Cpu;
::::::::::
cpu_spec.ada
::::::::::
--  this is a machine specific package for reporting the amount of
--  CPU time used.
package Cpu is
  type Time is private;

    --  The time returned by Clock can only be used to determine the
    --  difference between two times.
  function Clock return Time;

    -- subtracting two times will result in the duration (seconds).
  function "-" (Stop_Time, Start_Time : Time) return DURATION;
private
  type Time is new DURATION;
end Cpu;

::::::::::
driver.ada
::::::::::
---------------- tasking benchmark main driver -----------------------

------------------ note that SYSTEM is included so that system dependent
------------------ characteristics can be displayed.
with TEXT_IO, SYSTEM, CALENDAR;
use  TEXT_IO;

------------------ all the tests are in packages PartN procedure Do_Test
------------------ where N ranges from 1 to the number of test sections
with Part1, Part2, Part3, Part4, Part5;

procedure Driver is
  Version : constant STRING := "August 1, 1986"; -- last modification date


  Quiet : BOOLEAN;  -- true implies no further prompting on each test
                    -- and that each test is to be run.

  Results : FILE_TYPE;     -- file where test results are written.
                           -- Do not use this file directly.  Instead, use
                           -- standard output for user messages and
                           -- current output for test results.

procedure Print_Header_Info is
use SYSTEM;
begin
  PUT_LINE ("                      Tasking Benchmark");
  NEW_LINE;
  PUT_LINE ("Benchmark Version of " & Version);
  PUT_LINE ("System is " & SYSTEM.NAME'IMAGE (SYSTEM_NAME));

  declare
    use CALENDAR;
    Yr : YEAR_NUMBER;
    Mo : MONTH_NUMBER;
    Da : DAY_NUMBER;
    Se : DAY_DURATION;
    Hr  : INTEGER range 0 .. 23;
    Min : INTEGER range 0 .. 59;
    Sec : INTEGER range 0 .. 86_400;  -- seconds in a day
  begin
    SPLIT (CLOCK, Yr, Mo, Da, Se);
    Sec := INTEGER (Se);
    Hr := Sec / 3600;
    Min := (Sec - Hr * 3600) / 60;
    PUT      ("Benchmark run on ");
    case Mo is
      when  1 => PUT ("January");
      when  2 => PUT ("February");
      when  3 => PUT ("March");
      when  4 => PUT ("April");
      when  5 => PUT ("May");
      when  6 => PUT ("June");
      when  7 => PUT ("July");
      when  8 => PUT ("August");
      when  9 => PUT ("September");
      when 10 => PUT ("October");
      when 11 => PUT ("November");
      when 12 => PUT ("December");
    end case;
    PUT_LINE (INTEGER'IMAGE (Da) & "," & INTEGER'IMAGE (Yr) & "   " &
              INTEGER'IMAGE (Hr * 100 + Min));
  end;

  declare
    package Float_Text_IO is new FLOAT_IO (FLOAT);
    X : FLOAT;
  begin
    PUT ("Basic Clock Period (SYSTEM.TICK) is ");
    X := FLOAT (TICK);
    Float_Text_IO.DEFAULT_EXP := 0;  -- dont want scientific notation
    Float_Text_IO.PUT (X);
    PUT_LINE (" seconds.");
  end;

  PUT_LINE ("INTEGER is represented with" & INTEGER'IMAGE (INTEGER'SIZE) &
            " bits.");

  declare
    task type T;
    task body T is begin null; end T;
  begin
    PUT_LINE ("An empty task is allocated" & INTEGER'IMAGE (T'STORAGE_SIZE) &
              " storage units.");
  end;
end Print_Header_Info;


function Ask (Question : STRING) return BOOLEAN is
  Ch : CHARACTER;
begin
  PUT (STANDARD_OUTPUT, Question & " (Y/N)? ");
  loop
    GET (Ch);
    if (Ch = 'Y') or (Ch = 'y') then
      return TRUE;
    elsif (Ch = 'N') or (Ch = 'n') then
      return FALSE;
    end if;
  end loop;
end Ask;


procedure Open_Files is
  -- this procedure opens the output file for the results and makes
  -- this file the default output file.

  Name : STRING (1 .. 80);
  Len  : INTEGER range 0 .. Name'LAST;
begin
  Try_To_Open:
  loop
    PUT ("File name for results (<cr> for console) ");
    GET_LINE (Name, Len);
    exit Try_To_Open when Len = 0;

    begin
      CREATE (Results, NAME => Name (1 .. Len));
      SET_OUTPUT (Results);
      exit Try_To_Open;
    exception
      when NAME_ERROR | USE_ERROR => PUT_LINE ("Cannot create file");
    end;
  end loop Try_To_Open;
end Open_Files;

begin  -- Driver
  PUT_LINE ("Tasking Benchmark");
  Open_Files;
  Quiet := Ask ("Do you wish to run all the tests");

  Print_Header_Info;

  if Quiet or else Ask ("Run " & Part1.Title & " timings") then
    NEW_PAGE;
    Part1.Do_Test;
  end if;

  if Quiet or else Ask ("Run " & Part2.Title & " timings") then
    NEW_PAGE;
    Part2.Do_Test;
  end if;

  if Quiet or else Ask ("Run " & Part3.Title & " timings") then
    NEW_PAGE;
    Part3.Do_Test;
  end if;

  if Quiet or else Ask ("Run " & Part4.Title & " timings") then
    NEW_PAGE;
    Part4.Do_Test;
  end if;

  if Quiet or else Ask ("Run " & Part5.Title & " timings") then
    NEW_PAGE;
    Part5.Do_Test;
  end if;


  -- other tests go here


  if LINE > 50 then
    NEW_PAGE;
  else
    NEW_LINE (10);
  end if;

  PUT_LINE (STANDARD_OUTPUT, "Test Complete");
end Driver;
::::::::::
misc_benchmark_body.ada
::::::::::
--  this is a package which provides a default
--  for the overhead timing subprogram in the Benchmark Generic
--  as well as miscellaneous timing routines.
with TEXT_IO; use TEXT_IO;
with CALENDAR; use CALENDAR;
with Cpu; use Cpu;
package body Misc_Benchmark is

procedure Get_Both_Times (Now : out Raw_Time_Info) is
-- retrieves the current elapsed time and cpu time
begin
  Now.Elapsed_Time := CALENDAR.CLOCK;
  Now.Cpu_Time := Cpu.Clock;
end Get_Both_Times;

function "-" (Stop, Start : in Raw_Time_Info) return Time_Info is
begin
  return (Elapsed_Time => Stop.Elapsed_Time - Start.Elapsed_Time,
          Cpu_Time => Stop.Cpu_Time - Start.Cpu_Time);
end "-";

procedure Print_Results (Results : in Results_Type;
                         Overhead_Results : in Results_Type;
                         Test_Repetitions : NATURAL;
                         Iterations : NATURAL) is

  package Duration_IO is new FIXED_IO (DURATION);
  use Duration_IO;

  type Net_Cpu_Type is array (1..Test_Repetitions) of DURATION;
  Net_Cpus : Net_Cpu_Type;  -- contains the Net Cpu per repetition
  Total_Cpu : DURATION := 0.0;

begin
  NEW_LINE;
  PUT("Number of iterations executed per repetition: ");
  PUT(NATURAL'IMAGE(Iterations));
  NEW_LINE;
  NEW_LINE;
  PUT_LINE("Note that all times are in seconds.");
  NEW_LINE;

  -- build table header
  PUT("|-----------------------------------------------------------------");
  PUT_LINE("-------------|");
  PUT("| REPETITION |  OVERHEAD  |    TEST    |     NET    |   TEST     |");
  PUT_LINE(" NET CPU PER |");
  PUT("| NUMBER     |  CPU       |    CPU     |     CPU    |   ELAPSED  |");
  PUT_LINE(" ITERATION   |");

  for Repetitions in 1..Test_Repetitions loop
    PUT("|------------|------------|------------|------------|------------|");
    PUT_LINE("-------------|");
    PUT("|     ");
    PUT(NATURAL'IMAGE(Repetitions));
    SET_COL(14);
    PUT("| ");
    PUT(Overhead_Results (Repetitions).Cpu_Time,FORE => 5);
    SET_COL(27);
    PUT("| ");
    PUT(Results (Repetitions).Cpu_Time,FORE => 5);
    SET_COL(40);
    PUT("| ");
    Net_Cpus(Repetitions) := DURATION(Results(Repetitions).Cpu_Time -
                                      Overhead_Results(Repetitions).Cpu_Time);
    Total_Cpu := Total_Cpu + Net_Cpus(Repetitions);
    PUT(Net_Cpus(Repetitions),FORE => 5);
    SET_COL(53);
    PUT("| ");
    PUT(Results (Repetitions).Elapsed_Time,FORE => 5);
    SET_COL(66);
    PUT("|  ");
    PUT(DURATION(Net_Cpus(Repetitions) / DURATION(Iterations)),FORE => 5);
    SET_COL(80);
    PUT_LINE("|");
  end loop;

  PUT("|-----------------------------------------------------------------");
  PUT_LINE("-------------|");

  -- Output Net Cpu time averaged across repetitions
  NEW_LINE;
  NEW_LINE;
  PUT("The average net cpu time (across repetitions) was: ");
  PUT(DURATION(Total_Cpu / DURATION(Test_Repetitions)),FORE=>5);
  NEW_LINE;
  PUT("The average net cpu time per iteration was: ");
  PUT(DURATION(Total_Cpu / DURATION(Test_Repetitions * Iterations)),FORE=>5);
  NEW_LINE;
  NEW_LINE;
  PUT_LINE((1..80=> '-'));
  PUT_LINE((1..80=> '-'));
end Print_Results;


procedure Default_Overhead (Iterations : in NATURAL) is
begin
  for Loop_Count in 1..Iterations loop
    null;
  end loop;
end Default_Overhead;

begin
  null;
end Misc_Benchmark;
::::::::::
misc_benchmark_spec.ada
::::::::::
--  this is a package which provides a default
--  for the overhead timing subprogram in the Benchmark Generic
--  as well as miscellaneous timing routines.
with CALENDAR; use CALENDAR;
with Cpu; use Cpu;
package Misc_Benchmark is
  type Time_Info is private;
  type Raw_Time_Info is private;
  type Results_Type is array (NATURAL range <>) of Time_Info;

  procedure Get_Both_Times (Now : out Raw_Time_Info);
  function "-" (Stop, Start : in Raw_Time_Info) return Time_Info;
  procedure Print_Results (Results : in Results_Type;
                           Overhead_Results : in Results_Type;
                           Test_Repetitions : NATURAL;
                           Iterations : NATURAL);

  procedure Default_Overhead (Iterations : in NATURAL);

private
  type Time_Info is record
         Elapsed_Time,
         Cpu_Time : DURATION;
       end record;

  type Raw_Time_Info is record
         Elapsed_Time  : CALENDAR.TIME;
         Cpu_Time      : Cpu.Time;
       end record;

end Misc_Benchmark;
::::::::::
part1.ada
::::::::::
---- test section 1 - task activation/termination
with TEXT_IO, Benchmark;
use  TEXT_IO;
package body Part1 is

procedure Do_Test is

    procedure Task_Activation (N : in NATURAL) is
      -- this procedure declares N tasks locally - timing this procedure
      -- will time 1 procedure call and N task activations/terminations

      task type Empty_Task;

      Lots_Of_Tasks : array (1 .. N) of Empty_Task;

      task body Empty_Task is
      begin
        null;
      end  Empty_Task;

    begin
      null;
    end Task_Activation;


    procedure Task_Allocation (N : in NATURAL) is
    -- this procedure allocates N tasks.  Since the task type is declared
    -- locally, deallocation of the task space should occur during the
    -- call to this procedure.

      task type Empty_Task;

      type Empty_Task_Ptr is access Empty_Task;
      Lots_Of_Tasks : array (1 .. N) of Empty_Task_Ptr;

      task body Empty_Task is
      begin
        null;
      end  Empty_Task;

    begin
      Lots_Of_Tasks := (1 .. N => new Empty_Task);
    end Task_Allocation;

    procedure Task_Activation2 (N : in NATURAL) is
      -- this procedure declares N tasks locally - timing this procedure
      -- will time 1 procedure call and N task activations/terminations

      task type Empty_Task is
         entry Dont_Call_Me;
      end Empty_Task;

      Lots_Of_Tasks : array (1 .. N) of Empty_Task;

      task body Empty_Task is
      begin
        select
          accept Dont_Call_Me;
        or
          terminate;
        end select;
      end  Empty_Task;

    begin
      null;
    end Task_Activation2;


begin  -- Do_Test
    PUT_LINE ("               Task Activation/Termination Test");
    NEW_LINE;
    PUT_LINE ("This test times task activation and termination under a ");
    PUT_LINE ("variety of circumstances.");

              --------------------------------------------

    NEW_LINE (2);
    PUT_LINE ("In this test an array of tasks is declared locally to a");
    PUT_LINE ("procedure.  Both the procedure and the task have null bodies.");
    NEW_LINE;

    declare
      package Local_Array_Pkg is new Benchmark
              (Item_Of_Interest => Task_Activation);
    begin
      Local_Array_Pkg.Timer;
    end;

              --------------------------------------------

    NEW_LINE (2);
    PUT_LINE ("In this test an array of tasks is declared locally to a");
    PUT_LINE ("procedure.  The task uses the terminate option in a select");
    PUT_LINE ("statement to terminate.  The task is never called");
    NEW_LINE;

    declare
      package Terminate_Array_Pkg is new Benchmark
              (Item_Of_Interest => Task_Activation2);
    begin
      Terminate_Array_Pkg.Timer;
    end;

             ----------------------------------------

    NEW_LINE (2);
    PUT_LINE ("In this test an access type to a task is used to create a");
    PUT_LINE ("series of tasks.  The timing should include both allocation");
    PUT_LINE ("and deallocation of the task as well as activation and");
    PUT_LINE ("termination.");
    NEW_LINE;

    declare
      package Access_Type_Pkg is new Benchmark
              (Item_Of_Interest => Task_Allocation);
    begin
      Access_Type_Pkg.Timer;
    end;


exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");

end Do_Test;

end Part1;
::::::::::
part1spec.ada
::::::::::
---- test section 1

package Part1 is
  Title : constant STRING := "task activation/termination";
  procedure Do_Test;
end Part1;
::::::::::
part2.ada
::::::::::
--- test section 2  --  task communication
with TEXT_IO, Benchmark;
use  TEXT_IO;
package body Part2 is

-- define the continue and terminate conditions for the tasks
Continue_Item : constant := 1;
Terminate_Item : constant := -1;


procedure Do_Test is


  -- task types that are used in several tests

  task type Buffer_Type is
    entry Take_Item (Item : in INTEGER);
    entry Provide_Item (Item : out INTEGER);
  end Buffer_Type;

  task type Called_Consumer_Type is
        -- consumer is to take items until
        -- a value of Terminate_Item is accepted.
    entry Take_Item (Item : in INTEGER);
  end Called_Consumer_Type;

pragma PAGE;

  task body Buffer_Type is
     type Buffer_Count is range 0 .. 2;
     subtype Buffer_Index is Buffer_Count range 1 .. Buffer_Count'LAST;
     Buf : array (Buffer_Index) of INTEGER;
     Head, Tail : Buffer_Index := Buffer_Index'FIRST;
     Count : Buffer_Count := 0;
  begin
    loop
      select
        when Count > 0 =>
        accept Provide_Item (Item : out INTEGER) do
          Item := Buf (Tail);
          Tail := (Tail mod Buffer_Index'LAST) + 1;
          Count := Count - 1;
        end Provide_Item;
      or
        when Count < Buffer_Count'LAST =>
        accept Take_Item (Item : in INTEGER) do
          Buf (Head) := Item;
          Head := (Head mod Buffer_Index'LAST) + 1;
          Count := Count + 1;
        end Take_Item;
      or
        terminate;
      end select;
    end loop;
  end Buffer_Type;



  task body Called_Consumer_Type is
    Item : INTEGER;
  begin
    loop
      accept Take_Item (Item : in INTEGER) do
        Called_Consumer_Type.Item := Item;
      end Take_Item;

      exit when Item = Terminate_Item;

    end loop;
  end Called_Consumer_Type;
pragma PAGE;

procedure Time_PC is
  Consumer : Called_Consumer_Type;

begin
  NEW_LINE (2);
  PUT_LINE ("SIMPLE PC");
  PUT_LINE ("In this test the main task calls a consumer task.");
  PUT_LINE ("A simple integer value is the only data transferred");
  PUT_LINE ("and the consumer simply loops on the accept.");
  PUT_LINE ("Task activation/termination time is not included in the timing.");
  NEW_LINE;

  declare
    procedure Send_Item (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Consumer.Take_Item (Continue_Item);
      end loop;
    end Send_Item;

    package PC_Pkg is new Benchmark
            (Item_Of_Interest => Send_Item);
  begin
    PC_Pkg.Timer;
    Consumer.Take_Item (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_PC;
pragma PAGE;

procedure Time_PC2 is

  task type Called_Consumer_Type_With_Select is
        -- consumer is to take items until
        -- a value of Terminate_Item is accepted.
    entry Take_Item (Item : in INTEGER);
    entry Stop;  -- alternate entry for Take_Item
  end Called_Consumer_Type_With_Select;

  Consumer : Called_Consumer_Type_With_Select;



  task body Called_Consumer_Type_With_Select is
    Item : INTEGER;
  begin
    loop
      select
        accept Take_Item (Item : in INTEGER) do
          Called_Consumer_Type_With_Select.Item := Item;
        end Take_Item;
      or
        accept Stop do
           Item := Item;
        end Stop;
      end select;

      exit when Item = Terminate_Item;

    end loop;
  end Called_Consumer_Type_With_Select;


begin
  NEW_LINE (2);
  PUT_LINE ("SELECTIVE WAIT");
  PUT_LINE ("In this test the main task calls a consumer task that");
  PUT_LINE ("consumes more than one type of item.");
  PUT_LINE ("A simple integer value is the only data transferred");
  PUT_LINE ("and the consumer simply loops on the selective accept.");
  PUT_LINE ("This test differs from the previous test in that the consumer");
  PUT_LINE ("uses a select statement to take the entry call where the");
  PUT_LINE ("select has two open alternatives.  In the previous case");
  PUT_LINE ("there was no select statement.");
  NEW_LINE;

  declare
    procedure Send_Item (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Consumer.Take_Item (Continue_Item);
      end loop;
    end Send_Item;

    package PC2_Pkg is new Benchmark
            (Item_Of_Interest => Send_Item);
  begin
    PC2_Pkg.Timer;
    Consumer.Take_Item (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_PC2;
pragma PAGE;

procedure Time_PC3 is
  Consumer : Called_Consumer_Type;

  task Producer is
       -- producer terminates upon accepting Terminate_Item.
    entry Produce (Num : in INTEGER);
    entry Have_Finished;

    -- Calls
       -- Consumer.Take_Item
  end Producer;


  task body Producer is
    Count : INTEGER;
  begin
    loop
      accept Produce (Num : in INTEGER) do
        Count := Num;
      end Produce;

      exit when Count = Terminate_Item;

      for I in 1 .. Count loop
        Consumer.Take_Item (Continue_Item);
      end loop;

      accept Have_Finished;
    end loop;
  end Producer;


begin
  NEW_LINE (2);
  PUT_LINE ("PC");
  PUT_LINE ("In this test a producer task communicates with a consumer task");
  PUT_LINE ("directly. This timing should be similar to the simple PC tests.");
  PUT_LINE ("Interaction with the main task takes place only at the beginning");
  PUT_LINE ("and at the end.");
  PUT_LINE ("Total number of task interactions is N+2");
  NEW_LINE;

  declare
    procedure Tell_Producer (Iterations : in NATURAL) is
    begin
      Producer.Produce (Iterations);
      Producer.Have_Finished;
    end Tell_Producer;

    package PC3_Pkg is new Benchmark
            (Item_Of_Interest => Tell_Producer);

  begin
    PC3_Pkg.Timer;
    Producer.Produce (Terminate_Item);
    Consumer.Take_Item (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_PC3;
pragma PAGE;

procedure Time_PBC is
  Buffer : Buffer_Type;


  task type Calling_Consumer_Type is
        -- consumer is to take items until
        -- a value of Terminate_Item is received.
    entry Stop_On_Number (Num : in INTEGER);

    -- Calls
       -- Buffer.Provide_Item
  end Calling_Consumer_Type;

  Consumer : Calling_Consumer_Type;


  task Producer is
    entry Produce (Num : in INTEGER);
    entry Have_Finished;
    -- Calls
       -- Buffer.Take_Item
  end Producer;


  task body Producer is
    Count : INTEGER;
  begin
    loop
      accept Produce (Num : in INTEGER) do
        Count := Num;
      end Produce;

      exit when Count = Terminate_Item;

      for I in 1 .. Count loop
        Buffer.Take_Item (Continue_Item);
      end loop;

      accept Have_Finished;
    end loop;
  end Producer;


  task body Calling_Consumer_Type is
    Item,
    Count : INTEGER;
  begin
    loop
      Accept Stop_On_Number (Num : in INTEGER) do
        Count := Num;
      end Stop_On_Number;

      exit when Count = Terminate_Item;

      for I in 1..Count loop
        Buffer.Provide_Item (Item);
      end loop;
    end loop;
  end Calling_Consumer_Type;


begin
  NEW_LINE (2);
  PUT_LINE ("PBC");
  PUT_LINE ("In this test a producer task communicates with a consumer task");
  PUT_LINE ("indirectly through a bounded buffer (buffer size = 2).");
  PUT_LINE ("Interaction with the main task takes place only at the beginning");
  PUT_LINE ("and at the end.");
  PUT_LINE ("Total number of task interactions is 2N+3.");
  NEW_LINE;

  declare
    procedure Tell_PC (Iterations : NATURAL) is
    begin
      Producer.Produce (Iterations);
      Consumer.Stop_On_Number (Iterations);
      Producer.Have_Finished;
    end Tell_PC;

    package PBC_Pkg is new Benchmark
            (Item_Of_Interest => Tell_PC);

  begin
    PBC_Pkg.Timer;
    Producer.Produce (Terminate_Item);
    Consumer.Stop_On_Number (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_PBC;
pragma PAGE;

procedure Time_PBTC is
  Buffer      : Buffer_Type;
  Consumer    : Called_Consumer_Type;

  task Producer is
    entry Produce (Num : in INTEGER);
    entry Have_Finished;

    -- Calls
       -- Buffer.Take_Item
  end Producer;


  task Transporter is
    -- Calls
       -- Buffer.Provide_Item
       -- Consumer.Take_Item
  end Transporter;


  task body Transporter is
    Item : INTEGER;
  begin
    loop
      Buffer.Provide_Item (Item);
      Consumer.Take_Item (Item);
    end loop;
  end Transporter;


  task body Producer is
    Count : INTEGER;
  begin
    loop
      accept Produce (Num : in INTEGER) do
        Count := Num;
      end Produce;

      exit when Count = Terminate_Item;

      for I in 1 .. Count loop
        Buffer.Take_Item (Continue_Item);
      end loop;

      accept Have_Finished;
    end loop;
  end Producer;

begin
  NEW_LINE (2);
  PUT_LINE ("PBTC");
  PUT_LINE ("In this test a producer task communicates with a consumer task");
  PUT_LINE ("indirectly through a bounded buffer (buffer size = 2) with");
  PUT_LINE ("a transporter between the buffer and the consumer.");
  PUT_LINE ("Interaction with the main task takes place only at the beginning");
  PUT_LINE ("and at the end.");
  PUT_LINE ("Total number of task interactions is 3N+2.");
  NEW_LINE;

  declare
    procedure Tell_Producer (Iterations : in NATURAL) is
    begin
      Producer.Produce (Iterations);
      Producer.Have_Finished;
    end Tell_Producer;

    package PBTC_Pkg is new Benchmark
            (Item_Of_Interest => Tell_Producer);

  begin
    PBTC_Pkg.Timer;
    Producer.Produce (Terminate_Item);
    Consumer.Take_Item (Terminate_Item);
    abort Transporter;            -- do this so buffer will die on its own
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_PBTC;
pragma PAGE;

procedure Time_PTBTC is
  Buffer      : Buffer_Type;
  Consumer    : Called_Consumer_Type;

  task Producer is
    entry Produce (Num : in INTEGER);
    entry Provide_Item (Item : out INTEGER);
    entry Have_Finished;
  end Producer;


  task C_Transporter is
    -- Calls
       -- Buffer.Provide_Item
       -- Consumer.Take_Item
  end C_Transporter;


  task body C_Transporter is
    Item : INTEGER;
  begin
    loop
      Buffer.Provide_Item (Item);
      Consumer.Take_Item (Item);
    end loop;
  end C_Transporter;


  task P_Transporter is
    -- Calls
       -- Producer.Provide_Item
       -- Buffer.Take_Item
  end P_Transporter;


  task body P_Transporter is
    Item : INTEGER;
  begin
    loop
      Producer.Provide_Item (Item);
      Buffer.Take_Item (Item);
    end loop;
  end P_Transporter;


  task body Producer is
    Count : INTEGER;
  begin
    loop
      accept Produce (Num : in INTEGER) do
        Count := Num;
      end Produce;

      exit when Count = Terminate_Item;

      for I in 1 .. Count loop
        accept Provide_Item (Item : out INTEGER) do
           Item := Continue_Item;
        end Provide_Item;
      end loop;

      accept Have_Finished;

    end loop;
  end Producer;

begin
  NEW_LINE (2);
  PUT_LINE ("PTBTC");
  PUT_LINE ("In this test a producer task communicates with a consumer task");
  PUT_LINE ("indirectly through a bounded buffer (buffer size = 2) with");
  PUT_LINE ("a transporter for both the producer and the consumer.");
  PUT_LINE ("Interaction with the main task takes place only at the beginning");
  PUT_LINE ("and at the end.");
  PUT_LINE ("Total number of task interactions is 4N+2.");
  NEW_LINE;

  declare
    procedure Tell_Producer (Iterations : in NATURAL) is
    begin
      Producer.Produce (Iterations);
      Producer.Have_Finished;
    end Tell_Producer;

    package PTBTC_Pkg is new Benchmark
            (Item_Of_Interest => Tell_Producer);
  begin
    PTBTC_Pkg.Timer;
    Producer.Produce (Terminate_Item);
    Consumer.Take_Item (Terminate_Item);
    abort P_Transporter, C_Transporter; -- do this so buffer will die on its own
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_PTBTC;
pragma PAGE;

procedure Time_Relay is
  Consumer    : Called_Consumer_Type;


  task Producer is
    entry Produce (Num : in INTEGER);
    entry Have_Finished;

    -- Calls
       -- Relay.Take_Item
  end Producer;


  task Relay is
    entry Take_Item (Item : in INTEGER);

    -- Calls
       -- Consumer.Take_Item
  end Relay;


  task body Relay is
    Item : INTEGER;
  begin
    loop
      accept Take_Item (Item : in INTEGER) do
        Relay.Item := Take_Item.Item;
      end Take_Item;

      exit when Item = Terminate_Item;

      Consumer.Take_Item (Item);
    end loop;
  end Relay;


  task body Producer is
    Count : INTEGER;
  begin
    loop
      accept Produce (Num : in INTEGER) do
        Count := Num;
      end Produce;

      exit when Count = Terminate_Item;

      for I in 1 .. Count loop
        Relay.Take_Item (Continue_Item);
      end loop;

      accept Have_Finished;

    end loop;
  end Producer;

begin
  NEW_LINE (2);
  PUT_LINE ("RELAY");
  PUT_LINE ("In this test a producer task communicates with a consumer task");
  PUT_LINE ("indirectly through a relay.  In terms of the task communication");
  PUT_LINE ("model, this resembles the PBTC paradigm but in terms of");
  PUT_LINE ("performance it should resemble the PBC test.");
  PUT_LINE ("Interaction with the main task takes place only at the beginning");
  PUT_LINE ("and at the end.");
  PUT_LINE ("Total number of task interactions is 2N+2.");
  NEW_LINE;

  declare
    procedure Tell_Producer (Iterations : in NATURAL) is
    begin
      Producer.Produce (Iterations);
      Producer.Have_Finished;
    end Tell_Producer;

    package Relay_Pkg is new Benchmark
            (Item_Of_Interest => Tell_Producer);
  begin
    Relay_Pkg.Timer;
    Producer.Produce (Terminate_Item);
    Consumer.Take_Item (Terminate_Item);
    Relay.Take_Item (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Relay;
pragma PAGE;

begin
  PUT_LINE ("               Task Communication");
  NEW_LINE;
  PUT_LINE ("This test times task to task communication in order to determine");
  PUT_LINE ("the cost of the various task communication models.  Task");
  PUT_LINE ("activation and termination is not included in the timings.");
  Time_PC;
  Time_PC2;
  Time_PC3;
  Time_PBC;
  Time_PBTC;
  Time_PTBTC;
  Time_Relay;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");

end Do_Test;

end Part2;
::::::::::
part2spec.ada
::::::::::
---- test section 2

package Part2 is
  Title : constant STRING := "task communication";
  procedure Do_Test;
end Part2;
::::::::::
part3.ada
::::::::::
------ test section 3 - task optimization techniques
with TEXT_IO, Benchmark;
use  TEXT_IO;
package body Part3 is

-- define the continue and terminate conditions for the tasks.
Continue_Item : constant := 1;
Terminate_Item : constant := -1;

procedure Do_Test is

procedure Time_Monitor is

  task General_Task is
    entry Take_Item (Item : in INTEGER);
    entry Provide_Item (Item : out INTEGER);
  end General_Task;

  task Monitor is
    entry Take_Item (Item : in INTEGER);
    entry Provide_Item (Item : out INTEGER);
  end Monitor;


  task body General_Task is
    Local : INTEGER;
  begin
    loop
      select
        accept Take_Item (Item : in INTEGER) do
          Local := Item;
        end Take_Item;
        Local := Local + 1;  -- the only difference is where this line is
      or
        accept Provide_Item (Item : out INTEGER) do
          Item := Local;
        end Provide_Item;
      or
        terminate;
      end select;
    end loop;
  end General_Task;


  task body Monitor is
    Local : INTEGER;
  begin
    loop
      select
        accept Take_Item (Item : in INTEGER) do
          Local := Item;
          Local := Local + 1;  -- the only difference is where this line is
        end Take_Item;
      or
        accept Provide_Item (Item : out INTEGER) do
          Item := Local;
        end Provide_Item;
      or
        terminate;
      end select;
    end loop;
  end Monitor;


begin
  NEW_LINE (2);
  PUT_LINE ("MONITOR");
  PUT_LINE ("A task that contains no code outside of the accept bodies");
  PUT_LINE ("is considered to be a monitor.  It is possible to eliminate");
  PUT_LINE ("such a task by protecting the task entries with semaphores.");
  PUT_LINE ("In this test the main task interacts with a monitor and with");
  PUT_LINE ("a more general task in order to determine if this optimization");
  PUT_LINE ("is performed.  The monitor is the overhead item and the general");
  PUT_LINE ("task is the tested item.  If the net cpu is negative or near");
  PUT_LINE ("zero, it can be assumed that the optimization is not done.");
  NEW_LINE;

  declare
    procedure Send_To_Monitor (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Monitor.Take_Item (Continue_Item);
      end loop;
    end Send_To_Monitor;

    procedure Send_To_General (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        General_Task.Take_Item (Continue_Item);
      end loop;
    end Send_To_General;

    package Monitor_Pkg is new Benchmark
            (Overhead => Send_To_Monitor,
             Item_Of_Interest => Send_To_General);

  begin
    Monitor_Pkg.Timer;
  end;
end Time_Monitor;
pragma PAGE;

procedure Time_Single_Accept_Body is

  task Single_Accept is
    entry Take_Item (Item : in INTEGER);
    entry Stop;
  end Single_Accept;

  task body Single_Accept is
  begin
    loop
      select
        accept Take_Item (Item : in INTEGER) do
          if Item = 0 then
            PUT_LINE ("error in test (single accept)");
          end if;
        end Take_Item;
      or
        accept Stop;
        exit;
      end select;
    end loop;
  end Single_Accept;


  task Multiple_Accept is
    entry Take_Item (Item : in INTEGER);
    entry Stop;
  end Multiple_Accept;

  task body Multiple_Accept is
  begin
    loop
      select
        accept Take_Item (Item : in INTEGER) do
          if Item = 0 then
            PUT_LINE ("error in test (single accept)");
          end if;
        end Take_Item;
      or
        accept Stop;
        exit;
      end select;

         -- repeat select statement to create the multiple accept bodies
      select
        accept Take_Item (Item : in INTEGER) do
          if Item = 0 then
            PUT_LINE ("error in test (single accept)");
          end if;
        end Take_Item;
      or
        accept Stop;
        exit;
      end select;
    end loop;
  end Multiple_Accept;


begin
  NEW_LINE (2);
  PUT_LINE ("SINGLE ACCEPT BODIES");
  PUT_LINE ("In the case where a task entry has a single accept body there");
  PUT_LINE ("is no need for the indirect referencing that may be used when");
  PUT_LINE ("a single entry has multiple accept bodies.");
  PUT_LINE ("This test checks to see if calls to entrys that have a ");
  PUT_LINE ("single accept body are more efficient than when multiple ");
  PUT_LINE ("accept bodies are used.  The single accept body is the ");
  PUT_LINE ("overhead item and the multiple accept body is the tested item.");
  PUT_LINE ("If the net cpu is negative or near zero, it can be assumed ");
  PUT_LINE ("that the optimization is not done.");
  NEW_LINE;

  declare
    procedure Send_To_Single (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Single_Accept.Take_Item (Continue_Item);
      end loop;
    end Send_To_Single;

    procedure Send_To_Multiple (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Multiple_Accept.Take_Item (Continue_Item);
      end loop;
    end Send_To_Multiple;

    package Accept_Pkg is new Benchmark
            (Overhead => Send_To_Single,
             Item_Of_Interest => Send_To_Multiple);

  begin
    Accept_Pkg.Timer;
    Single_Accept.Stop;   -- kill off the tasks
    Multiple_Accept.Stop;
  end;
end Time_Single_Accept_Body;
pragma PAGE;

begin  -- Do_Test
  PUT_LINE ("               Task Optimizations");
  NEW_LINE;
  PUT_LINE ("This test determines if the implementation optimizes various");
  PUT_LINE ("special cases of tasking.  The specific optimizations being");
  PUT_LINE ("tested for are machine independent optimizations that have been");
  PUT_LINE ("discussed in the Ada literature. For each specific optimization");
  PUT_LINE ("the general case and the special case is timed.");
  PUT_LINE ("If the special case is significantly");
  PUT_LINE ("faster than the general case then it is assumed that the");
  PUT_LINE ("optimization technique is employed.");

  Time_Monitor;
  Time_Single_Accept_Body;


exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");

end Do_Test;
end Part3;
::::::::::
part3spec.ada
::::::::::
---- test section 3

package Part3 is
  Title : constant STRING := "task optimization";
  procedure Do_Test;
end Part3;
::::::::::
part4.ada
::::::::::
---------- test section 4  -- exception propagation
with TEXT_IO, Benchmark;
use  TEXT_IO;
package body Part4 is

procedure Do_Test is

procedure Time_Simple_Exception is
begin
  NEW_LINE (2);
  PUT_LINE ("EXCEPTION IN BLOCK");
  PUT_LINE ("In this test an exception is raised and handled in the same");
  PUT_LINE ("block.  The user defined exception is declared local to the");
  PUT_LINE ("block where it is raised.  The same block is timed without");
  PUT_LINE ("the exception being raised so the exception handling time can");
  PUT_LINE ("be determined.");

  declare
    procedure Do_Raise (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        declare
          Exc : exception;
        begin
          raise Exc;
          PUT_LINE ("ERROR: exception not raised as it should.");
          raise PROGRAM_ERROR;
        exception
          when Exc =>
               null;
        end;
      end loop;
    end Do_Raise;

    procedure Dont_Raise (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        declare
          Exc : exception;
        begin
          null;
        exception
          when Exc =>
            PUT_LINE ("ERROR: exception improperly raised.");
        end;
      end loop;
    end Dont_Raise;

    package Simple_Exception_Pkg is new Benchmark
            (Overhead => Dont_Raise,
             Item_Of_Interest => Do_Raise);

  begin
    Simple_Exception_Pkg.Timer;
  end;
end Time_Simple_Exception;
pragma PAGE;

procedure Time_Procedure_Exception is
  Exc         : exception;

    -- raise Exc if the parameter is true otherwise do nothing
  procedure Raise_Exc (Do_It : in BOOLEAN) is
  begin
    if Do_It then
      raise Exc;
    end if;

    if Do_It then  -- make sure the exception was raised
      PUT_LINE ("ERROR: exception not properly raised.");
      raise PROGRAM_ERROR;
    end if;
  end Raise_Exc;

begin
  NEW_LINE (2);
  PUT_LINE ("EXCEPTION WITHIN PROCEDURE");
  PUT_LINE ("In this test an exception is raised in a procedure and");
  PUT_LINE ("handled by the caller. The same procedure call is timed without");
  PUT_LINE ("the exception being raised so the exception handling time can");
  PUT_LINE ("be determined.");

  declare
    procedure Do_Raise (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        begin
          Raise_Exc (TRUE);
        exception -- handle exception raised by the procedure
          when Exc =>
                null;
        end;
      end loop;
    end Do_Raise;

    procedure Dont_Raise (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        begin
          Raise_Exc (FALSE);
        exception
          when Exc =>
            PUT_LINE ("ERROR: exception improperly raised.");
        end;
      end loop;
    end Dont_Raise;

    package Procedure_Exception_Pkg is new Benchmark
            (Overhead => Dont_Raise,
             Item_Of_Interest => Do_Raise);

  begin
    Procedure_Exception_Pkg.Timer;
  end;
end Time_Procedure_Exception;
pragma PAGE;

procedure Time_Task_Propagation is
  Exc         : exception;

  task Some_Task is
    entry Raise_Exc (Do_It : in BOOLEAN);
  end Some_Task;

  task body Some_Task is
  begin
    loop
      begin
        select
          accept Raise_Exc (Do_It : in BOOLEAN) do
            -- raise Exc if the parameter is true otherwise do nothing
            if Do_It then
              raise Exc;
            end if;

            if Do_It then  -- make sure the exception was raised
              PUT_LINE ("ERROR: exception not properly raised.");
              raise PROGRAM_ERROR;
            end if;
          end Raise_Exc;
        or
          terminate;
        end select;
      exception
        when Exc => null;
      end;
    end loop;
  end Some_Task;

begin
  NEW_LINE (2);
  PUT_LINE ("EXCEPTION IN ENTRY");
  PUT_LINE ("In this test an exception is raised during a rendezvous.");
  PUT_LINE ("The exception is handled in both the calling environment and");
  PUT_LINE ("in the task.  The same entry is timed without");
  PUT_LINE ("the exception being raised so the exception handling time can");
  PUT_LINE ("be determined.");

  declare
    procedure Do_Raise (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        begin
          Some_Task.Raise_Exc (TRUE);
        exception -- handle exception raised by the procedure
          when Exc =>
                null;
        end;
      end loop;
    end Do_Raise;

    procedure Dont_Raise (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        begin
          Some_Task.Raise_Exc (FALSE);
        exception
          when Exc =>
            PUT_LINE ("ERROR: exception improperly raised.");
        end;
      end loop;
    end Dont_Raise;

    package Task_Exception_Pkg is new Benchmark
            (Overhead => Dont_Raise,
             Item_Of_Interest => Do_Raise);

  begin
    Task_Exception_Pkg.Timer;
  end;
end Time_Task_Propagation;
pragma PAGE;

begin  -- Do_Test
  PUT_LINE ("               Exception Propagation");
  NEW_LINE;
  PUT_LINE ("This test times exception propagation in various contexts");
  PUT_LINE ("including propagating an exception to a calling task during a");
  PUT_LINE ("rendezvous.");

  Time_Simple_Exception;
  Time_Procedure_Exception;
  Time_Task_Propagation;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Do_Test;
end Part4;
::::::::::
part4spec.ada
::::::::::
---- test section 4 - exception propagation

package Part4 is
  Title : constant STRING := "exception propagation";
  procedure Do_Test;
end Part4;
::::::::::
part5.ada
::::::::::
--- test section 5  --  task interaction
with TEXT_IO, Benchmark;
use  TEXT_IO;
package body Part5 is

  -- define the continue and terminate conditions for the tasks
  Continue_Item : constant := 1;
  Terminate_Item : constant := -1;

  -- task types that are common to several tests

  task type Called_Consumer_Type_1 is
        -- consumer is to take items until
        -- a value of Terminate_Item is accepted.
    entry Take_Item (Item : in INTEGER);
  end Called_Consumer_Type_1;


  task type Called_Consumer_Type_2 is
        -- consumer is to take items until
        -- a value of Terminate_Item is accepted.
        -- However, enabling takes must be done first.
    entry Take_Item (Item : in INTEGER);
    entry Enable_Takes;
  end Called_Consumer_Type_2;


  task body Called_Consumer_Type_1 is
    Item : INTEGER;
  begin
    loop
      accept Take_Item (Item : in INTEGER) do
        Called_Consumer_Type_1.Item := Item;
      end Take_Item;

      exit when Item = Terminate_Item;

    end loop;
  end Called_Consumer_Type_1;

  task body Called_Consumer_Type_2 is
    Item : INTEGER;
  begin
    accept Enable_Takes;
    loop
      accept Take_Item (Item : in INTEGER) do
        Called_Consumer_Type_2.Item := Item;
      end Take_Item;

      exit when Item = Terminate_Item;

    end loop;
  end Called_Consumer_Type_2;
pragma PAGE;

procedure Do_Test is

procedure Time_Procedure_Calls is
  Finished    : BOOLEAN := FALSE;

  procedure Take_Number (Num : in INTEGER) is
  begin
    -- note that Num is never 0.  The conditional recursion is to help
    -- prevent the compiler from making this procedure implicitly inline.
    if Num <= 0 then
       Take_Number (Num + 1);
    else
      Finished := Num = 1;
    end if;
  end Take_Number;

  procedure Give_Number (Iterations : in NATURAL) is
  begin
    for J in 1..Iterations loop
      Take_Number (1);
    end loop;
  end Give_Number;

begin
  NEW_LINE (2);
  PUT_LINE ("PROCEDURE CALLING");
  PUT_LINE ("In this test the time to do a procedure call is measured");
  PUT_LINE ("so it can be compared to a task entry call.  The procedure");
  PUT_LINE ("contains a minimum amount of code - just enough to keep a");
  PUT_LINE ("compiler from thinking it can be eliminated.");
  NEW_LINE;

  declare
    package Procedure_Pkg is new Benchmark
            (Item_Of_Interest => Give_Number);
  begin
    Procedure_Pkg.Timer;
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Procedure_Calls;
pragma PAGE;

procedure Time_Conditional_Entry is
  Enabled_Task   : Called_Consumer_Type_1;
  Disabled_Task  : Called_Consumer_Type_2;
  Not_Accepted_Err,
  Accepted_Err : INTEGER := 0;

  procedure Not_Accepted (Iterations : in NATURAL) is
  begin
    for J in 1..Iterations-1 loop  -- -1 to account for Enable call
      select
        Disabled_Task.Take_Item (Continue_Item);
        Not_Accepted_Err := Not_Accepted_Err + 1;
      else
        null;
      end select;
    end loop;
  end Not_Accepted;

  procedure Accepted (Iterations : in NATURAL) is
  begin
    for J in 1..Iterations-1 loop  -- -1 to account for Enable call
      select
        Enabled_Task.Take_Item (Continue_Item);
      else
        Accepted_Err := Accepted_Err + 1;
      end select;
    end loop;
  end Accepted;

begin
  NEW_LINE (2);
  PUT_LINE ("CONDITIONAL ENTRY");
  PUT_LINE ("In this test the main task calls a consumer task with a");
  PUT_LINE ("conditional entry call.  The test tries calls that are not");
  PUT_LINE ("accepted then tries calls that are accepted.");
  PUT_LINE ("Since the consumer is the same type of consumer used in the");
  PUT_LINE ("other producer/consumer tests these results can be compared");
  PUT_LINE ("to the simple producer/consumer test.");
  NEW_LINE;

  declare
    package Conditional_Pkg is new Benchmark
            (Overhead => Not_Accepted,
             Item_Of_Interest => Accepted);
  begin
    Conditional_Pkg.Timer;
    Enabled_Task.Take_Item (Terminate_Item);  -- kill off the tasks
    Disabled_Task.Enable_Takes;
    Disabled_Task.Take_Item (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Conditional_Entry;
pragma PAGE;

procedure Time_Timed_Entry is
  Enabled_Task   : Called_Consumer_Type_1;
  Disabled_Task   : Called_Consumer_Type_2;
  Not_Accepted_Err,
  Accepted_Err : INTEGER := 0;

  procedure Not_Accepted (Iterations : in NATURAL) is
  begin
    for J in 1..Iterations loop
      select
        Disabled_Task.Take_Item (Continue_Item);
        Not_Accepted_Err := Not_Accepted_Err + 1;
      or
        delay 0.0;
      end select;
    end loop;
  end Not_Accepted;

  procedure Accepted (Iterations : in NATURAL) is
  begin
    for J in 1..Iterations loop
      select
        Enabled_Task.Take_Item (Continue_Item);
      or
        delay 0.0;
        Accepted_Err := Accepted_Err + 1;
      end select;
    end loop;
  end Accepted;

begin
  NEW_LINE (2);
  PUT_LINE ("TIMED ENTRY");
  PUT_LINE ("In this test the main task calls a consumer task with a");
  PUT_LINE ("timed entry call with a time limit of 0.0.  The test tries");
  PUT_LINE ("calls that are not accepted then tries calls that are accepted.");
  PUT_LINE ("Since the consumer is the same type of consumer used in the");
  PUT_LINE ("other producer/consumer tests these results can be compared");
  PUT_LINE ("to the simple producer/consumer test.");
  NEW_LINE;

  declare
    package Timed_Entry_Pkg is new Benchmark
            (Overhead => Not_Accepted,
             Item_Of_Interest => Accepted);
  begin
    Timed_Entry_Pkg.Timer;
    Enabled_Task.Take_Item (Terminate_Item);  -- kill off the tasks
    Disabled_Task.Enable_Takes;
    Disabled_Task.Take_Item (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Timed_Entry;
pragma PAGE;

procedure Time_Family is

  type Family is range 1 .. 10;  -- size of entry family
  Family_Member : Family := 3;   -- this is the one we will use

  task Some_Task is
        -- consumer is to take items until
        -- a value of Terminat_Item is accepted.
    entry Take_Item (Family)(Item : in INTEGER);
  end Some_Task;


  task body Some_Task is
    Item : INTEGER;
  begin
    loop
      accept Take_Item (Family_Member) (Item : in INTEGER) do
        Some_Task.Item := Item;
      end Take_Item;

      exit when Item = Terminate_Item;

    end loop;
  end Some_Task;


begin
  NEW_LINE (2);
  PUT_LINE ("FAMILY OF ENTRIES");
  PUT_LINE ("This test is similar to the simple producer/consumer (SIMPLE PC)");
  PUT_LINE ("in that the main task produces integer values that are consumed");
  PUT_LINE ("by a consumer task.  The difference is that the consumer task");
  PUT_LINE ("uses a family of entries instead of a single entry.");
  NEW_LINE;

  declare
    procedure Send_Item (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations Loop
        Some_Task.Take_Item (Family_Member) (Continue_Item);
      end loop;
    end Send_Item;

    package Family_Pkg is new Benchmark
            (Item_Of_Interest => Send_Item);

  begin
    Family_Pkg.Timer;
    Some_Task.Take_Item (Family_Member) (Terminate_Item);
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Family;
pragma PAGE;

procedure Time_Simple_Sync is
  task Sync is
    entry Pass;
  end Sync;

  task body Sync is
  begin
    loop
      accept Pass;
    end loop;
  end Sync;

begin
  NEW_LINE (2);
  PUT_LINE ("SIMPLE SYNCHRONIZATION");
  PUT_LINE ("This test times the use of a simple synchronization task entry.");
  PUT_LINE ("In this type of task interaction no parameters are passed to the");
  PUT_LINE ("task entry and there is no body for the accept. The called task");
  PUT_LINE ("loops on an unconditional accept.");
  NEW_LINE;

  declare
    procedure Call_Sync (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Sync.Pass;
      end loop;
    end Call_Sync;

    package Simple_Sync_Pkg is new Benchmark
            (Item_Of_Interest => Call_Sync);

  begin
    Simple_Sync_Pkg.Timer;
    abort Sync;   -- kill off the task
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Simple_Sync;
pragma PAGE;

procedure Time_Sync_With_Term is
  task Sync is
    entry Pass;
  end Sync;

  task body Sync is
  begin
    loop
      select
        accept Pass;
      or
        terminate;
      end select;
    end loop;
  end Sync;

begin
  NEW_LINE (2);
  PUT_LINE ("SYNCHRONIZATION WITH TERMINATION");
  PUT_LINE ("This test times the use of a simple synchronization task entry.");
  PUT_LINE ("In this type of task interaction no parameters are passed to the");
  PUT_LINE ("task entry and there is no body for the accept. The called task");
  PUT_LINE ("loops on an select statement containing an accept and a");
  PUT_LINE ("terminate alternative.");
  NEW_LINE;

  declare
    procedure Call_Sync (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Sync.Pass;
      end loop;
    end Call_Sync;

    package Sync_Term_Pkg is new Benchmark
            (Item_Of_Interest => Call_Sync);

  begin
    Sync_Term_Pkg.Timer;
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Sync_With_Term;
pragma PAGE;

procedure Time_Term_Option is
  Open_Terminate : BOOLEAN := FALSE;

  task Sync is
    entry Pass;
  end Sync;

  task body Sync is
  begin
    loop
      select
        accept Pass;
      or
        when Open_Terminate =>
        terminate;
      end select;
    end loop;
  end Sync;

begin
  NEW_LINE (2);
  PUT_LINE ("TERMINATE OPTION");
  PUT_LINE ("This test times the use of a simple synchronization task entry");
  PUT_LINE ("both without and with a terminate option.  The overhead test");
  PUT_LINE ("is for the time without the terminate option.");
  PUT_LINE ("In this type of task interaction no parameters are passed to the");
  PUT_LINE ("task entry and there is no body for the accept. The called task");
  PUT_LINE ("loops on an select statement containing an accept and a");
  PUT_LINE ("conditional terminate alternative.");
  NEW_LINE;

  declare
    procedure Closed_Terminate (Iterations : in NATURAL) is
    begin
      for J in 1..Iterations loop
        Sync.Pass;
      end loop;
    end Closed_Terminate;

    procedure Opened_Terminate (Iterations : in NATURAL) is
    begin
      Open_Terminate := TRUE;
      for J in 1..Iterations loop
        Sync.Pass;
      end loop;
    end Opened_Terminate;

    package Term_Option_Pkg is new Benchmark
            (Overhead => Closed_Terminate,
             Item_Of_Interest => Opened_Terminate);

  begin
    Term_Option_Pkg.Timer;
  end;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");
end Time_Term_Option;
pragma PAGE;

begin
  PUT_LINE ("               Task Interaction");
  NEW_LINE;
  PUT_LINE ("This test times various task interactions in order to determine");
  PUT_LINE ("their relative cost. These tests are related to the task");
  PUT_LINE ("communication tests and in many cases the output should be");
  PUT_LINE ("compared to those tests (see each test for details).");

  Time_Procedure_Calls;
  Time_Conditional_Entry;
  Time_Timed_Entry;
  Time_Family;
  Time_Simple_Sync;
  Time_Sync_With_Term;
  Time_Term_Option;

exception
  when CONSTRAINT_ERROR => PUT_LINE ("*** test aborted due to constraint err");
  when NUMERIC_ERROR    => PUT_LINE ("*** test aborted due to numeric error");
  when PROGRAM_ERROR    => PUT_LINE ("*** test aborted due to program error");
  when STORAGE_ERROR    => PUT_LINE ("*** test aborted due to storage error");
  when TASKING_ERROR    => PUT_LINE ("*** test aborted due to tasking error");
  when others           => PUT_LINE ("*** test aborted due to exception");

end Do_Test;

end Part5;
::::::::::
part5spec.ada
::::::::::
---- test section 5

package Part5 is
  Title : constant STRING := "task interaction";
  procedure Do_Test;
end Part5;
::::::::::
timer_body.ada
::::::::::
--++
-- FACILITY:
--      Benchmark Driver
--
-- ABSTRACT:
--      This generic procedure provides the services necessary to time
--      a given operaion and report on the performance.
--
-- AUTHOR:
--      Tom Burger
--
-- MODIFICATION HISTORY:
----

with TEXT_IO;  use TEXT_IO;
with Cpu;      use Cpu;
with Misc_Benchmark; use Misc_Benchmark;
with SYSTEM;                        -- for SYSTEM.TICK
package body Benchmark is

Iterations : NATURAL;     -- how many iterations to run the test

procedure Determine_Necessary_Iterations is
  -- If a specified number of iterations is given then use this number;
  -- otherwise, determine the best number of iterations by starting at 1 and
  -- keep doubling the number of iterations until the time required for
  -- the item of interest is at least 100 times the clock resolution.
  -- The result of this procedure is left in the variable Iterations.

  Minimum_Time : DURATION;
  Start_Cpu,
  Stop_Cpu   : Cpu.Time;
begin
  if Number_Of_Iterations /= 0 then
    Iterations := Number_Of_Iterations;
    return;
  end if;

  if SYSTEM.TICK > DURATION'SMALL then
    Minimum_Time := 100 * SYSTEM.TICK;
  else
    Minimum_Time := 100 * DURATION'SMALL;
  end if;

  Iterations := 1;
  loop
    Start_Cpu := Cpu.Clock;
    Item_Of_Interest (Iterations);
    Stop_Cpu := Cpu.Clock;

    exit when Stop_Cpu - Start_Cpu >= Minimum_Time;

      -- check for overflow condition
    if Iterations = NATURAL'LAST / 2 + 1 then
      Iterations := NATURAL'LAST;
      exit;
    end if;
    Iterations := Iterations * 2;
  end loop;
end Determine_Necessary_Iterations;


procedure Do_Timing_Run (Results : out Results_Type;
                         Overhead_Results : out Results_Type) is

  Start,
  Stop   : Raw_Time_Info;          -- Contains Elapsed and Cpu Times

begin
  for Repetitions in 1..Test_Repetitions loop
    Get_Both_Times (Start);
    Overhead (Iterations);  -- run the overhead routine
    Get_Both_Times (Stop);
    Overhead_Results (Repetitions) := Stop - Start;

    Get_Both_Times (Start);
    Item_Of_Interest (Iterations);  -- run the item of interest routine
    Get_Both_Times (Stop);
    Results (Repetitions) := Stop - Start;
  end loop;
end Do_Timing_Run;


procedure Timer is
  Results : Results_Type (1..Test_Repetitions);
  Overhead_Results : Results_Type (1..Test_Repetitions);
begin
  Determine_Necessary_Iterations;
  Do_Timing_Run (Results, Overhead_Results);
  Print_Results (Results, Overhead_Results, Test_Repetitions, Iterations);
end Timer;

end Benchmark;
::::::::::
timer_spec.ada
::::::::::
--++
-- FACILITY:
--      Benchmark Driver
--
-- ABSTRACT:
--      This generic procedure provides the services necessary to time
--      a given operaion and report on the performance.
--
-- AUTHOR:
--      Tom Burger
--
-- MODIFICATION HISTORY:
----
with Misc_Benchmark; use Misc_Benchmark;
generic
    Test_Repetitions     : NATURAL := 5;  -- run the entire test this many times
                                          -- to check for variability in results
    Number_of_Iterations : NATURAL := 0;  -- 0 implies the number of iterations
                                          -- is to be determined.

    with procedure Overhead (Iterations : in NATURAL) is Default_Overhead;
    with procedure Item_Of_Interest (Iterations : in NATURAL);

package Benchmark is
  procedure Timer;
end Benchmark;

::::::::::
wall_clock_cpu_body.ada
::::::::::
--  this is a machine independent dummy package for reporting the amount of
--  CPU time used. It actually reports the elapsed time
with CALENDAR;  use CALENDAR;
with TEXT_IO;   use TEXT_IO;
package body Cpu is
  Base_Time : constant CALENDAR.TIME := CALENDAR.CLOCK;

function Clock return Time is
  Now : constant CALENDAR.TIME := CALENDAR.CLOCK;
begin
  return Cpu.Time (Now - Base_Time);
end Clock;

function "-" (Stop_Time, Start_Time : Time) return DURATION is
begin
  return DURATION (DURATION (Stop_Time) - DURATION (Start_Time));
end "-";

begin
  PUT_LINE ("NOTE: CPU Time is actually ELAPSED time!!!");
end Cpu;