[fpc-devel] Shootout

[Daniël Mantione]

Hi,

Encouraged by Vincent I made an attempt to implement the Chameneos 
benchmark of the Shootout. It turned out to be really hard, because we 
don't have real semafores (which makes it for example impossible to 
translate the C version).

However, with the RTLevent* routines, it is possible to implement it.
I have a final problem I'm unable to solve at this time. When all threads 
exit, one of the threads still hangs in a RTLeventwaitfor call. We don't 
know which one.

The trick is to get it out of its wait state in a safe way. My currect 
solution (a set event call when the end is eached) sometimes fails,
depending on the weather or something.

If anyone wants to take a look, the source is attached.

Daniël
-------------- next part --------------
program chameneos;

uses sysutils
{$ifdef unix}
     ,cthreads
{$endif};

type colour=(blue,red,yellow,fade);

     chamid=0..3;

var complement:array[colour,colour] of colour=
       ((blue,yellow,red,fade),
        (yellow,red,blue,fade),
        (red,blue,yellow,fade),
        (fade,fade,fade,fade));

    meet_event:PRTLevent;
    tid:array[chamid] of Tthreadid;

const cham_colours:array[chamid] of colour=(blue,red,yellow,blue);
      meetings:longint=0;
      meetings_left:longint=1000000;
      first_call:boolean=true;
      state:longint=0;

var first,second:colour;

function other_creatures_colour(id:chamid;c:colour):colour;

begin
  other_creatures_colour:=fade;
  if meetings_left<>0 then
    begin
      if interlockedincrement(state) and 1<>0 then
        begin
          other_creatures_colour:=first;
          second:=c;
          RTLeventsetevent(meet_event);
          dec(meetings_left);
        end
      else
        begin
          RTLeventstartwait(meet_event);
          first:=c;
          RTLeventwaitfor(meet_event);
          other_creatures_colour:=second;
        end
    end
  else
    RTLeventsetevent(meet_event); {!!! Not trusted!}
end;

function chameneos(parameter:pointer):ptrint;

var id:chamid;
    other:colour;

begin
  id:=ptrint(parameter);
  while cham_colours[id]<>fade do
    begin
      other:=other_creatures_colour(id,cham_colours[id]);
      if other=fade then
        cham_colours[id]:=fade
      else
        begin
          cham_colours[id]:=complement[cham_colours[id],other];
          inc(meetings);
        end;
    end;
  chameneos:=0;
end;

var i:chamid;

begin
  if paramcount>=1 then
    val(paramstr(1),meetings_left);
  meet_event:=RTLeventcreate;  
  for i:=low(chamid) to high(chamid) do
    tid[i]:=beginthread(@chameneos,pointer(ptrint(i)));
  for i:=low(chamid) to high(chamid) do
    waitforthreadterminate(tid[i],0);
  RTLeventdestroy(meet_event);
  writeln(meetings);
end.