Geek Gadgets 1/ADE-1.bin/ade-dist/gnat-2.06-src.tgz/tar.out/fsf/gnat/ada/s-os2~tp.adb

Text File | 1996-09-28 | 17KB | 610 lines

------------------------------------------------------------------------------
--                                                                          --
--                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS                --
--                                                                          --
--                S Y S T E M . T A S K _ P R I M I T I V E S               --
--                                                                          --
--                                  B o d y                                 --
--                               (OS/2 Version)                             --
--                                                                          --
--                             $Revision: 1.8 $                             --
--                                                                          --
--          Copyright (c) 1993,1994,1995 NYU, All Rights Reserved           --
--                                                                          --
--  GNARL is free software; you can redistribute it and/or modify it  under --
--  terms  of  the  GNU  Library General Public License as published by the --
--  Free Software Foundation; either version 2,  or (at  your  option)  any --
--  later  version.   GNARL is distributed in the hope that it will be use- --
--  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
--  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
--  eral Library Public License for more details.  You should have received --
--  a  copy of the GNU Library General Public License along with GNARL; see --
--  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
--  Ave, Cambridge, MA 02139, USA.                                          --
--                                                                          --
------------------------------------------------------------------------------

with System.Task_Clock.Machine_Specifics;
with Interfaces.C.Strings;    use Interfaces.C.Strings;
with System.Address_To_Access_Conversions;
with System.OS2Lib;           use System.OS2Lib;
with System.OS2Lib.Errors;    use System.OS2Lib.Errors;
with System.Storage_Elements; use System.Storage_Elements;
with System.Io;               use System.Io;

