chameneos-redux Ada 2005 GNAT #2 program | Computer Language Benchmarks Game

performance measurements

Each table row shows performance measurements for this Ada 2005 GNAT program with a particular command-line input value N.

N	CPU secs	Elapsed secs	Memory KB	Code B	≈ CPU Load
60,000	0.09	0.04	?	6001	67% 67% 75% 50%
600,000	0.82	0.23	840	6001	91% 87% 95% 96%
6,000,000	Bad Output			6001

Read the ↓ make, command line, and program output logs to see how this program was run.

Read chameneos-redux benchmark to see what this program should do.

notes

GNAT 4.6

gcc (Ubuntu/Linaro 4.7.3-1ubuntu1) 4.7.3

chameneos-redux Ada 2005 GNAT #2 program source code

-- The Computer Language Benchmarks Game

-- http://benchmarksgame.alioth.debian.org/

--

-- Contributed by Pat Rogers

--

-- Based on the C++ version by Andrew Moon 

-- and the C version by Dmitry Vyukov

--

-- A task (thread) is created for each chameneous.

-- An atomic compare-and-swap operation is used

-- for shared state manipulation.  A protected 

-- type is used for completion notification.

-- A cache-aligned memory allocator is used.



-- Expected build command:

-- gnatmake -gnatp  -gnatn  -fstrict-aliasing -O3 -fomit-frame-pointer -march=native -ffunction-sections -fdata-sections -f chameneosredux.adb -o chameneosredux.gnat_run   -largs -Wl,--gc-sections




pragma Restrictions (No_Abort_Statements);
pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);

with Chameneos.Games;       use Chameneos.Games;
with Ada.Command_Line;      use Ada.Command_Line;
with Chameneos.Processors;  use Chameneos.Processors;

