--::::::::::
--tasking.pro
--::::::::::
-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name : Tasking Benchmarks
-- :
-- Version : Version 1.0
-- :
-- Authors : Thomas M. Burger
-- :
-- : TeleSoft, Inc.
-- : 5959 Cornerstone - West
-- : San Diego, CA 92121-9891
-- :
-- : and
-- :
-- : Kjell W. Nielsen
-- :
-- : Hughes Aircraft Company
-- : 10103 Carroll Canyon Road
-- : San Diego, CA 92131
-- :
-- DDN Address : amoses@ecla.usc.edu
-- Copyright : (c)
-- Date created :
-- Release date :
-- Last update :
-- Machine/System Compiled/Run on : DEC Ada (Version 1.2) on a VAX 8600
--
---------------------------------------------------------------
--
-- Keywords :
--
-- Abstract : A set of tasking benchmarks were developed in
-- : conjunction with the paper "An Assessment of the
-- : Overhead Associated with Tasking Facilities
-- : and Task Paradigms in Ada" which appeared in the
-- : January,February 1987 Ada Letters. These benchmarks
-- : were developed to measure the efficiency of the
-- : implementation of the Ada tasking model, and
-- : evaluate the additional cost of introducing
-- : intermediaries for the various tasking paradigms.
--
--
------------------ Revision history ---------------------------
--
-- DATE VERSION AUTHOR HISTORY
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
-- software released to the Public Domain is not subject
-- to copyright protection).
-- Restrictions on use or distribution: NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered. The user is advised to
-- test the software thoroughly before relying on it. The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------
--::::::::::
--tasking.doc
--::::::::::
Ada* Benchmark Suite
Tasking Section
Version 1.0
29 August 1986
Hughes Aircraft Company
Ground Systems Group
Software Engineering Division
San Diego Software Engineering Laboratory
Command and Control Software Department
* Ada is a registered trademark of the U.S. Government (Ada Joint
Program Office).
Ada Tasking Benchmark Version 1.0
CONTENTS
1 PURPOSE . . . . . . . . . . . . . . . . . . . . . . 1
2 TASKING BENCHMARK . . . . . . . . . . . . . . . . . 1
2.1 Task Activation/Termination Test Category . . . . 1
2.1.1 Local Array Of Null Task Bodies . . . . . . . . 1
2.1.2 Local Array Of Tasks With Terminate Option . . . 2
2.1.3 Access Type . . . . . . . . . . . . . . . . . . 2
2.2 Task Communication Test Category . . . . . . . . . 2
2.2.1 Simple Producer-Consumer . . . . . . . . . . . . 3
2.2.2 Selective Wait . . . . . . . . . . . . . . . . . 3
2.2.3 Producer-Consumer . . . . . . . . . . . . . . . 3
2.2.4 Producer-Buffer-Consumer . . . . . . . . . . . . 3
2.2.5 Producer-Buffer-Transporter-Consumer . . . . . . 4
2.2.6 Producer-Transporter-Buffer-Transporter-Consumer 4
2.2.7 Relay . . . . . . . . . . . . . . . . . . . . . 4
2.3 Task Optimizations Test Category . . . . . . . . . 5
2.3.1 Monitor . . . . . . . . . . . . . . . . . . . . 5
2.3.2 Single Accept Bodies . . . . . . . . . . . . . . 5
2.4 Exception Propagation Test Category . . . . . . . 5
2.4.1 Exception In A Block . . . . . . . . . . . . . . 6
2.4.2 Exception In A Procedure . . . . . . . . . . . . 6
2.4.3 Exception In An Entry . . . . . . . . . . . . . 6
2.5 Task Interaction Test Category . . . . . . . . . . 6
2.5.1 Procedure Calling . . . . . . . . . . . . . . . 6
2.5.2 Conditional Entry Call . . . . . . . . . . . . . 7
2.5.3 Timed Entry Call . . . . . . . . . . . . . . . . 7
2.5.4 Family Of Entries . . . . . . . . . . . . . . . 7
2.5.5 Simple Synchronization . . . . . . . . . . . . . 8
2.5.6 Synchronization With Termination . . . . . . . . 8
2.5.7 Terminate Option . . . . . . . . . . . . . . . 8
3 TIMING METHODOLOGY . . . . . . . . . . . . . . . . . 8
3.1 Timing Generic . . . . . . . . . . . . . . . . . . 9
3.2 Testing Environment . . . . . . . . . . . . . . . 9
4 REFERENCES . . . . . . . . . . . . . . . . . . . . 10
APPENDIX A BENCHMARK LISTINGS
A.1 FILE ORGANIZATION . . . . . . . . . . . . . . . . A-1
A.2 CPU_SPEC.ADA . . . . . . . . . . . . . . . . . . . A-2
A.3 CPU_BODY.ADA . . . . . . . . . . . . . . . . . . . A-3
A.4 MISC_BENCHMARK_SPEC.ADA . . . . . . . . . . . . . A-5
A.5 MISC_BENCHMARK_SPEC.ADA . . . . . . . . . . . . . A-6
A.6 TIMER_SPEC.ADA . . . . . . . . . . . . . . . . . . A-9
A.7 TIMER_BODY.ADA . . . . . . . . . . . . . . . . . A-10
A.8 WALL_CLOCK_CPU_BODY.ADA . . . . . . . . . . . . A-12
A.9 PART1SPEC.ADA . . . . . . . . . . . . . . . . . A-13
A.10 PART1.ADA . . . . . . . . . . . . . . . . . . . A-14
A.11 PART2SPEC.ADA . . . . . . . . . . . . . . . . . A-17
A.12 PART2.ADA . . . . . . . . . . . . . . . . . . . A-18
A.13 PART3SPEC.ADA . . . . . . . . . . . . . . . . . A-31
A.14 PART3.ADA . . . . . . . . . . . . . . . . . . . A-32
Ada Tasking Benchmark Version 1.0
A.15 PART4SPEC.ADA . . . . . . . . . . . . . . . . . A-37
A.16 PART4.ADA . . . . . . . . . . . . . . . . . . . A-38
A.17 PART5SPEC.ADA . . . . . . . . . . . . . . . . . A-43
A.18 PART5.ADA . . . . . . . . . . . . . . . . . . . A-44
A.19 DRIVER.ADA . . . . . . . . . . . . . . . . . . A-54
Ada Tasking Benchmark Version 1.0 Page 1
1 PURPOSE
The Ada Benchmark Suite has been developed to provide a foundation for
the performance evaluation of various Ada compiler systems. The
benchmarks are used to measure compilation speed and execution speed
of the Ada systems.
This report describes the tasking benchmarks contained in the suite
and provides a listing of the benchmarks in Appendix A. This report
also describes the timing methodology used to gather measurements.
2 TASKING BENCHMARK
The use of the Ada tasking model incurs certain overhead costs
associated with, for example, task activation and termination, context
switching, and synchronization. There are five general categories of
tests, with each category divided into individually timed tests. The
Tasking benchmark is 1904 source lines of code. The following
paragraphs describe the tasking tests performed.
2.1 Task Activation/Termination Test Category
Since Ada does not include a real-time executive, task activation and
termination are not accomplished via programmer-written executive
service requests. Task activation and termination in Ada is a part of
the tasking model semantics, and is perfomed automatically based on an
elaborate set of rules [BAR84, p.209, and GEH84, p. 45]. The
follwing paragraphs describe the task activation and termination
tests.
2.1.1 Local Array Of Null Task Bodies
Declaring a task within a procedure causes the task to be activated
each time the procedure is called. The procedure will not return to
its caller until the task terminates.
In this test an array of tasks is declared locally to a procedure.
Both the procedure and the task have null bodies. The length of the
array is determined by the iteration count (i.e., an iteration of one
means the array length is one). Therefore, the timing per iteration
is the time to activate and terminate one task in the array.
Ada Tasking Benchmark Version 1.0 Page 2
2.1.2 Local Array Of Tasks With Terminate Option
In this test an array of tasks is declared locally to a procedure.
The task uses the terminate option in a select statement to terminate.
The task is never called. The length of the array is determined by
the iteration count.
2.1.3 Access Type
It is possible to create tasks dynamically by using an allocator.
Tasks created in this fashion are immediately activated.
In this test an access type to a task is used to create a series of
tasks. The timing per iteration includes both allocation and
deallocation of the task as well as activation and termination.
2.2 Task Communication Test Category
The method used in Ada for task communcation is called the
"rendezvous." The rendezvous is a synchronous operation and therefore
limits the amount of asynchronous action between tasks. It is often
desirable to uncouple [NIE86] the task interaction to some extent in
order to allow more independence and increase the amount of
concurrency. Intermediary tasks are often used to accomplish this
uncoupling. Intermediary tasks are classified as "buffers,"
"transporters," or "relays" depending upon the caller/called
relationships between the tasks. A "buffer" is a pure server task.
It provides one entry for storing of items in a buffer, and another
entry for providing items from the buffer. A "transporter" is a pure
caller. It obtains an item by calling a producer (or intermediary)
task, and "transports" that item by calling a consumer (or
intermediary) task. A "relay" is a mixture of a caller and server.
It obtains an item by calling a producer (or intermediary) task, and
"relays" that item when it is called by a consumer (or intermediary)
task. (Alternately, a relay may be called by a producer, and call a
consumer).
In addition to providing more independence between tasks (higher
degree of asynchronicity), intermediary tasks are also used to alter
the caller/called relationships. Sometimes it is more advantageous to
be a called task and other times it is more advantageous to be a
calling task. The use of a buffer allows two calling tasks to
communicate while the use of a transporter allows two called tasks to
communicate. A relay preserves the caller/called relationships while
providing a degree of uncoupling.
The case where one task passes information to another task is called a
producer-consumer (PC) relationship. The task that is the source of
the information is called the producer and the task that is the
Ada Tasking Benchmark Version 1.0 Page 3
recipient of the information is called the consumer. One or more
rendezvous are used to pass the information from the producer to the
consumer. A rendezvous is a rough measure of two Ada context switches
since the caller is suspended until the rendezvous is complete. The
first context switch is from the caller to the called task and the
second context switch is the return to the caller task.
The following paragraphs describe the task communication tests.
2.2.1 Simple Producer-Consumer
In this test the main procedure calls a consumer task. A simple
integer value is the only data transferred and the consumer simply
loops on the accept. Task activation/termination time is not included
in the timing. An iteration consists of one rendezvous.
2.2.2 Selective Wait
In this test the main procedure calls a consumer task that has two
entries. A simple integer value is the only data transferred and the
consumer simply loops on the selective accept. This test differs from
the previous test in that the consumer uses a select statement to take
the entry call where the select has two open alternatives. In the
previous case there was no select statement. An iteration consists of
one rendezvous.
2.2.3 Producer-Consumer
In this test a producer task communicates with a consumer task
directly. This timing should be similar to the simple
producer-consumer test. An iteration consists of one rendezvous.
2.2.4 Producer-Buffer-Consumer
It is often the case that a producer and a consumer will communicate
via a buffer, i.e., producer-buffer-consumer (PBC). A buffer serves
to uncouple the producer from the consumer thus providing a higher
degree of independence. A buffer is a task, and therefore its use
adds some overhead. Each time a piece of information is passed from
the producer to the consumer two rendezvous occur - the producer with
the buffer and the consumer with the buffer. This arrangement
requires that both the producer and the consumer be calling tasks
since a buffer is strictly a called task.
In this test a producer task communicates with a consumer task
Ada Tasking Benchmark Version 1.0 Page 4
indirectly through a bounded buffer (buffer size = 2). An iteration
consists of two rendezvous.
2.2.5 Producer-Buffer-Transporter-Consumer
Many times a producer will want to communicate with a consumer via a
buffer, but it is undesirable for the consumer to be a calling task.
For example, the consumer may want to accept requests from any number
of producers and therefore would want to be a called task. This can
be accomplished by having a transporter task take information from the
buffer and pass it on to the consumer, i.e.,
producer-buffer-transporter-consumer (PBTC). This means that two
intermediary tasks are used between the producer and the consumer.
Each time a piece of information is passed from the producer to the
consumer three rendezvous occur - the producer with the buffer, the
transporter with the buffer, and the transporter with the consumer.
In this test a producer task communicates with a consumer task
indirectly through a bounded buffer (buffer size = 2) with a
transporter between the buffer and the consumer. An iteration
consists of three rendezvous.
2.2.6 Producer-Transporter-Buffer-Transporter-Consumer
In the event that a producer and a consumer wish to communicate via a
buffer and both need to be called tasks, it is necessary to use a
transporter on each side of the buffer. This results in the
producer-transporter-buffer-transporter-consumer (PTBTC) paradigm.
Each time a piece of information is passed from the producer to the
consumer four rendezvous occur - a transporter with the producer, the
transporter with the buffer, a second transporter with the buffer, and
the second transporter with the consumer.
In this test a producer task communicates with a consumer task
indirectly through a bounded buffer (buffer size = 2) with a
transporter for both the producer and the consumer. An iteration
consists of four rendezvous.
2.2.7 Relay
A relay is an intermediary task that takes information from a producer
and passes it on to the consumer. For each piece of information that
is passed from the producer to the consumer two rendezvous occur - the
producer with the relay and the relay with the consumer.
In this test a producer task communicates with a consumer task
indirectly through a relay. In terms of the task communication model,
Ada Tasking Benchmark Version 1.0 Page 5
this resembles th PBTC paradigm but in terms of performance it should
resemble the PBC test. An iteration consists of two rendezvous.
2.3 Task Optimizations Test Category
This test category determines if the implementation optimizes various
special cases of tasking. The specific optimizations being tested for
are machine independent optimizations that have been discussed in the
Ada literature [HIL82, HAB80]. For each specific optimization the
general case and the special case are timed. If the special case is
significantly faster than the general case then it is assumed that the
optimization technique is employed. An iteration consists of the
general case time minus the special case time. For iteration times
near zero, it can be assumed that the optimization is not done.
2.3.1 Monitor
A task that contains no code outside of the accept bodies is
considered to be a monitor. It is possible to eliminate such a task
by protecting the task entries with semaphores.
In this test the main procedure interacts with a monitor and with a
more general task in order to determine if this optimization is
performed.
2.3.2 Single Accept Bodies
In the case where a task entry has a single accept body there is no
need for the indirect referencing that may be used when a single entry
has multiple accept bodies.
This test checks to see if calls to entries that have a single accept
body are more efficient than when multiple accept bodies are used.
2.4 Exception Propagation Test Category
The raising of an exception is the means by which error and
exceptional conditions are reported in Ada. An exception handler is
used to respond to an exception that has been raised. Three types of
exception handling are examined here to determine the cost of raising
and propagating an exception. Each test is timed without the
exception being raised and with the exception being raised. An
iteration consists of the difference in these times (raised minus not
raised).
Ada Tasking Benchmark Version 1.0 Page 6
2.4.1 Exception In A Block
A block is a statement that may contain declarations, a sequence of
statements, and an exception handler. An exception that is raised and
handled within the same block is the simplest form of exception
handling.
In this test an exception is raised and handled in the same block.
The user defined exception is declared local to the block where it is
raised.
2.4.2 Exception In A Procedure
If an exception is raised within a procedure that does not have an
exception handler for that exception, then the exception is propagated
to the caller procedure.
In this test an exception is raised in a procedure and handled by the
caller.
2.4.3 Exception In An Entry
If an exception is raised within a rendezvous, then it is propagated
to the task containing the accept as well as to the calling task.
This is the most complex form of exception handling since the
exception is handled in both the task containing the accept and by the
calling task.
In this test an exception is raised during a rendezvous. The
exception is handled in both the calling environment and in the called
task.
2.5 Task Interaction Test Category
This test category times various task interactions in order to
determine their relative cost. These tests are related to the task
communication tests and in many cases the output should be compared to
those tests.
2.5.1 Procedure Calling
In this test the time to do a procedure call is measured so it can be
used in comparing the tasking overhead to the time of a procedure call
(i.e., normalized to a procedure call). The procedure contains a
minimum amount of code, just enough to keep a compiler from thinking
Ada Tasking Benchmark Version 1.0 Page 7
it can be eliminated. An iteration consists of one procedure call.
2.5.2 Conditional Entry Call
When one task wishes to call an entry in another task it has the
option of:
a. making the call if and only if the called task is ready to
accept the call, or
b. blocking until the called task is ready.
The first of these two choices is a conditional entry call.
In this test the main procedure calls a consumer task using a
conditional entry call. The test first tries calls that are not
accepted, then tries calls that are accepted. Since the consumer is
the same type of consumer used in the other producer/consumer tests,
these results can be compared to the simple producer/consumer test.
An iteration consists of the "accepted call timing" minus the "not
accepted call timing" (i.e., the rendezvous time plus the overhead of
the conditional call).
2.5.3 Timed Entry Call
Like the conditional entry mechanism, the timed entry mechanism gives
the calling task a degree of control over the call to the task entry.
A timed entry call allows the calling task to specify how long it is
willing to wait for the rendezvous to start. If this time limit
expires prior to the start of the rendezvous then the call is
cancelled.
In this test the main procedure calls a consumer task with a timed
entry call containing a time limit of 0.0. The test tries calls that
are not accepted then tries calls that are accepted. Since the
consumer is the same type of consumer used in the other
producer/consumer tests, these results can be compared to the simple
producer/consumer test. An iteration consists of the "accepted call
timing" minus the "not accepted call timing" (i.e., the rendezvous
time plus the overhead of the timed entry call).
2.5.4 Family Of Entries
This test is similar to the simple producer/consumer in that the main
procedure produces integer values that are consumed by a consumer
task. The difference is that the consumer task uses a family of
entries instead of a single entry. An iteration consists of one
Ada Tasking Benchmark Version 1.0 Page 8
rendezvous.
2.5.5 Simple Synchronization
This test times the use of a simple synchronization task entry. In
this type of task interaction no parameters are passed to the task
entry and there is no body for the accept. The called task loops on
an unconditional accept. An iteration consists of one rendezvous.
2.5.6 Synchronization With Termination
This test times the use of a simple synchronization task entry. In
this type of task interaction no parameters are passed to the task
entry and there is no body for the accept. The called task loops on a
select statement containing an accept and a terminate alternative. An
iteration consists of one rendezvous.
2.5.7 Terminate Option
A group of tasks can cooperatively terminate by using the terminate
option of the select statement.
This test times the use of a simple synchronization task entry both
without and with a terminate option. In this type of task interaction
no parameters are passed to the task entry and there is no body for
the accept. The called task loops on a select statement containing an
accept and a conditional terminate alternative. An iteration consists
of the difference in time between having the terminate option open and
having the terminate option closed.
3 TIMING METHODOLOGY
This section describes the timing methodology employed with the
benchmark tests. For compiler speed, the measurements are taken from
the timing information generated by the compiler. For execution
speed, a generic package is used by the benchmark programs to output
the CPU time and wall-clock time elapsed during the execution of the
benchmark program. The benchmark programs are compiled and executed
in a controlled environment to limit distortion of measurements.
Ada Tasking Benchmark Version 1.0 Page 9
3.1 Timing Generic
The generic package Benchmark is used by the benchmark programs to
output timing measurements. The package specification for Benchmark
is shown below:
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;
The generic parameter Item_of_Interest is the benchmark program or
feature that is measured. The generic parameter Overhead is the
overhead involved with measuring Item_Of_Interest.
After being instantiated as (for example):
package New_Benchmark is new Benchmark (Item_Of_Interest =>
Thing_To_Be_Measured);
a call to New_Benchmark.Timer causes the measurements for this test to
be timed and output. The measurements are based on a number of
iterations of the "Thing_To_Be_Measured" calculated as: the number
that is required to have the measurements one hundred times greater
than the resolution of the system time.
When available, a system call to a timer function is supplied in a
library unit.
3.2 Testing Environment
The testing environment is controlled to limit the distortion of
timing measurements [CLA86]. Benchmark programs are compiled and
executed in a batch mode in the evening. Although this scheme does
Ada Tasking Benchmark Version 1.0 Page 10
not entirely eliminate operating system interference (i.e., time
slicing, daemon processes, and paging) or other user interference, the
results are more realistic than those obtained in an interactive mode.
4 REFERENCES
___________ __ ___
BAR84 Barnes, J. G. P., Programming in Ada, Second Edition,
Addison-Wesly, 1984.
CLA86 Clapp, R.M., Duchesneau, L., Volz, R.A., Mudge, T.N., and
______ _________ ___________ __________
Schultze, T., Toward Real-Time Performance Benchmarks
___ ___
for Ada, RSD-TR-6-86, Electrical Engineering and Computer
Science Department, University of Michigan, Ann Arbor,
January, 1986.
___ __________ ___________
GEH84 Gehani, N., Ada Concurrent Programming, Prentice-Hall,
1984.
HAB80 Habermann, A. N. and I. R. Nassi, "Efficient Implementation of
Ada Tasks," Technical Report CMU-CS-80-103, Carnegie-Mellon
University, January 1980.
HIL82 Hilfinger, D. N., "Implementation Strategies for Ada Tasking
Idioms," Proceedings of the AdaTEC Conference on Ada,
October 6-8, 1982.
NIE86 Nielsen, K. W., "Task Coupling and Cohesion in Ada," Ada
Letters, Volume VI, Number 4, July/August 1986.
WEI84 Weicker, R. P., "Dhrystone: A Synthetic Systems Programming
Benchmark," Communications of the ACM, October 1984.
APPENDIX A
BENCHMARK LISTINGS
A.1 FILE ORGANIZATION
The organization of the files for these benchmarks is presented below.
The timing benchmark files must be compiled first, in the following
order:
a. CPU_SPEC.ADA
b. CPU_BODY.ADA
c. MISC_BENCHMARK_SPEC.ADA
d. MISC_BENCHMARK_BODY.ADA
e. TIMER_SPEC.ADA
f. TIMER_BODY.ADA
The file WALL_CLOCK_CPU_BODY.ADA outputs the elapsed time as the cpu
time. This is machine independent and can be used until a CPU_BODY is
developed for the specific target machine.
The tasking benchmark files must be compiled in the following order:
a. package specification file before respective body (e.g.,
PART1SPEC.ADA before PART1.ADA)
b. all the specifications must be compiled before DRIVER.ADA.
Ada Benchmark Suite Version 1.0 Page A-2
A.2 CPU_SPEC.ADA
The following is a listing of the specification for package Cpu:
-- 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;
Ada Benchmark Suite Version 1.0 Page A-3
A.3 CPU_BODY.ADA
The following is a listing of the body for package Cpu:
-- this is a machine specific package for reporting the amount of
-- CPU time used. The CPU time is expressed in centiseconds.
with TEXT_IO; use TEXT_IO;
with SYSTEM;
package body Cpu is
type Item_List is
record
Code : SHORT_INTEGER;
Buffer_Length : SHORT_INTEGER;
Buffer_Address : SYSTEM.ADDRESS;
Return_Len_Addr : SYSTEM.ADDRESS;
End_List : INTEGER := 0; -- marks end of requests
end record;
for Item_List use
record
Code at 0 range 16 .. 31;
Buffer_Length at 0 range 0 .. 15;
Buffer_Address at 4 range 0 .. 31;
Return_Len_Addr at 8 range 0 .. 31;
End_List at 12 range 0 .. 31;
end record;
procedure GetJPIW (Status : out INTEGER;
Efn : in INTEGER := 0; -- not used
PidAdr : in INTEGER := INTEGER'NULL_PARAMETER;
PrcNam : in INTEGER := INTEGER'NULL_PARAMETER;
ItmLst : in out Item_List;
Iosb : in INTEGER := INTEGER'NULL_PARAMETER;
AstAdr : in INTEGER := INTEGER'NULL_PARAMETER;
AstPrm : in INTEGER := INTEGER'NULL_PARAMETER;
Nullarg: in INTEGER := INTEGER'NULL_PARAMETER);
pragma INTERFACE (SYSTEM, GetJPIW);
pragma IMPORT_VALUED_PROCEDURE (GetJPIW, "SYS$GETJPIW",
MECHANISM => (VALUE, REFERENCE, REFERENCE, DESCRIPTOR, REFERENCE,
REFERENCE, REFERENCE, REFERENCE, REFERENCE));
function Clock return Time is
JPI_CPUTIM : constant := 1031; -- accumulated cpu time
Rslt_Len,
Ticks : INTEGER := 0;
Rqst : Item_List;
Status : INTEGER;
pragma VOLATILE (Ticks);
pragma VOLATILE (Rslt_Len);
Ada Benchmark Suite Version 1.0 Page A-4
begin
Rqst.Buffer_Length := 4; -- 4 bytes in a longword
Rqst.Buffer_Address := Ticks'ADDRESS;
Rqst.Return_Len_Addr := Rslt_Len'ADDRESS;
Rqst.Code := JPI_CPUTIM;
GetJPIW (Status => Status, ItmLst => Rqst);
if Status /= 1 or Rslt_Len /= 4 then
PUT_LINE ("bad status from Get_JPIW = " & INTEGER'IMAGE (Status) &
" len = " & INTEGER'IMAGE (Rslt_Len));
end if;
return Time(Time(Ticks) * Time(0.01));
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;
Ada Benchmark Suite Version 1.0 Page A-5
A.4 MISC_BENCHMARK_SPEC.ADA
The following is a listing of the specification for package Misc_Benchmark:
-- 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;
Ada Benchmark Suite Version 1.0 Page A-6
A.5 MISC_BENCHMARK_SPEC.ADA
The following is a listing of the body for package Misc_Benchmark:
-- 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 |");
Ada Benchmark Suite Version 1.0 Page A-7
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;
Ada Benchmark Suite Version 1.0 Page A-8
end Default_Overhead;
begin
null;
end Misc_Benchmark;
Ada Benchmark Suite Version 1.0 Page A-9
A.6 TIMER_SPEC.ADA
The following is a listing of the specification for package Benchmark:
--++
-- 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;
Ada Benchmark Suite Version 1.0 Page A-10
A.7 TIMER_BODY.ADA
The following is a listing of the body for package Benchmark:
--++
-- 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;
Ada Benchmark Suite Version 1.0 Page A-11
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;
Ada Benchmark Suite Version 1.0 Page A-12
A.8 WALL_CLOCK_CPU_BODY.ADA
The following is a machine independent listing of the body for package Cpu:
-- 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;
Ada Benchmark Suite Version 1.0 Page A-13
A.9 PART1SPEC.ADA
The following is a listing of the specification for the package Part_1:
---- test section 1
package Part1 is
Title : constant STRING := "task activation/termination";
procedure Do_Test;
end Part1;
Ada Benchmark Suite Version 1.0 Page A-14
A.10 PART1.ADA
The following is a listing of the body for the package Part_1:
---- 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
Ada Benchmark Suite Version 1.0 Page A-15
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
Ada Benchmark Suite Version 1.0 Page A-16
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;
Ada Benchmark Suite Version 1.0 Page A-17
A.11 PART2SPEC.ADA
The following is a listing of the specification for the package Part_2:
---- test section 2
package Part2 is
Title : constant STRING := "task communication";
procedure Do_Test;
end Part2;
Ada Benchmark Suite Version 1.0 Page A-18
A.12 PART2.ADA
The following is a listing of the body for the package Part_2:
--- 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;
Ada Benchmark Suite Version 1.0 Page A-19
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
Ada Benchmark Suite Version 1.0 Page A-20
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.");
Ada Benchmark Suite Version 1.0 Page A-21
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;
Ada Benchmark Suite Version 1.0 Page A-22
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
Ada Benchmark Suite Version 1.0 Page A-23
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");
Ada Benchmark Suite Version 1.0 Page A-24
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;
Ada Benchmark Suite Version 1.0 Page A-25
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);
Ada Benchmark Suite Version 1.0 Page A-26
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
Ada Benchmark Suite Version 1.0 Page A-27
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;
Ada Benchmark Suite Version 1.0 Page A-28
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;
Ada Benchmark Suite Version 1.0 Page A-29
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");
Ada Benchmark Suite Version 1.0 Page A-30
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;
Ada Benchmark Suite Version 1.0 Page A-31
A.13 PART3SPEC.ADA
The following is a listing of the specification for the package Part_3:
---- test section 3
package Part3 is
Title : constant STRING := "task optimization";
procedure Do_Test;
end Part3;
Ada Benchmark Suite Version 1.0 Page A-32
A.14 PART3.ADA
The following is a listing of the body for the package Part_3:
------ 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
Ada Benchmark Suite Version 1.0 Page A-33
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;
Ada Benchmark Suite Version 1.0 Page A-34
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
Ada Benchmark Suite Version 1.0 Page A-35
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");
Ada Benchmark Suite Version 1.0 Page A-36
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;
Ada Benchmark Suite Version 1.0 Page A-37
A.15 PART4SPEC.ADA
The following is a listing of the specification for the package Part_4:
---- test section 4 - exception propagation
package Part4 is
Title : constant STRING := "exception propagation";
procedure Do_Test;
end Part4;
Ada Benchmark Suite Version 1.0 Page A-38
A.16 PART4.ADA
The following is a listing of the body for the package Part_4:
---------- 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;
Ada Benchmark Suite Version 1.0 Page A-39
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);
Ada Benchmark Suite Version 1.0 Page A-40
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.");
Ada Benchmark Suite Version 1.0 Page A-41
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");
Ada Benchmark Suite Version 1.0 Page A-42
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;
Ada Benchmark Suite Version 1.0 Page A-43
A.17 PART5SPEC.ADA
The following is a listing of the specification for the package Part_5:
---- test section 5
package Part5 is
Title : constant STRING := "task interaction";
procedure Do_Test;
end Part5;
Ada Benchmark Suite Version 1.0 Page A-44
A.18 PART5.ADA
The following is a listing of the body for the package Part_5:
--- 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;
Ada Benchmark Suite Version 1.0 Page A-45
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");
Ada Benchmark Suite Version 1.0 Page A-46
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);
Ada Benchmark Suite Version 1.0 Page A-47
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;
Ada Benchmark Suite Version 1.0 Page A-48
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");
Ada Benchmark Suite Version 1.0 Page A-49
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
Ada Benchmark Suite Version 1.0 Page A-50
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
Ada Benchmark Suite Version 1.0 Page A-51
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
Ada Benchmark Suite Version 1.0 Page A-52
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");
Ada Benchmark Suite Version 1.0 Page A-53
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;
Ada Benchmark Suite Version 1.0 Page A-54
A.19 DRIVER.ADA
The following is a listing of the driver for the Tasking benchmark:
---------------- 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
Ada Benchmark Suite Version 1.0 Page A-55
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;
Ada Benchmark Suite Version 1.0 Page A-56
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 ( 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;
Ada Benchmark Suite Version 1.0 Page A-57
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;
--::::::::::
--tasking.src
--::::::::::
::::::::::
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 ( 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;