gcc/ada/a-exetim-mingw.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                   A D A . E X E C U T I O N _ T I M E                    --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2007, Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is the Windows native version of this package
  35
  36 with Ada.Task_Identification;           use Ada.Task_Identification;
  37 with Ada.Unchecked_Conversion;
  38
  39 with System.OS_Interface;               use System.OS_Interface;
  40 with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
  41 with System.Tasking;                    use System.Tasking;
  42
  43 package body Ada.Execution_Time is
  44
  45    ---------
  46    -- "+" --
  47    ---------
  48
  49    function "+"
  50      (Left  : CPU_Time;
  51       Right : Ada.Real_Time.Time_Span) return CPU_Time
  52    is
  53       use type Ada.Real_Time.Time;
  54    begin
  55       return CPU_Time (Ada.Real_Time.Time (Left) + Right);
  56    end "+";
  57
  58    function "+"
  59      (Left  : Ada.Real_Time.Time_Span;
  60       Right : CPU_Time) return CPU_Time
  61    is
  62       use type Ada.Real_Time.Time;
  63    begin
  64       return CPU_Time (Left + Ada.Real_Time.Time (Right));
  65    end "+";
  66
  67    ---------
  68    -- "-" --
  69    ---------
  70
  71    function "-"
  72      (Left  : CPU_Time;
  73       Right : Ada.Real_Time.Time_Span) return CPU_Time
  74    is
  75       use type Ada.Real_Time.Time;
  76    begin
  77       return CPU_Time (Ada.Real_Time.Time (Left) - Right);
  78    end "-";
  79
  80    function "-"
  81      (Left  : CPU_Time;
  82       Right : CPU_Time) return Ada.Real_Time.Time_Span
  83    is
  84       use type Ada.Real_Time.Time;
  85    begin
  86       return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
  87    end "-";
  88
  89    -----------
  90    -- Clock --
  91    -----------
  92
  93    function Clock
  94      (T : Ada.Task_Identification.Task_Id :=
  95             Ada.Task_Identification.Current_Task) return CPU_Time
  96    is
  97       Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
  98
  99       function To_Time is new Ada.Unchecked_Conversion
 100         (Duration, Ada.Real_Time.Time);
 101
 102       function To_Task_Id is new Ada.Unchecked_Conversion
 103         (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
 104
 105       C_Time : aliased Long_Long_Integer;
 106       E_Time : aliased Long_Long_Integer;
 107       K_Time : aliased Long_Long_Integer;
 108       U_Time : aliased Long_Long_Integer;
 109       Res    : BOOL;
 110
 111    begin
 112       if T = Ada.Task_Identification.Null_Task_Id then
 113          raise Program_Error;
 114       end if;
 115
 116       Res :=
 117         GetThreadTimes
 118           (HANDLE (Get_Thread_Id (To_Task_Id (T))),
 119            C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access);
 120
 121       if Res = False then
 122          raise Program_Error;
 123       end if;
 124
 125       return
 126         CPU_Time
 127           (To_Time
 128              (Duration
 129                 ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec)
 130                  + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec))));
 131    end Clock;
 132
 133    -----------
 134    -- Split --
 135    -----------
 136
 137    procedure Split
 138      (T  : CPU_Time;
 139       SC : out Ada.Real_Time.Seconds_Count;
 140       TS : out Ada.Real_Time.Time_Span)
 141    is
 142       use type Ada.Real_Time.Time;
 143    begin
 144       Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
 145    end Split;
 146
 147    -------------
 148    -- Time_Of --
 149    -------------
 150
 151    function Time_Of
 152      (SC : Ada.Real_Time.Seconds_Count;
 153       TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
 154       return CPU_Time
 155    is
 156    begin
 157       return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
 158    end Time_Of;
 159
 160 end Ada.Execution_Time;