procedure ChameneosRedux is

   use Chameneos;

   N : Meeting_Count;

   Game1_Creature_Colors : constant Color_List_Ref := new Color_List'(Blue, Red, Yellow);



   Game2_Creature_Colors : constant Color_List_Ref :=

      new Color_List'(Blue, Red, Yellow, Red, Yellow, Blue, Red, Yellow, Red, Blue);

   Game1 : Game (Num_Creatures => Game1_Creature_Colors'Length);

   Game2 : Game (Num_Creatures => Game2_Creature_Colors'Length);

begin
   Print_Color_Complements;

   if Argument_Count < 1 then
      N := 6_000_000;
   else
      N := Meeting_Count'Value (Argument (1));
   end if;

   if Processor_Count < 4 then  -- run the games sequentially

      Game1.Start (Game1_Creature_Colors, N, Slot => 0);
      Game1.Await_Completion;

      Game2.Start (Game2_Creature_Colors, N, Slot => 0);
      Game2.Await_Completion;
   else -- run the games in parallel

      Game1.Start (Game1_Creature_Colors, N, Slot => 1);
      Game2.Start (Game2_Creature_Colors, N, Slot => 2);

      Game1.Await_Completion;
      Game2.Await_Completion;
   end if;

   Game1.Display;
   Game2.Display;
end ChameneosRedux;

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


with Interfaces;                  use Interfaces;
with Cache_Aligned_Storage_Pools; use Cache_Aligned_Storage_Pools;

package Chameneos is

   Storage : Cache_Aligned_Storage_Pool;
   --  All allocators use this common pool, which is really just a wrapper for

   --  the system allocator, but with additional constraints on the addresses

   --  returned.


   type String_Access is access all String;
   for String_Access'Storage_Pool use Storage;

   type Colors is (Blue, Red, Yellow);

   Colors_Image : constant array (Colors) of String_Access :=
                    (Blue   => new String'("blue"),

                     Red    => new String'("red"),
                     Yellow => new String'("yellow"));



   type Colors_Complements is array (Colors, Colors) of Colors;



   Complementary_Color : constant Colors_Complements :=

                           (Blue   => (Blue   => Blue,

                                       Red    => Yellow,

                                       Yellow => Red),

                            Red    => (Red    => Red,

                                       Blue   => Yellow,

                                       Yellow => Blue),

                            Yellow => (Yellow => Yellow,

                                       Blue   => Red,

                                       Red    => Blue));



   --  Print the Complementary_Color map

   procedure Print_Color_Complements;



   --  Returns a string representing the non-negative integer Value, in which

   --  each digit of Value is spelled out as a distinct word

   function Spelled (Value : Natural) return String;





   type Color_List is array (Positive range <>) of Colors;



   type Color_List_Ref is access constant Color_List;

   for Color_List_Ref'Storage_Pool use Storage;





   --  The efficiency of this design is due to the underlying use of a single

   --  variable (per game) shared amongst all the creature threads. This

   --  variable is used both for the count of the number of meetings completed

   --  as well as an indication of the creatures present for meetings. Hence

   --  some of the bits are used for the meeting count and some for the

   --  creatures. The number of bits used for the creature mask, in combination

   --  with the total number of bits in the shared variable, determine how many

   --  creatures and how many total meetings are supported.



   --  The number of bits allocated within the shared variable for identifying

   --  creatures

   Creature_Mask_Bits : constant := 4;



   subtype Creature_Count is Unsigned_32 range 0 .. 2 ** Creature_Mask_Bits - 1;



   --  The number of bits allocated within the shared variable for tracking the

   --  total number of meetings completed

   Meetings_Bits : constant := Unsigned_32'Size - Creature_Mask_Bits;



   Max_Meetings : constant := 2 ** Meetings_Bits - 1;



   subtype Meeting_Count is Unsigned_32 range 0 .. Max_Meetings;



end Chameneos;



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



with Chameneos.Meetings;

with Chameneos.Countdown;

with Chameneos.Processors;



with System.Task_Info;  use System.Task_Info;



package Chameneos.Creatures is



   type Creature (Starting_Color : Colors) is tagged limited private;

   --  Each creature has an initial color, but their current color is a function

   --  of the colors of the other creatures met.



   type Creature_Ref is access all Creature;

   for Creature_Ref'Storage_Pool use Chameneos.Storage;



   --  Tell the creature where all the creatures in the game are meeting, where

   --  to signal when the creature is finished, and which slot to execute in.

   procedure Start (This     : access Creature;

                    Location : Chameneos.Meetings.Venue;

                    Latch    : Chameneos.Countdown.Latch_Ref;

                    Slot     : Natural);



   --  The caller side of the rendezvous

   procedure Meet (This : in out Creature;  Other : in out Creature);



   --  The called side of the rendezvous

   procedure Wait_Until_Met (This : in out Creature);



   procedure Await_Completion (This : in out Creature);



   procedure Set_Id (This : in out Creature;  To : Creature_Count);



   function Id (This : Creature) return Creature_Count;



   function Current_Color (This : Creature) return Colors;



   function Initial_Color (This : Creature) return Colors;



   procedure Display (This : in out Creature);



   function Total_Met (This : Creature) return Natural;



   pragma Inline (Set_Id, Id, Current_Color, Initial_Color, Total_Met);



private



   use Chameneos.Processors;



   --  Objects of type Thread implement the active execution, i.e., the

   --  symmetric rendezvous requirement, for their corresponding creatures.

   --  Each thread instance has a discriminant designating the corresponding

   --  creature. No state is maintained within the threads themselves. Each

   --  thread instance executes in a given "slot" that specifies the cores it

   --  can run upon, via processor affinities. The specific slot is also given

   --  via discriminant.

   task type Thread (This : access Creature;  Slot : Natural) is

      pragma Task_Info (new Thread_Attributes'(CPU_Affinity => Affinity (Slot)));
   end Thread;

   type Thread_Ref is access all Thread;
   for Thread_Ref'Storage_Pool use Chameneos.Storage;

   type Creature (Starting_Color : Colors) is tagged limited
      record
         Met              : Boolean := False;
         --  Met is set by other threads so the pragma is essential

         pragma Volatile (Met);
         Count            : Natural := 0;
         Same_Count       : Natural := 0;
         Color            : Colors := Starting_Color;
         Id               : Creature_Count;
         Rendezvous_Point : Meetings.Venue;
         Completion       : Chameneos.Countdown.Latch_Ref;
      end record;

end Chameneos.Creatures;

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


with Chameneos.Creatures;  use Chameneos.Creatures;
with Chameneos.Meetings;
with Chameneos.Countdown;

package Chameneos.Games is

   type Game (Num_Creatures : Creature_Count) is tagged limited private;

   --  Allocates the creature threads and all other required data.

   procedure Start
     (This            : in out Game;
      Creature_Colors : Color_List_Ref;
      Num_Meetings    : Meeting_Count;
      Slot            : Natural);

   --  Waits for all creatures (threads) to finish.

   procedure Await_Completion (This : Game);

   procedure Display (This : Game);

private

   use Chameneos;

   type Creatures_List is array (Creature_Count range <>) of Creature_Ref;

   type Game (Num_Creatures : Creature_Count) is tagged limited
      record
         --  where all the creatures in the game meet

         Rendezvous_Point : Meetings.Venue;
         --  all the creatures in the game

         Players : Creatures_List (1 .. Num_Creatures);
         --  the common mechanism used for signalling creature completion

         Latch : aliased Countdown.Latch (Num_Creatures);
      end record;

end Chameneos.Games;

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


limited with Chameneos.Creatures;

package Chameneos.Meetings is

   type Place (Meetings_Expected : Meeting_Count) is tagged limited private;
   --  Where creatures come to meet other creatures, potentially change colors,

   --  and play the game. Creatures are required to meet until the required

   --  number of total meetings has occurred. This number of required meetings

   --  is specified by the discriminant Meetings_Expected.


   type Venue is access all Place;
   for Venue'Storage_Pool use Chameneos.Storage;

   --  Assign a location for the creature designated by Player, within This place,

   --  for the purpose of meeting any other creatures willing to meet.

   procedure Register
     (This   : in out Place;
      Player : access Chameneos.Creatures.Creature);

   --  Have creature Player iteratively meet other creatures with This place,

   --  updating the count of the total number of creature meetings as they

   --  occur, and updating individual creature states as well (including

   --  individual meeting counts and color changes).

   procedure Meet_Others
     (This   : in out Place;
      Player : access Chameneos.Creatures.Creature);

private

   type Creature_Reference_List is
     array (Creature_Count range 1 .. Creature_Count'Last) of
        access Chameneos.Creatures.Creature;

   subtype Valid_Creature_Id is
     Creature_Count range 1 .. Creature_Count'Last;

   No_Creature : constant Creature_Count := Valid_Creature_Id'First - 1;
   --  used in Meet_Others to determine whether any creatures are waiting


   type Place (Meetings_Expected : Meeting_Count) is tagged limited
      record
         Id_Generator : Valid_Creature_Id := Valid_Creature_Id'First;
         --  Used to assign unique id's to creature threads as they register.

         Shared_State : aliased Unsigned_32 := Shift_Left (Meetings_Expected, Creature_Mask_Bits);
         --  The essential aspect of this program's design is the use of this

         --  shared variable accessed by all the creature threads in a given

         --  game. This variable is used both for the count of the number of

         --  meetings completed as well as an indication of creatures waiting

         --  for meetings. Hence the initial value is the number of required

         --  meetings, shifted into the dedicated bits, with no creatures yet

         --  waiting.

         pragma Volatile (Shared_State);
         --  Shared_State is accessed and modified by all the threads within a

         --  given game, so the pragma is essential!

         Registered_Players : Creature_Reference_List;
      end record;

end Chameneos.Meetings;

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


with System.Storage_Pools;
with System.Storage_Elements;

package Cache_Aligned_Storage_Pools is

   package SSE renames System.Storage_Elements;
   package SSP renames System.Storage_Pools;

   type Cache_Aligned_Storage_Pool is
     new SSP.Root_Storage_Pool with private;
   --  A Cache_Aligned_Storage_Pool is a wrapper for the underlying operating

   --  system storage allocator. Allocations using pool objects of this type

   --  will return addresses that are aligned with the cache line size specified

   --  below.


   Cache_Line_Size : constant := 64;
   --  The length of a cache line on this machine.  Change as necessary...


   --  Allocates a block of storage such that Storage_Address is aligned with

   --  Cache_Line_Size. Uses the system memory allocator to do the actual

   --  allocation but asks for more storage than Requested_Size so that an

   --  aligned address within the allocated block can be found.

   procedure Allocate
     (Pool            : in out Cache_Aligned_Storage_Pool;
      Storage_Address : out System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count);

   --  Uses the system memory routine to deallocate the entire block of storage

   --  in which Storage_Address is contained.

   procedure Deallocate
     (Pool            : in out Cache_Aligned_Storage_Pool;
      Storage_Address : System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count);

   --  Returns a meaningless number since the system memory allocation and

   --  deallocation routines are used.

   function Storage_Size (Pool : Cache_Aligned_Storage_Pool)
      return SSE.Storage_Count;

private

   procedure Allocate_Any
     (Pool            : in out Cache_Aligned_Storage_Pool'Class;
      Storage_Address : out System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count);

   procedure Deallocate_Any
     (Pool            : in out Cache_Aligned_Storage_Pool'Class;
      Storage_Address : System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count);

   type Cache_Aligned_Storage_Pool is
     new SSP.Root_Storage_Pool with null record;  -- just a wrapper...


end Cache_Aligned_Storage_Pools;

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


package Chameneos.Countdown is

   --  "Latch" is a non-cyclic traditional barrier abstraction. As a barrier it

   --  provides a means of blocking callers to Wait until a specified number of

   --  calls to Signal have occurred. At that point all of the prior calls to

   --  Wait are allowed to execute and, therefore, their callers are no longer

   --  blocked. The number of required calls to Signal is specified on a

   --  per-object basis via discriminant when objects of the type are declared.

   --  Latch is "non-cyclic", i.e., it does not block another set of waiters

   --  after the first set is allowed to continue, because there is no

   --  requirement in this application for cyclic behavior.

   protected type Latch (Signallers : Creature_Count) is
      entry Wait;
      procedure Signal;
   private
      Count : Unsigned_32 := Signallers;
   end Latch;

   type Latch_Ref is access all Latch;
   for Latch_Ref'Storage_Pool use Chameneos.Storage;

end Chameneos.Countdown;

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


with System.Task_Info;     use System.Task_Info;
pragma Warnings (Off);
with System.OS_Interface;  use System.OS_Interface;
pragma Warnings (On);

package Chameneos.Processors is
   pragma Elaborate_Body;

   Processor_Count : constant Positive := System.Task_Info.Number_Of_Processors;

   Max_Slots : constant := 33;

   --  Returns a bit mask indicating the cores on which a thread in Slot can

   --  execute. A game is assigned to a given slot, and as a result all the

   --  threads within that game will execute only on those cores, for the sake

   --  of locality (ie performance).

   function Affinity (Slot : Natural) return CPU_Set;

   --  Each slot has an affinity mask consisting of a pair of cores

   --  dedicated to that slot, except for slot 0 which is the global mask

   --  returned by the OS (which shows all processors available).

   --

   --  For example, imagine that we get a mask with the first 8 bits

   --  enabled, indicating that 8 processors (cores) are available.

   --  The resulting data structure would be as follows:

   --

   --                     bit#

   --   slot #         123456789...

   --     0            1111111100

   --     1            1100000000

   --     2            0011000000

   --     3            0000110000

   --     4            0000001100

   --     5            1100000000

   --     6            0011000000

   --    ...              ...


end Chameneos.Processors;

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


with Interfaces;   use Interfaces;

package x86_Atomic_Swap_Utils is

   -- Perform an atomic compare and swap: if the current value of

   -- Destination.all is Comparand, then write New_Value into Destination.all.

   -- Returns the content of Destination.all before the operation.

   function Sync_Val_Compare_And_Swap
     (Destination : access Unsigned_32;
      Comparand   : Unsigned_32;
      New_Value   : Unsigned_32)
      return Unsigned_32;

   pragma Inline_Always (Sync_Val_Compare_And_Swap);

end x86_Atomic_Swap_Utils;

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


with GNAT.IO; use GNAT.IO;
with Ada.Strings.Unbounded;

package body Chameneos is

   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"));

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

   -- Spelled --

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


   function Spelled (Value : Natural) return String is
      use Ada.Strings.Unbounded;
      Result : Unbounded_String;
      K      : Natural := Value;
   begin
      loop
         Insert (Result, 1, Numbers_Image (K rem 10).all);
         K := K / 10;
         exit when K = 0;
      end loop;
      return To_String (Result);
   end Spelled;

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

   -- Print_Color_Changes --

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


   procedure Print_Color_Complements is
   begin
      for Self in Colors loop
         for Other in Colors loop
            Put_Line (Colors_Image (Self).all & " + " &
                      Colors_Image (Other).all & " -> " &
                      Colors_Image (Complementary_Color (Self, Other)).all);
         end loop;
      end loop;
      New_Line;
   end Print_Color_Complements;

end Chameneos;

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


with GNAT.IO;  use GNAT.IO;

package body Chameneos.Creatures is

   -----------

   -- Start --

   -----------


   procedure Start
     (This     : access Creature;
      Location : Chameneos.Meetings.Venue;
      Latch    : Chameneos.Countdown.Latch_Ref;
      Slot     : Natural)
   is
      Player_To_Be_Named_Later : Thread_Ref;
      pragma Unreferenced (Player_To_Be_Named_Later);
   begin
      This.Rendezvous_Point := Location;
      This.Completion := Latch;
      This.Rendezvous_Point.Register (This);
      Player_To_Be_Named_Later := new Thread (This, Slot);
        --  just launch the thread, no need to keep track of it

   end Start;

   ----------

   -- Meet --

   ----------


   procedure Meet (This : in out Creature; Other : in out Creature) is
      New_Color : Colors;
   begin
      if This.Id = Other.Id then
         This.Same_Count := This.Same_Count + 1;
         Other.Same_Count := Other.Same_Count + 1;
      end if;

      This.Count  := This.Count + 1;
      Other.Count := Other.Count + 1;

      New_Color := Complementary_Color (This.Color, Other.Color);
      This.Color := New_Color;
      Other.Color := New_Color;

      Other.Met := True;
   end Meet;

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

   -- Wait_Until_Met --

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


   procedure Wait_Until_Met (This : in out Creature) is
   begin
      if Processor_Count > 1 then
         declare
            Spin_Count : Integer := 0;
         begin
            while not This.Met loop
               Spin_Count := Spin_Count + 1;
               if Spin_Count > 20_000 then  -- arbitrary max

                  delay 0.0;  -- yield

                  Spin_Count := 0;
               end if;
            end loop;
         end;
      else
         while not This.Met loop
            delay 0.0; -- yield

         end loop;
      end if;
      This.Met := False;
   end Wait_Until_Met;

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

   -- Await_Completion --

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


   procedure Await_Completion (This : in out Creature) is
   begin
      This.Completion.Wait;
   end Await_Completion;

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

   -- Set_Id --

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


   procedure Set_Id (This : in out Creature;  To : Creature_Count) is
   begin
      This.Id := To;
   end Set_Id;

   --------

   -- Id --

   --------


   function Id (This : Creature) return Creature_Count is
   begin
      return This.Id;
   end Id;

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

   -- Current_Color --

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


   function Current_Color (This : Creature) return Colors is
   begin
      return This.Color;
   end Current_Color;

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

   -- Initial_Color --

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


   function Initial_Color (This : Creature) return Colors is
   begin
      return This.Starting_Color;
   end Initial_Color;

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

   -- Display --

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


   procedure Display (This : in out Creature) is
   begin
      Put (This.Count);
      Put_Line (Spelled (This.Same_Count));
   end Display;

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

   -- Total_Met --

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


   function Total_Met (This : Creature) return Natural is
   begin
      return This.Count;
   end Total_Met;

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

   -- Thread --

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


   task body Thread is
      use Chameneos.Meetings;
   begin
      Meet_Others (This.Rendezvous_Point.all, Player => This);
      This.Completion.Signal;
   end Thread;

end Chameneos.Creatures;

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


with GNAT.IO;  use GNAT.IO;

package body Chameneos.Games is

   -----------

   -- Start --

   -----------


   procedure Start
     (This            : in out Game;
      Creature_Colors : Color_List_Ref;
      Num_Meetings    : Meeting_Count;
      Slot            : Natural)
   is
      Color_Index : Positive := Creature_Colors'First;
      --  We use a separate index, instead of the index used to iterate over

      --  This.Players, since the bounds need not be the same. The range of

      --  This.Players is 1 .. Num_Creatures, where that upper bound is set as a

      --  discriminant to the game when it is created. The actual value passed

      --  to this discriminant comes from the length of an array of colors,

      --  which is then passed to this procedure in Creature_Colors, so the

      --  count will be the same. There is no guarantee of that, of course, but

      --  in practice that will suffice.

   begin
      This.Rendezvous_Point := new Meetings.Place (Num_Meetings);
      for K in This.Players'Range loop
         This.Players (K) := new Creature (Creature_Colors (Color_Index));
         This.Players (K).Start
           (Location => This.Rendezvous_Point,
            Latch    => This.Latch'Unchecked_Access,
            Slot     => Slot);
         Color_Index := Color_Index + 1;
      end loop;
   end Start;

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

   -- Await_Completion --

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


   procedure Await_Completion (This : Game) is
   begin
      for K in This.Players'Range loop
         This.Players (K).Await_Completion;
      end loop;
   end Await_Completion;

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

   -- Display --

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


   procedure Display (This : Game) is
      Grand_Total : Natural := 0;
   begin
      for K in This.Players'Range loop
         Put( " " & Colors_Image (This.Players (K).Initial_Color).all);
      end loop;
      New_Line;

      for K in This.Players'Range loop
         This.Players (K).Display;
         Grand_Total := Grand_Total + This.Players (K).Total_Met;
      end loop;
      Put_Line (Spelled (Grand_Total));
      New_Line;
   end Display;

end Chameneos.Games;

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


with Chameneos.Creatures;
with x86_Atomic_Swap_Utils;  use x86_Atomic_Swap_Utils;

package body Chameneos.Meetings is

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

   -- Register --

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


   procedure Register
     (This   : in out Place;
      Player : access Chameneos.Creatures.Creature)
   is
      Id : constant Creature_Count := This.Id_Generator;
   begin
      Player.Set_Id (Id);
      This.Registered_Players (Id) := Player;
      This.Id_Generator := This.Id_Generator + 1;
   end Register;


   --  the lower part of the shared variable State, used to represent those

   --  chameneos wating for a meeting in the mall

   Creature_Mask : constant := 2 ** Creature_Mask_Bits - 1;

   --  the additional meeting count value due to the creature mask

   Count_Offset : constant Unsigned_32 := Shift_Left (1, Creature_Mask_Bits);


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

   -- Meet_Others --

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


   procedure Meet_Others
     (This   : in out Place;
      Player : access Chameneos.Creatures.Creature)
   is
      Local_State       : Unsigned_32 := This.Shared_State;
      Waiting           : Unsigned_32;
      Target_State      : Unsigned_32;
      State_Before_Swap : Unsigned_32;
   begin
      loop
         --  get the Id of a creature waiting for a meeting, if any

         Waiting := Local_State and Creature_Mask;
         if Waiting /= No_Creature then
            --  at least one creature is in the mall, waiting for a rendezvous,

            --  so we set the target state to the current meeting count - 1 to

            --  reflect the meeting we're about to attempt

            Target_State := (Local_State and not Creature_Mask) - Count_Offset;
         elsif Local_State /= 0 then
            --  no creatures are waiting but there are meetings remaining so set

            --  the target state to reflect Player, who is willing to meet

            Target_State := Local_State or Player.Id;
         else  --  no creatures waiting and no further meetings to be held

            exit;
         end if;

         --  Attempt to update the shared game state. If the value of the shared

         --  state is that of the local copy when the swap is attempted, then

         --  the shared state will be updated, otherwise it is not changed.

         State_Before_Swap := Sync_Val_Compare_And_Swap
           (Destination => This.Shared_State'Access,
            Comparand   => Local_State,
            New_Value   => Target_State);

         if State_Before_Swap = Local_State then -- we successfully updated it

            if Waiting /= 0 then
               Player.Meet (This.Registered_Players (Waiting).all);
            else
               Player.Wait_Until_Met;
            end if;

            Local_State := Target_State;
         else  -- we did not update the shared state, so use the shared value

            Local_State := State_Before_Swap;
         end if;
      end loop;
   end Meet_Others;

end Chameneos.Meetings;

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


package body Chameneos.Countdown is

   -----------

   -- Latch --

   -----------


   protected body Latch is

      ----------

      -- Wait --

      ----------


      entry Wait when Count = 0 is
      begin
         null;
      end Wait;

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

      -- Signal --

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


      procedure Signal is
      begin
         Count := Count - 1;
      end Signal;

   end Latch;

end Chameneos.Countdown;

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


with System.Memory;
with Ada.Unchecked_Conversion;

package body Cache_Aligned_Storage_Pools is

   use System, System.Storage_Elements;

   --  we cannot use System.Address'Size as the modulus so we use the same thing

   --  that the compiler does (when declaring Address as a modular type in the

   --  full definition)

   type Unsigned_Address is mod System.Memory_Size;

   function As_Unsigned_Address is new Ada.Unchecked_Conversion
     (Source => Address,
      Target => Unsigned_Address);

   function As_Address is new Ada.Unchecked_Conversion
     (Target => Address,
      Source => Unsigned_Address);

   type Address_Pointer is access all Address;
   for Address_Pointer'Storage_Size use 0;

   function As_Address_Pointer is new Ada.Unchecked_Conversion
     (Source => Address,
      Target => Address_Pointer);

   --  size of an address in terms of storage units

   Size_Of_Address : constant Storage_Offset := Address'Size / System.Storage_Unit;

   Twice_Cache_Line_Size : constant := 2 * Cache_Line_Size;

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

   -- Allocate --

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


   procedure Allocate
     (Pool            : in out Cache_Aligned_Storage_Pool;
      Storage_Address : out System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count)
   is
      pragma Unreferenced (Pool);
      pragma Unreferenced (Alignment);

      Actual  : Address;
      Aligned : Address;
      Header  : Address;
      Temp    : Unsigned_Address;
   begin
      Actual := Memory.Alloc (Memory.size_t (Requested_Size + Twice_Cache_Line_Size));
      --  The call to Alloc returns an address whose alignment is compatible

      --  with the worst case alignment requirement for the machine; thus the

      --  Alignment argument can be safely ignored.


      if Actual = Null_Address then
         raise Storage_Error;
      end if;

      --  compute a cache-aligned address within the block allocated

      Temp := As_Unsigned_Address (Actual + Cache_Line_Size) and not (Cache_Line_Size - 1);
      Aligned := As_Address (Temp);
      --  Put the address of the whole allocated block just before the address

      --  given to the application so we can deallocate the whole block later

      Header := Aligned - Size_of_Address;
      As_Address_Pointer (Header).all := Actual;
      Storage_Address := Aligned;
   end Allocate;

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

   -- Deallocate --

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


   procedure Deallocate
     (Pool            : in out Cache_Aligned_Storage_Pool;
      Storage_Address : System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count)
   is
      pragma Unreferenced (Pool);
      pragma Unreferenced (Requested_Size);
      pragma Unreferenced (Alignment);

      Actual : Address;
      Header : Address;
   begin
      Header := Storage_Address - Size_of_Address;
      Actual := As_Address_Pointer (Header).all;
      Memory.Free (Actual);
   end Deallocate;

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

   -- Storage_Size --

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


   function Storage_Size
     (Pool  : Cache_Aligned_Storage_Pool)
      return  SSE.Storage_Count
   is
      pragma Warnings (Off, Pool);
   begin
      return SSE.Storage_Count'Last;
   end Storage_Size;

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

   -- Allocate_Any --

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


   procedure Allocate_Any
     (Pool            : in out Cache_Aligned_Storage_Pool'Class;
      Storage_Address : out System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count)
   is
   begin
      Allocate (Pool, Storage_Address, Requested_Size, Alignment);
   end Allocate_Any;

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

   -- Deallocate_Any --

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


   procedure Deallocate_Any
     (Pool            : in out Cache_Aligned_Storage_Pool'Class;
      Storage_Address : System.Address;
      Requested_Size  : SSE.Storage_Count;
      Alignment       : SSE.Storage_Count)
   is
   begin
      Deallocate (Pool, Storage_Address, Requested_Size, Alignment);
   end Deallocate_Any;

end Cache_Aligned_Storage_Pools;

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


with Interfaces.C;

package body Chameneos.Processors is

   Cores_Per_Slot : constant := 2;

   Affinities : array (0 .. Max_Slots) of aliased CPU_Set;
   --  we use the first slot (ie 0) for the global affinity mask, internally,

   --  hence there are Max_Slots-1 total slots available to the application

   --  threads, and a total of ((Max_Slots-1) * Cores_Per_Slot) cores supported


   Slot_Modulus : Natural;

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

   -- Affinity --

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


   function Affinity (Slot : Natural) return cpu_set_t is
   begin
      if Slot = 0 then
         return Affinities (Slot);
      else
         return Affinities ((Slot mod Slot_Modulus) + 1);
      end if;
   end Affinity;

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

   -- sched_getaffinity --

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


   function Sched_Getaffinity
     (Pid : Pid_T;  Cpusetsize : Unsigned_32;  Mask : access CPU_Set)
      return Interfaces.C.int;
   pragma Import (C, sched_getaffinity);


   subtype Bit_Number is Integer range bit_field'Range;

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

   --  Set_Bit --

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


   procedure Set_Bit (Bit : Bit_Number;  Within : in out CPU_Set) is
   begin
      Within.bits (Bit) := True;
   end Set_Bit;

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

   -- Define_Affinities_By_Slot --

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


   procedure Define_Affinities_By_Slot is
      Num_Bits_Set     : Natural := 0;
      Global_Mask      : CPU_Set renames Affinities (0);
      Result           : Int;
      Global_Mask_Size : constant Unsigned_32 := Global_Mask'Size / System.Storage_Unit;
      Next_Affinity    : Natural;
      use type Interfaces.C.int;
   begin
      Result := sched_getaffinity (getpid, Global_Mask_Size, Global_Mask'Access);
      if Result /= 0 then
         raise Program_Error with "Could not get affinity";
      end if;

      for B in 1 .. CPU_SETSIZE loop
         if Global_Mask.Bits (B) then
            Next_Affinity := (Num_Bits_Set / Cores_Per_Slot) + 1;
            if Next_Affinity not in Affinities'Range then
               --  there are more processors enabled than we support, but

               --  that is OK since we only want a few

               exit;
            end if;
            Set_Bit (B, Affinities (Next_Affinity));
            Num_Bits_Set := Num_Bits_Set + 1;
         end if;
      end loop;

      if Num_Bits_Set > 2 then
         Slot_Modulus := Num_Bits_Set / 2;
      else
         Slot_Modulus := 1;
      end if;
   end Define_Affinities_By_Slot;


begin
   for K in Affinities'Range loop
      Affinities (K).bits := (others => False);
   end loop;
   Define_Affinities_By_Slot;
end Chameneos.Processors;

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


with System.Machine_Code;  use System.Machine_Code;

package body x86_Atomic_Swap_Utils is

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

   -- Sync_Val_Compare_And_Swap --

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


   function Sync_Val_Compare_And_Swap
     (Destination : access Unsigned_32;
      Comparand   : Unsigned_32;
      New_Value   : Unsigned_32)
      return Unsigned_32
   is
      Prior_Value : Unsigned_32;
      pragma Suppress (All_Checks);
   begin
      --  %eax := Comparand

      --  if %eax = Destination.all then

      --     Destination.all := New_Value

      --  else

      --     %eax := Destination.all

      --  end if

      Asm("lock cmpxchg %1, %2;",
        Inputs  => (Unsigned_32'Asm_Input ("r", New_Value),        -- %1

                    Unsigned_32'Asm_Input ("m", Destination.all),  -- %2

                    Unsigned_32'Asm_Input ("a", Comparand)),
        Outputs => (Unsigned_32'Asm_Output ("=a", Prior_Value)),   -- %0

        Clobber => "memory, cc",
        Volatile => True);
      --  return %eax

      return Prior_Value;
   end Sync_Val_Compare_And_Swap;

end x86_Atomic_Swap_Utils;

make, command-line, and program output logs

Sat, 27 Apr 2013 21:52:49 GMT

MAKE:
/usr/bin/gnatchop -r -w chameneosredux.gnat-2.gnat
splitting chameneosredux.gnat-2.gnat into:
   chameneosredux.adb
   chameneos.ads
   chameneos-creatures.ads
   chameneos-games.ads
   chameneos-meetings.ads
   cache_aligned_storage_pools.ads
   chameneos-countdown.ads
   chameneos-processors.ads
   x86_atomic_swap_utils.ads
   chameneos.adb
   chameneos-creatures.adb
   chameneos-games.adb
   chameneos-meetings.adb
   chameneos-countdown.adb
   cache_aligned_storage_pools.adb
   chameneos-processors.adb
   x86_atomic_swap_utils.adb
/usr/bin/gnatmake -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp -f chameneosredux.adb -o chameneosredux.gnat-2.gnat_run 
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp chameneosredux.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp chameneos.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp chameneos-games.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp chameneos-processors.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp cache_aligned_storage_pools.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp chameneos-countdown.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp chameneos-creatures.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp chameneos-meetings.adb
gcc-4.6 -c -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -gnatNp x86_atomic_swap_utils.adb
gnatbind -x chameneosredux.ali
gnatlink chameneosredux.ali -O3 -fomit-frame-pointer -march=native -msse3 -mfpmath=sse -o chameneosredux.gnat-2.gnat_run
2.10s to complete and log all make actions

COMMAND LINE:
./chameneosredux.gnat-2.gnat_run 6000000

UNEXPECTED OUTPUT 

15c15
<  one one nine nine nine nine nine nine
--- field 2
>  one two zero zero zero zero zero zero

PROGRAM OUTPUT:
blue + blue -> blue
blue + red -> yellow
blue + yellow -> red
red + blue -> yellow
red + red -> red
red + yellow -> blue
yellow + blue -> red
yellow + red -> blue
yellow + yellow -> yellow

 blue red yellow
3155334 zero
5928277 zero
2916388 zero
 one one nine nine nine nine nine nine

 blue red yellow red yellow blue red yellow red blue
1296260 zero
1263805 zero
1307420 zero
1010195 zero
1189756 zero
1018132 zero
1044697 zero
1347353 zero
1254226 zero
1268156 zero
 one two zero zero zero zero zero zero

Home Conclusions License Play

x64 Ubuntu : Intel® Q6600® quad-coreComputer Language Benchmarks Game [[ Play ]]

performance measurements

notes

chameneos-redux Ada 2005 GNAT #2 program source code

make, command-line, and program output logs

x64 Ubuntu : Intel® Q6600® quad-core
Computer Language Benchmarks Game [[ Play ]]