./index.html ../index.html

Adaのスレッド構文で遊ぶ

言語組み込みのスレッド機能はsyncronized程度が最近の流行らしいですが、クリティカルセクション程度であれば組み込みで無くても正直大差無く思えます。 10年前から存在していた、遥か上の組み込みスレッドをご覧あれ…！？

Adaの紹介をしているところでも、スレッドに踏み込んでいるのは少ないですし…。 例によって希少価値狙いです。 試した時に書き散らかしたサンプルということで勘弁してください。

ネイティブスレッドかな？

with Ada.Text_IO;
with Ada.Integer_Text_IO;
with Windows;
procedure Task_Units is
  use Ada.Text_IO, Ada.Integer_Text_IO;
  task Thread is 
    entry Rendezvous;
  end Thread;
  task body Thread is
  begin
    delay 0.1;
    Put("Thread");
    Put(Integer(Windows.GetCurrentThreadId), Base => 16);
    New_Line;
    accept Rendezvous do
      Put("Rendezvous");
      Put(Integer(Windows.GetCurrentThreadId), Base => 16);
      New_Line;
    end Rendezvous;
  end Thread;
begin
  Put("Main");
  Put(Integer(Windows.GetCurrentThreadId), Base => 16);
  New_Line;
  Thread.Rendezvous;
end Task_Units;

...>task_units
Main    16#1F8#
Thread    16#40C#
Rendezvous    16#40C#

...>

豪華な機能が付いているAdaのスレッドは果たしてそのままOSのスレッドなのか？ この結果や、タスクマネージャとか見る限り、GNAT@MinGWではTrueらしいです。

タイムアウト

with Ada.Text_IO;
with Ada.Long_Long_Float_Text_IO;
procedure Select_Then_Abort is
  subtype Real is Long_Long_Float;
  function F(X: in Real) return Real is
  begin
    return (X * X * X) - X * 5.0 - 7.0;
  end F;
  function F_D(X: in Real) return Real is
  begin
    return (X * X) * 3.0 - 5.0;
  end F_D;
  X: Real := 3.0;
  use Ada.Text_IO, Ada.Long_Long_Float_Text_IO;
begin
  select
    delay 1.0;
  then abort
    Newton: loop
      Abortable: declare
        New_X: Real;
      begin
        pragma Abort_Defer;
        New_X := (X - F(X) / F_D(X));
        exit Newton when New_X = X;
        X := New_X;
      end Abortable;
    end loop Newton;
  end select;
  Put(X);
  New_Line;
  Put(F(X));
end Select_Then_Abort;

...>select_then_abort
 2.74734654030721085E+00
 0.00000000000000000E+00

...>

428さんの書き込みではっとなって、実装してみたのがこれです。 ニュートン法で、Long_Long_Float精度の限界までいくか、1秒経つかまで答えを求め続ける。 pragmaが要るあたりがあまり嬉しくないです。pragmaを書いたステートメント並びの間にチェックルーチンを挟んでいる感じ…恐らく他の関数なんか呼んだりすると意図通り動いてくれない予感。 pragma書かない場合はdelay 0.0とか挟む。

protectedのentry, procedure, function

-- http://www.seas.gwu.edu/~adagroup/sigada-website/barnes-html/intro.html
with Ada.Text_IO;
procedure Semaphore is
  protected type Counting_Semaphore(Start_Count: Integer := 1) is
    entry Secure;
    procedure Release;
    function Count return Integer;
  private
    Current_Count: Integer := Start_Count;
  end Counting_Semaphore;
  protected body Counting_Semaphore is
    entry Secure when Current_Count > 0 is
    begin
      Current_Count := Current_Count - 1;
    end Secure;
    procedure Release is
    begin
      Current_Count := Current_Count + 1;
    end Release;
    function Count return Integer is
    begin
      return Current_Count;
    end Count;
  end Counting_Semaphore;
  Section: Counting_Semaphore(2);
  task type Thread(Name: Character);
  task body Thread is
    use Ada.Text_IO;
  begin
    loop
      Section.Secure;
      Put_Line(Name & " enter.");
      delay 1.0;
      Put_Line(Name & " leave.");
      Section.Release;
      delay 1.0;
    end loop;
  end Thread;
  A: Thread('A');
  B: Thread('B');
  C: Thread('C');
begin
  null;
end Semaphore;

...>semaphore
A enter.
B enter.
A leave.
C enter.
B leave.
C leave.
A enter.
B enter.
B leave.
C enter.
A leave.
^C
...>

Ada95への招待のサンプルコードにメインルーチン与えただけです。 同時にn個までのスレッドしか侵入を許さない…というやつ。

protectedのrequeue

