source code
-- The Computer Language Benchmarks Game
-- http://benchmarksgame.alioth.debian.org/
--
-- Contributed by Francois Fabien (9 septembre 2011)
--
-- Based on the original Ada version by
-- Claude Kaiser and Jean-Francois Pradat-Peyre (CEDRIC - CNAM Paris)
--
-- Chameneos are Ada tasks, mapped to OS threads.
-- The meeting place is a protected body with a requeue entry.
-- On a single-core, tests are run in sequence; on a multicore in parallel.
--
-- Expected build command:
-- gnatmake -O3 chameneosredux.adb
------------------------------------------------------------------------------
pragma Suppress (All_Checks);
pragma Restrictions (No_Abort_Statements);
pragma Restrictions (Max_Select_Alternatives => 0);
pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
with System; use System;
with Ada.Command_Line; use Ada.Command_Line;
with Chameneos; use Chameneos;
with System.Task_Info;
procedure ChameneosRedux is
pragma Priority (Max_Priority);
-- GNU ld will remove unused sections; GNAT specific
pragma Linker_Options ("-Wl,--gc-sections");
Meeting_count : Meetings := 600; -- default value
begin
if Argument_Count > 0 then
begin
Meeting_count := Meetings'Value (Argument (1));
exception
when others =>
-- When wrong argument, keep meetings := 600
null;
end;
end if;
Chameneos.Print_Colours;
if Task_Info.Number_Of_Processors > 1 then
Chameneos.Run_Multicore (Meeting_count);
else
Chameneos.Run (Meeting_count, 3);
Chameneos.Run (Meeting_count, 10);
end if;
end ChameneosRedux;
------------------------------------------------------------------------------
-- Root package
-- Definitions and test procedure (run)
------------------------------------------------------------------------------
package Chameneos is
Max_Creatures : constant := 10;
type Meetings is range 0 .. +(2 ** 31 - 1);
for Meetings'Size use 32; --32bits even on x64
type Colour is (Blue, Red, Yellow);
-- The creature Name
type Id_Type is range 1 .. Max_Creatures;
Max_Set : constant array (Id_Type) of Colour :=
(Blue,
Red,
Yellow,
Red,
Yellow,
Blue,
Red,
Yellow,
Red,
Blue);
-- The test procedure for single core
procedure Run (Meetings_Nbr : Meetings; Task_Nbr : Id_Type);
-- The test procedure for multicore
procedure Run_Multicore (Meetings_Nbr : Meetings);
-- Ancilliary procedure used for output
procedure Print_Colours;
function Do_Complement (C1, C2 : Colour) return Colour;
-- since this function is heavily used, make it inline to speed up
pragma Inline (Do_Complement);
end Chameneos;
------------------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Chameneos.Creatures; use Chameneos.Creatures;
package body Chameneos is
package Meet_Io is new Ada.Text_IO.Integer_IO (Meetings);
type Measures is array (Id_Type range <>) of Measure_Item;
type String_Access is access all String;
Colour_Image : constant array (Colour) of String_Access :=
(Blue => new String'("blue"),
Red => new String'("red"),
Yellow => new String'("yellow"));
-- global data because of memory leak
Numbers_Image : constant array (0 .. 9) of String_Access :=
(0 => new String'("zero "),
1 => new String'("one "),
2 => new String'("two "),
3 => new String'("three "),
4 => new String'("four "),
5 => new String'("five "),
6 => new String'("six "),
7 => new String'("seven "),
8 => new String'("eight "),
9 => new String'("nine "));
function Do_Complement (C1, C2 : Colour) return Colour is
begin
case C1 is
when Blue =>
case C2 is
when Blue =>
return Blue;
when Red =>
return Yellow;
when Yellow =>
return Red;
end case;
when Red =>
case C2 is
when Blue =>
return Yellow;
when Red =>
return Red;
when Yellow =>
return Blue;
end case;
when Yellow =>
case C2 is
when Blue =>
return Red;
when Red =>
return Blue;
when Yellow =>
return Yellow;
end case;
end case;
end Do_Complement;
function Spelled (Value : Meetings) return String is
Result : Unbounded_String := Null_Unbounded_String;
K : Natural := Natural (Value);
begin
loop
Result := Numbers_Image (K rem 10).all & Result;
K := K / 10;
exit when K = 0;
end loop;
return To_String (Result);
end Spelled;
procedure Join (Set : Creature_Sets) is
Finished : Boolean := False;
First : Id_Type := Id_Type'First;
begin
while not Finished loop
Finished := True;
for I in First .. Set'Last loop
if not Set (I)'Terminated then
Finished := False;
delay 0.001;
exit;
else
First := I;
end if;
end loop;
end loop;
end Join;
pragma Inline (Join);
procedure Output (Measure : in Measures) is
Total_Meetings : Meetings := 0;
begin
for I in Measure'Range loop
Put (Colour_Image (Max_Set (I)).all & " ");
end loop;
New_Line;
for I in Measure'Range loop
Total_Meetings := Total_Meetings + Measure (I).Meetings_Made;
Meet_Io.Put (Measure (I).Meetings_Made, Width => 10);
Put_Line (" " & Spelled (Measure (I).Meetings_Same));
end loop;
Put (Spelled (Total_Meetings));
New_Line (2);
end Output;
procedure Run (Meetings_Nbr : Meetings; Task_Nbr : Id_Type) is
Creature_Set : Creature_Sets (1 .. Task_Nbr);
Measure : Measures (1 .. Task_Nbr);
begin
-- Meeting Place initialization
Init_Mall (1, Meetings_Nbr);
-- launch the tasks
for I in 1 .. Task_Nbr loop
Creature_Set (I).Start (1, I, Max_Set (I));
end loop;
-- Rendez-vous : Waiting for the the completion of tasks
for I in 1 .. Task_Nbr loop
Creature_Set (I).Report (Measure (I));
end loop;
Join (Creature_Set);
Output (Measure);
end Run;
procedure Run_Multicore (Meetings_Nbr : Meetings) is
Creature_Set_3 : Creature_Sets (1 .. 3);
Measure_3 : Measures (1 .. 3);
Creature_Set_10 : Creature_Sets (1 .. 10);
Measure_10 : Measures (1 .. 10);
begin
-- initialization of the 2 Meeting Places
Init_Mall (1, Meetings_Nbr);
Init_Mall (2, Meetings_Nbr);
-- launch the tasks
for I in Id_Type range 1 .. 3 loop
Creature_Set_3 (I).Start (1, I, Max_Set (I));
end loop;
for I in Id_Type range 1 .. 10 loop
Creature_Set_10 (I).Start (2, I, Max_Set (I));
end loop;
-- Rendez-vous : Waiting for the the completion of tasks
for I in Id_Type range 1 .. 10 loop
Creature_Set_10 (I).Report (Measure_10 (I));
end loop;
Join (Creature_Set_10);
for I in Id_Type range 1 .. 3 loop
Creature_Set_3 (I).Report (Measure_3 (I));
end loop;
Join (Creature_Set_3);
Output (Measure_3);
Output (Measure_10);
end Run_Multicore;
procedure Print_Colours is
procedure Print_One_Line (C1, C2 : Colour) is
begin
Put_Line
(Colour_Image (C1).all &
" + " &
Colour_Image (C2).all &
" -> " &
Colour_Image (Do_Complement (C1, C2)).all);
end Print_One_Line;
begin
for Self in Colour loop
for Other in Colour loop
Print_One_Line (Self, Other);
end loop;
end loop;
New_Line;
end Print_Colours;
end Chameneos;
------------------------------------------------------------------------------
-- The chameneos description
------------------------------------------------------------------------------
with System;
package Chameneos.Creatures is
type Place_Index is range 1 .. 2;
-- Stuff required for the measurement
type Measure_Item is record
Meetings_Made : Meetings := 0;
Meetings_Same : Meetings := 0;
end record;
--A chameneos is an Ada task
task type Creature is
pragma Priority (System.Default_Priority);
pragma Storage_Size (31000);
entry Start
(Place_Nbr : in Place_Index;
Id : in Id_Type;
C : in Colour);
entry Report (Item : out Measure_Item);
end Creature;
type Creature_Sets is array (Id_Type range <>) of Creature;
procedure Init_Mall (Place_Nbr : Place_Index; Max_Count : in Meetings);
end Chameneos.Creatures;
------------------------------------------------------------------------------
package body Chameneos.Creatures is
-- specification of the meeting place where 2 tasks transfer Id.
-- the entry point is Meet for all tasks, the first incoming task is
-- requeued at the Waiting entry.
protected type Places is
procedure Init (Max_Count : in Meetings);
entry Meet
(X : in Id_Type;
C : in Colour;
Mall_Open : out Boolean;
Name_Other : out Id_Type;
Color_Other : out Colour);
private
entry Waiting
(X : in Id_Type;
C : in Colour;
Mall_Open : out Boolean;
Name_Other : out Id_Type;
Color_Other : out Colour);
First_Call, Ready : Boolean;
A_Colour, B_Colour : Colour;
A_Name, B_Name : Id_Type;
Meetings_Counter : Meetings;
end Places;
Place : array (Place_Index) of Places;
task body Creature is
My_Place : Place_Index;
My_ID, Other_Id : Id_Type;
My_Colour, Other_Colour : Colour;
L_Measure : Measure_Item := (0, 0);
Is_Mall_Open : Boolean;
begin
accept Start (
Place_Nbr : in Place_Index;
Id : in Id_Type;
C : in Colour) do
My_Place := Place_Nbr;
My_ID := Id;
My_Colour := C;
end Start;
loop
Place (My_Place).Meet
(My_ID,
My_Colour,
Is_Mall_Open,
Other_Id,
Other_Colour);
if not Is_Mall_Open then
-- the test is finished
exit;
end if;
My_Colour := Do_Complement (My_Colour, Other_Colour);
L_Measure.Meetings_Made := L_Measure.Meetings_Made + 1;
if Other_Id = My_ID then
L_Measure.Meetings_Same := L_Measure.Meetings_Same + 1;
end if;
end loop;
-- Give the results and die.
accept Report (Item : out Measure_Item) do
Item := L_Measure;
end Report;
end Creature;
protected body Places is
procedure Init (Max_Count : in Meetings) is
begin
Meetings_Counter := Max_Count;
First_Call := True;
Ready := True;
end Init;
entry Meet
(X : in Id_Type;
C : in Colour;
Mall_Open : out Boolean;
Name_Other : out Id_Type;
Color_Other : out Colour) when Ready
is
begin
if (Meetings_Counter = 0) then
-- The test is finished
Mall_Open := False;
-- must give dummy values that will not be used anyway
Name_Other := 1;
Color_Other := Red;
return;
end if;
Mall_Open := True;
if (First_Call) then
First_Call := False;
A_Name := X;
A_Colour := C;
requeue Waiting;
else
Meetings_Counter := Meetings_Counter - 1;
B_Name := X;
B_Colour := C;
Name_Other := A_Name;
Color_Other := A_Colour;
Ready := False; -- block next incoming task
First_Call := True; -- enable Waiting entry
end if;
end Meet;
entry Waiting
(X : in Id_Type;
C : in Colour;
Mall_Open : out Boolean;
Name_Other : out Id_Type;
Color_Other : out Colour) when First_Call
is
pragma Unreferenced (X, C);
begin
Mall_Open := True;
Name_Other := B_Name;
Color_Other := B_Colour;
Ready := True; --enable Meet entry
end Waiting;
end Places;
procedure Init_Mall (Place_Nbr : Place_Index; Max_Count : in Meetings) is
begin
Place (Place_Nbr).Init (Max_Count);
end Init_Mall;
end Chameneos.Creatures;