Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnarl/a-exetim__mingw.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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;