package body System.Task_Primitives is

   Offset : Storage_Offset;
   --  Holds the offset from the base of a thread's stack to the TCB for the
   --  thread. The assumption is that this is the same for all threads. See
   --  description of Self function. Set by Booster.

   Thread_1_TCB_Ptr : TCB_Ptr;
   --  Pointer to TCB of main task. We need this because we can't use the
   --  normal self mechanism (with the "booster" trick) for the main task.
   --  See Self procedure for more details.

   package Address_TCB_Ptr_Ptr_Conversion is
     new Address_To_Access_Conversions (TCB_Ptr);

   package Address_TCB_Ptr_Conversion is
      new Address_To_Access_Conversions (Task_Control_Block);

   package Address_Boolean_Conversion is
     new Address_To_Access_Conversions (Boolean);

   -------------------------
   -- Initialize_LL_Tasks --
   -------------------------

   procedure Initialize_LL_Tasks (T : TCB_Ptr) is
   begin
      T.all := (LL_Entry_Point  => null,
                LL_Arg          => Null_Address,
                Thread          => 1,            --  By definition
                Active_Priority => Default_Priority,
                Aborted         => False);

      Thread_1_TCB_Ptr := T;
   end Initialize_LL_Tasks;

   ----------
   -- Self --
   ----------

   --  When a task is created, the body of the (OS/2) thread is the
   --  procedure Booster, which in turn calls the actual task body.
   --  Booster has a local variable where the TCB pointer is stored.

   --  The assumption is that the offset from the base of the thread's
   --  stack to this variable is always the same; this offset is stored
   --  in the global variable Offset by Booster itself.

   --  Therefore, we retrieve the stack pointer as the location at Offset
   --  from the thread's stack base.

   --  Note: This does not work for Thread 1, since this one is not created
   --  using the Booster trick. Thread 1 TCB addr is in Thread_1_TCB_Ptr.

   function Self return TCB_Ptr is
      use Address_TCB_Ptr_Ptr_Conversion;

      Process_Info : aliased PPIB;
      Thread_Info  : aliased PTIB;

   begin
      Must_Not_Fail
        (DosGetInfoBlocks (Thread_Info'Access, Process_Info'Access));

      if Thread_Info.tib_ptib2.tib2_ultid = 1 then
         return Thread_1_TCB_Ptr;
      else
         return To_Pointer (Thread_Info.tib_pstack + Offset).all;
      end if;
   end Self;

   -------------
   -- Booster --
   -------------

   procedure Booster (Info : PVOID);
   --  See description above for Self function

   procedure Booster (Info : PVOID) is

      use Address_TCB_Ptr_Conversion;

      My_TCB_Ptr : TCB_Ptr;

   begin
      My_TCB_Ptr := To_Pointer (Info).all'Access;

      declare
         Process_Info : aliased PPIB;
         Thread_Info  : aliased PTIB;

      begin
         if DosGetInfoBlocks (Thread_Info'Access, Process_Info'Access)
                                         = NO_ERROR
         then
            Offset := My_TCB_Ptr'Address - Thread_Info.tib_pstack;
         else
            raise Storage_error;
         end if;
      end;

      --  Here we go!

      My_TCB_Ptr.LL_Entry_Point (My_TCB_Ptr.LL_Arg);

   end Booster;

   --------------------
   -- Create_LL_Task --
   --------------------

   procedure Create_LL_Task
     (Priority       : Priority;
      Stack_Size     : Task_Storage_Size;
      LL_Entry_Point : LL_Task_Procedure_Access;
      Arg            : Address;
      T              : TCB_Ptr)
   is
      use Interfaces.C;
      use Address_TCB_Ptr_Conversion;

      Result : OS2Lib.APIRET;
      Id     : aliased TID;
      Junk1  : PVOID; -- TBSL ???
      Junk2  : ULONG; -- TBSL ???

   begin
      --  Step 1: Create the thread in blocked mode

      Junk1  := Address_TCB_Ptr_Conversion.To_Address (T.all'Access);
      Junk2  := ULONG (Stack_Size);
      Result := DosCreateThread
                   (F_ptid   => Id'Unchecked_Access,
                    pfn      => LL_Task_Procedure_Access'(Booster'Access),
                    param    => Junk1,
                    flag     => 1, -- Block_child + No_commit_stack,
                    cbStack  => Junk2);
      if Result /= NO_ERROR then
         raise Storage_error;
      end if;

      --  Step 2: set its TCB

      T.all := (LL_Entry_Point => LL_Entry_Point,
                LL_Arg          => Arg,
                Thread          => Id,
                Active_Priority => Priority,
                Aborted         => False);

      --  Step 3: set its priority (child has inherited priority from parent)

      Must_Not_Fail
        (DosSetPriority (Scope   => PRTYS_THREAD,
                         Class   => PRTYC_NOCHANGE,
                         Delta_P => long (Priority - Get_Own_Priority),
                         PorTid  => Id));

      --  Step 4: Now, start it for good:

      Must_Not_Fail (DosResumeThread (Id));

   end Create_LL_Task;

   ------------------
   -- Exit_LL_Task --
   ------------------

   procedure Exit_LL_Task is
   begin
      DosExit (EXIT_THREAD, 0);
   end Exit_LL_Task;

   ---------------------
   -- Initialize_Lock --
   ---------------------

   procedure Initialize_Lock (Prio : Integer; L : in out Lock) is
   begin
      if DosCreateMutexSem (Null_Ptr, L.Mutex'Unchecked_Access, 0, False32)
                                            /= NO_ERROR
      then
         raise Storage_Error;
      end if;

      L.Priority := Prio;
   end Initialize_Lock;

   -------------------
   -- Finalize_Lock --
   -------------------

   procedure Finalize_Lock (L : in out Lock) is
   begin
      Must_Not_Fail (DosCloseMutexSem (L.Mutex));
   end Finalize_Lock;

   ----------------
   -- Write_Lock --
   ----------------

   procedure Write_Lock (L : in out Lock; Ceiling_Violation : out Boolean) is
   begin
      L.Owner_Priority := Get_Own_Priority;

      if L.Priority < L.Owner_Priority then
         Ceiling_Violation := True;
         return;
      end if;

      Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT));

      Ceiling_Violation := False;

      if L.Priority > L.Owner_Priority then
         Set_Own_Priority (L.Priority);
      end if;
   end Write_Lock;

   ---------------
   -- Read_Lock --
   ---------------

   --  Not worth worrying about distinguishing read and write locks until
   --  OS/2 supports multi-processing, since no advantage would be gained.

   procedure Read_Lock (L : in out Lock; Ceiling_Violation : out Boolean)
      renames Write_Lock;

   ------------
   -- Unlock --
   ------------

   procedure Unlock (L : in out Lock) is
   begin
      if L.Owner_Priority /= L.Priority then
         Set_Own_Priority (L.Owner_Priority);
      end if;

      Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
   end Unlock;

   -----------------------
   -- Initalialize_Cond --
   -----------------------

   procedure Initialize_Cond (Cond : in out Condition_Variable) is
      Temporary : aliased HEV;
      --  This temporary is needed for two reasons:
      --  1) Since DosCreateSem operates on an PHEV, not HEV, it is not
      --     derived and thus not available on type Condition_variable.
      --  2) Moreover we cannot have an aliased view of Cond, required
      --     for 'Access.

   begin
      Must_Not_Fail
        (DosCreateEventSem (Null_Ptr, Temporary'Unchecked_Access, 0, True32));
      Cond := Condition_Variable (Temporary);
   end Initialize_Cond;

   -------------------
   -- Finalize_Cond --
   -------------------

   --  No such problem here, DosCloseEventSem has been derived.
   --  What does such refer to in above comment???

   procedure Finalize_Cond (Cond : in out Condition_Variable) is
   begin
      Must_Not_Fail (DosCloseEventSem (Cond));
   end Finalize_Cond;

   ---------------
   -- Cond_Wait --
   ---------------

   --  Pre-assertion: Cond is posted
   --                 L is locked.

   --  Post-assertion: Cond is posted
   --                  L is locked.

   procedure Cond_Wait
     (Cond : in out Condition_Variable;
      L    : in out Lock)
   is
      Count : aliased ULONG; -- Unused
      Error : Boolean;
   begin
      --  Must reset Cond BEFORE L is unlocked.

      Must_Not_Fail (DosResetEventSem (Cond, Count'Unchecked_Access));
      Unlock (L);

      --  No problem if we are interrupted here: if the condition is signaled,
      --  DosWaitEventSem will simply not block

      Must_Not_Fail (DosWaitEventSem (Cond, SEM_INDEFINITE_WAIT));

      --  Since L was previously accquired, Error cannot be false:

      Write_Lock (L, Error);
   end Cond_Wait;

   ---------------------
   -- Cond_Timed_Wait --
   ---------------------

   --  Pre-assertion: Cond is posted
   --                 L is locked.

   --  Post-assertion: Cond is posted
   --                  L is locked.

   procedure Cond_Timed_Wait
     (Cond      : in out Condition_Variable;
      L         : in out Lock;
      Abs_Time  : System.Task_Clock.Stimespec;
      Timed_Out : out Boolean)
   is
      use System.Task_Clock;
      use System.Task_Clock.Machine_Specifics;

      Count    : aliased ULONG; -- Unused
      Time_Out : ULONG;
      Error    : Boolean;
      Rel_Time : Stimespec;

   begin
      --  Change Abs_time to a relative delay.

      --  Be careful not to reintroduce the race condition that gave birth
      --  to delay until.

      Must_Not_Fail (DosEnterCritSec);
      Rel_Time := Abs_Time - Clock;
      Must_Not_Fail (DosExitCritSec);

      --  Must reset Cond BEFORE L is unlocked.

      Must_Not_Fail (DosResetEventSem (Cond, Count'Unchecked_Access));
      Unlock (L);

      --  No problem if we are interrupted here: if the condition is signaled,
      --  DosWaitEventSem will simply not block

      if Rel_Time <= Stimespec_Zero then
         Timed_Out := True;
      else
         Time_Out := ULONG (Stimespec_Seconds  (Rel_Time)) * 1000 +
                     ULONG (Stimespec_NSeconds (Rel_Time) / 1E6);
         Timed_Out :=  DosWaitEventSem (Cond, Time_Out) = ERROR_TIMEOUT;
      end if;

      --  Since L was previously accquired, Error cannot be false

      Write_Lock (L, Error);

      --  Ensure post-condition

      if Timed_Out then
         Must_Not_Fail (DosPostEventSem (Cond));
      end if;
   end Cond_Timed_Wait;

   -----------------
   -- Cond_Signal --
   -----------------

   procedure Cond_Signal (Cond : in out Condition_Variable) is
   begin
      Must_Not_Fail (DosPostEventSem (Cond));
   end Cond_Signal;

   ------------------
   -- Set_Priority --
   ------------------

   --  Note: Currently, we have only 32 priorities, all in Regular Class.
   --  Priority level 31 is the only value for Interrupt_Priority. (see
   --  package System). A better choice (for OS/2) would be to have 32
   --  priorities in Regular class for subtype Priority and 32 priorities
   --  in Time-critical class for Interrupt_Priority ???

   procedure Set_Priority (T : TCB_Ptr; Prio : Integer) is
      use Interfaces.C;

   begin
      Must_Not_Fail
        (DosSetPriority (Scope   => PRTYS_THREAD,
                         Class   => PRTYC_NOCHANGE,
                         Delta_P => long (Prio - T.Active_Priority),
                         PorTid  => T.Thread));
      T.Active_Priority := Prio;
   end Set_Priority;

   ----------------------
   -- Set_Own_Priority --
   ----------------------

   procedure Set_Own_Priority (Prio : Integer) is
   begin
      Set_Priority (Self, Prio);
   end Set_Own_Priority;

   ------------------
   -- Get_Priority --
   ------------------

   function Get_Priority (T : TCB_Ptr) return Integer is
   begin
      return T.Active_Priority;
   end Get_Priority;

   ----------------------
   -- Get_Own_Priority --
   ----------------------

   function Get_Own_Priority return Integer is
   begin
      return Get_Priority (Self);
   end Get_Own_Priority;

   ----------------
   -- Abort_Task --
   ----------------

   procedure Abort_Task (T : TCB_Ptr) is
   begin
      T.Aborted := True;
   end Abort_Task;

   ----------------
   -- Test_Abort --
   ----------------

   Current_Abort_Handler : Abort_Handler_Pointer;

   procedure Test_Abort is
   begin
      if Self.Aborted then
         Current_Abort_Handler (0);   -- Parameter not used
      end if;
   end Test_Abort;

   ---------------------------
   -- Install_Abort_Handler --
   ---------------------------

   procedure Install_Abort_Handler (Handler : Abort_Handler_Pointer) is
   begin
      Current_Abort_Handler := Handler;
   end Install_Abort_Handler;

   ---------------------------
   -- Install_Error_Handler --
   ---------------------------

   procedure Install_Error_Handler (Handler : Address) is
   begin
      null;
   end Install_Error_Handler;

   -----------------
   -- Signal_Task --
   -----------------

   procedure Signal_Task (T : TCB_Ptr; I : Interrupt_ID) is
   begin
      raise Program_Error;
   end Signal_Task;

   ---------------------
   -- Wait_For_Signal --
   ---------------------

   procedure Wait_for_Signal (I : Interrupt_ID) is
   begin
      raise PROGRAM_ERROR;
   end Wait_for_Signal;

   ---------------------
   -- Reserved_Signal --
   ---------------------

   function Reserved_Signal (I : Interrupt_ID) return Boolean is
   begin
      return False;
   end Reserved_Signal;

   ------------------
   -- Test_And_Set --
   ------------------

   Test_And_Set_Mutex : Lock;
   --  Lock used by Test_And_Set procedure

   -------------------------
   -- Initialize_TAS_Cell --
   -------------------------

   procedure Initialize_TAS_Cell (Cell : out TAS_Cell) is
   begin
      Cell.Value := False;
   end Initialize_TAS_Cell;

   -----------------------
   -- Finalize_TAS_Cell --
   -----------------------

   procedure Finalize_TAS_Cell   (Cell : in out TAS_Cell) is
   begin
      null;
   end Finalize_TAS_Cell;

   -----------
   -- Clear --
   -----------

   --  This was not atomic with respect to another Test_and_Set in the
   --  original code.  Need it be???

   procedure Clear (Cell : in out TAS_Cell) is
   begin
      Cell.Value := False;
   end Clear;

   ------------
   -- Is_Set --
   ------------

   --  This was not atomic with respect to another Test_and_Set in the
   --  original code.  Need it be???

   function Is_Set (Cell : in TAS_Cell) return Boolean is
   begin
      return Cell.Value;
   end Is_Set;

   ------------------
   -- Test_And_Set --
   ------------------

   procedure Test_And_Set (Cell : in out TAS_Cell; Result : out Boolean) is
      Error : Boolean;
   begin
      Write_Lock (Test_And_Set_Mutex, Error);

      if Cell.Value then
         Result := False;
      else
         Result :=  True;
         Cell.Value := True;
      end if;

      Unlock (Test_And_Set_Mutex);
   end Test_And_Set;

   ---------------
   -- LL_Assert --
   ---------------

   procedure LL_Assert (B : Boolean; M : String) is
   begin
      if not B then
         Put ("Failed assertion: ");
         Put (M);
         Put ('.');
         New_Line;
         pragma Assert (False);
      end if;
   end LL_Assert;

begin
   Initialize_Lock (System.Priority'Last, Test_And_Set_Mutex);
end System.Task_Primitives;