-- http://www.seas.gwu.edu/~adagroup/sigada-website/barnes-html/intro.html
with Ada.Text_IO;
procedure Event is
  protected type Event is
    entry Wait;
    entry Signal;
  private
    entry Reset;
    Occurred: Boolean := False;
  end Event;
  protected body Event is
    entry Wait when Occurred is
    begin
      null;
    end Wait;
    entry Signal when True is
    begin
      if Wait'Count > 0 then
        Occurred := True;
        requeue Reset;
      end if;
    end Signal;
    entry Reset when Wait'Count = 0 is 
    begin
      Occurred := False;
    end Reset;
  end Event;
  use Ada.Text_IO;
  task type Waiting(Flag: access Event; Name: Character; Time: Integer);
  task body Waiting is
  begin
    loop
      Put_Line(Name & " begin.");
      Flag.Wait;
      Put_Line(Name & " end.");
      delay Duration(Time);
    end loop;
  end Waiting;
  Flag: aliased Event;
  A: Waiting(Flag'Access, 'A',  3);
  B: Waiting(Flag'Access, 'B', 11);
begin
  delay 1.0;
  loop
    Flag.Signal;
    delay 7.0;
  end loop;
end Event;

上と同じくサンプル丸写し。 はっきりいってこんなもの実装しなくてもentryを素で使う方がずっと高機能です。 原文でもこれがサンプルのためのサンプルで回りくどい実装であることは書かれていますしね。 protectedのentryは、キュー動作をする、と、そこだけポイント。

あと、taskやprotectedの起動時の引数に、StringとかDurationとか渡せないのは何故でしょう？

仕様では…

with Ada.Text_IO;
with Ada.Strings.Unbounded;
procedure Multi_Reader_And_Single_Writer is
  ---- clone of Delphi's library
  protected type TMultiReadExclusiveWriteSynchronizer is
    entry BeginWrite;
    procedure EndWrite;
    entry BeginRead;
    procedure EndRead;
  private
    Writer_Count: Integer := 0;
    Reader_Count: Integer := 0;
  end TMultiReadExclusiveWriteSynchronizer;
  protected body TMultiReadExclusiveWriteSynchronizer is
    entry BeginWrite when Writer_Count = 0 and Reader_Count = 0 is
    begin
      Writer_Count := Writer_Count + 1;
    end BeginWrite;
    procedure EndWrite is
    begin
      Writer_Count := Writer_Count - 1;
    end EndWrite;
    entry BeginRead when Writer_Count = 0 is
    begin
      Reader_Count := Reader_Count + 1;
    end BeginRead;
    procedure EndRead is
    begin
      Reader_Count := Reader_Count - 1;
    end EndRead;
  end TMultiReadExclusiveWriteSynchronizer;
  ---- Ada's way ???
  -- Please, see "s-taprob.ads":
  --   procedure Lock_Read_Only (Object : Protection_Access);
  --   --  ...
  --   --  Note: we are not currently using this interface, it is provided
  --   --  for possible future use. At the current time, everyone uses Lock
  --   --  for both read and write locks.
  -- Oh! No!
  protected type Sample is
    procedure Write(C: Character);
    function Read(Name: Character) return Character;
  private
    Buffer: Ada.Strings.Unbounded.Unbounded_String;
  end Sample;
  protected body Sample is
    procedure Write(C: Character) is
      use Ada.Text_IO;
      use type Ada.Strings.Unbounded.Unbounded_String;
    begin
      Put_Line("begin write");
      Buffer := Buffer & C;
      Put_Line(Ada.Strings.Unbounded.To_String(Buffer));
      Put_Line("end write");
    end Write;
    function Read(Name: Character) return Character is
      use Ada.Text_IO;
      Result: Character;
    begin
      Put_Line("begin read " & Name);
      Result := Ada.Strings.Unbounded.Element(Buffer, Ada.Strings.Unbounded.Length(Buffer));
      Put_Line("end read " & Name);
      return Result;
    end Read;
  end Sample;
  task type Writer(S: access Sample);
  task body Writer is
    subtype Upper is Character range 'A'..'Z';
  begin
    for C in Upper'Range loop
      S.Write(C);
    end loop;
  end Writer;
  task type Reader(S: access Sample; Name: Character);
  task body Reader is
    use Ada.Text_IO;
    C: Character;
  begin
    loop
      C := S.Read(Name);
      Put_Line(C & "");
    end loop;
  end Reader;
  -- S: aliased Sample;
  -- W: Writer(S'Access);
  -- A: Reader(S'Access, '?');
  -- B: Reader(S'Access, '!');
  ---- D_A_K_Y_O_U
  Buffer: Ada.Strings.Unbounded.Unbounded_String;
  task type Writer2(S: access TMultiReadExclusiveWriteSynchronizer);
  task body Writer2 is
    use Ada.Text_IO;
    use type Ada.Strings.Unbounded.Unbounded_String;
    subtype Upper is Character range 'A'..'Z';
  begin
    for C in Upper'Range loop
      S.BeginWrite;
      Put_Line("begin write");
      Buffer := Buffer & C;
      Put_Line(Ada.Strings.Unbounded.To_String(Buffer));
      Put_Line("end write");
      S.EndWrite;
    end loop;
  end Writer2;
  task type Reader2(S: access TMultiReadExclusiveWriteSynchronizer; Name: Character);
  task body Reader2 is
    use Ada.Text_IO;
    C: Character;
  begin
    loop
      S.BeginRead;
      Put_Line("begin read " & Name);
      C := Ada.Strings.Unbounded.Element(Buffer, Ada.Strings.Unbounded.Length(Buffer));
      delay 0.1;
      Put_Line("end read " & Name);
      S.EndRead;
      Put_Line(C & "");
    end loop;
  end Reader2;
  S: aliased TMultiReadExclusiveWriteSynchronizer;
  W: Writer2(S'Access);
  A: Reader2(S'Access, '?');
  B: Reader2(S'Access, '!');
begin
  null;
end Multi_Reader_And_Single_Writer;

仕様では、protectedのprocedureはWriteロック、functionはReadロックのはずなのですが、GNATでは、両方ともWriteロックになってしまっていて、functionが複数同時には入ってくれません。 それでも大抵は少々効率が悪い程度で済みますが、Readerが複数入れるのを前提にしていると痛い目に遭いそうですね。 Reader間でもランデブーするとか。

とりあえずTMultiReadExclusiveWriteSynchronizerがあまりにもあっさり実装できてしまいましたので、それを使っています。 entry～whenは偉大だ。