rxada_0.1.0_6ff779c7/src/body/rx-dispatchers-single.adb

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
with Ada.Task_Identification;

with Rx.Debug; use Rx.Debug;

package body Rx.Dispatchers.Single is

   --------------
   -- Schedule --
   --------------

   overriding procedure Schedule
     (Where : in out Dispatcher;
      What  : Runnable'Class;
      Time  : Ada.Calendar.Time := Ada.Calendar.Clock)
   is
      use Ada.Calendar;
      use Ada.Task_Identification;

      Must_Notify : Boolean;
   begin
      Where.Queue.Enqueue (What, Time, Must_Notify);
      if Must_Notify and then Current_Task /= Where.Thread'Identity then
         Where.Thread.Notify;
      end if;
   end Schedule;

   ------------
   -- Runner --
   ------------

   task body Runner is
   begin
      loop
         declare
            use Ada.Calendar;
            use Runnable_Holders;
            Exists  : Boolean;
            Ev      : Event;
         begin
            Parent.Queue.Dequeue (Ev, Exists);
            if Exists and not Dispatchers.Terminating then
               if Ev.Time > Clock then
                  Parent.Queue.Set_Idle (True);
               end if;

               select
                  -- An earlier event has arrived, so requeue
                  accept Notify;
                  Parent.Queue.Enqueue (Ev);
               or
                  delay until Ev.Time; -- This wait may perfectly well be 0

                  Parent.Queue.Set_Idle (False);
                  Ev.Code.Ref.Run;
               end select;
            else
               Parent.Queue.Set_Idle (True);
               select
                  accept Notify;
               or
                  terminate;
               end select;
            end if;
         exception
            when E : others =>
               Debug.Report (E, "At Dispatchers.Single.Runner: ", Debug.Warn, Reraise => False);
         end;
      end loop;
   end Runner;

   ----------
   -- Safe --
   ----------

   protected body Safe is

      -------------
      -- Enqueue --
      -------------

      procedure Enqueue
        (R : Runnable'Class;
         Time : Ada.Calendar.Time;
         Notify : out Boolean)
      is
         use Ada.Calendar;
         use Runnable_Holders;
      begin
         if Queue.Is_Empty or else Queue.Constant_Reference (Queue.First).Time > Time then
            Notify := True;
         end if;
--         Put_Line ("enqueue:" & Seq'Img);
         Queue.Insert ((Seq, Time, +R));
         Seq := Seq + 1;
      end Enqueue;

      -------------
      -- Enqueue --
      -------------

      procedure Enqueue (E : Event) is
      begin
         Queue.Insert (E);
      end Enqueue;

      -------------
      -- Dequeue --
      -------------

      procedure Dequeue (E : out Event; Exists : out Boolean) is
      begin
         Exists := not Queue.Is_Empty;
         if Exists then
            E := Queue.First_Element;
            Queue.Delete_First;
--            Put_Line ("dequeue:" & E.Id'Img);
         end if;
      end Dequeue;

      --------------
      -- Set_Idle --
      --------------

      procedure Set_Idle (Idle : Boolean) is
      begin
         Safe.Idle := Idle;
      end Set_Idle;

      -------------
      -- Is_Idle --
      -------------

      function Is_Idle return Boolean is
      begin
         return Idle;
      end Is_Idle;

   end Safe;

end Rx.Dispatchers.Single;