gcc/ada/libgnarl/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-2020, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This is the Windows native version of this package
  33
  34 with Ada.Task_Identification;           use Ada.Task_Identification;
  35 with Ada.Unchecked_Conversion;
  36
  37 with System.OS_Interface;               use System.OS_Interface;
  38 with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
  39 with System.Tasking;                    use System.Tasking;
  40 with System.Win32;                      use System.Win32;
  41
  42 package body Ada.Execution_Time with
  43   SPARK_Mode => Off
  44 is
  45
  46    ---------
  47    -- "+" --
  48    ---------
  49
  50    function "+"
  51      (Left  : CPU_Time;
  52       Right : Ada.Real_Time.Time_Span) return CPU_Time
  53    is
  54       use type Ada.Real_Time.Time;
  55    begin
  56       return CPU_Time (Ada.Real_Time.Time (Left) + Right);
  57    end "+";
  58
  59    function "+"
  60      (Left  : Ada.Real_Time.Time_Span;
  61       Right : CPU_Time) return CPU_Time
  62    is
  63       use type Ada.Real_Time.Time;
  64    begin
  65       return CPU_Time (Left + Ada.Real_Time.Time (Right));
  66    end "+";
  67
  68    ---------
  69    -- "-" --
  70    ---------
  71
  72    function "-"
  73      (Left  : CPU_Time;
  74       Right : Ada.Real_Time.Time_Span) return CPU_Time
  75    is
  76       use type Ada.Real_Time.Time;
  77    begin
  78       return CPU_Time (Ada.Real_Time.Time (Left) - Right);
  79    end "-";
  80
  81    function "-"
  82      (Left  : CPU_Time;
  83       Right : CPU_Time) return Ada.Real_Time.Time_Span
  84    is
  85       use type Ada.Real_Time.Time;
  86    begin
  87       return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
  88    end "-";
  89
  90    -----------
  91    -- Clock --
  92    -----------
  93
  94    function Clock
  95      (T : Ada.Task_Identification.Task_Id :=
  96         Ada.Task_Identification.Current_Task) return CPU_Time
  97    is
  98       Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
  99
 100       function To_Time is new Ada.Unchecked_Conversion
 101         (Duration, Ada.Real_Time.Time);
 102
 103       function To_Task_Id is new Ada.Unchecked_Conversion
 104         (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
 105
 106       C_Time : aliased Long_Long_Integer;
 107       E_Time : aliased Long_Long_Integer;
 108       K_Time : aliased Long_Long_Integer;
 109       U_Time : aliased Long_Long_Integer;
 110       Res    : BOOL;
 111
 112    begin
 113       if T = Ada.Task_Identification.Null_Task_Id then
 114          raise Program_Error;
 115       end if;
 116
 117       Res :=
 118         GetThreadTimes
 119           (HANDLE (Get_Thread_Id (To_Task_Id (T))),
 120            C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access);
 121
 122       if Res = System.Win32.FALSE then
 123          raise Program_Error;
 124       end if;
 125
 126       return
 127         CPU_Time
 128           (To_Time
 129              (Duration
 130                 ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec)
 131                  + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec))));
 132    end Clock;
 133
 134    --------------------------
 135    -- Clock_For_Interrupts --
 136    --------------------------
 137
 138    function Clock_For_Interrupts return CPU_Time is
 139    begin
 140       --  According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
 141       --  is set to False the function raises Program_Error.
 142
 143       raise Program_Error;
 144       return CPU_Time_First;
 145    end Clock_For_Interrupts;
 146
 147    -----------
 148    -- Split --
 149    -----------
 150
 151    procedure Split
 152      (T  : CPU_Time;
 153       SC : out Ada.Real_Time.Seconds_Count;
 154       TS : out Ada.Real_Time.Time_Span)
 155    is
 156    begin
 157       Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
 158    end Split;
 159
 160    -------------
 161    -- Time_Of --
 162    -------------
 163
 164    function Time_Of
 165      (SC : Ada.Real_Time.Seconds_Count;
 166       TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
 167       return CPU_Time
 168    is
 169    begin
 170       return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
 171    end Time_Of;
 172
 173 end Ada.Execution_Time;