1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2010-2023, Free Software Foundation, Inc. --
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. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package defines CUDA-specific datastructures and functions.
28 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Elists
; use Elists
;
33 with Errout
; use Errout
;
34 with Nlists
; use Nlists
;
35 with Nmake
; use Nmake
;
36 with Sem_Aux
; use Sem_Aux
;
37 with Sem_Util
; use Sem_Util
;
38 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
39 with Sinfo
; use Sinfo
;
43 package body GNAT_CUDA
is
45 --------------------------------------
46 -- Hash Table for CUDA_Global nodes --
47 --------------------------------------
49 type Hash_Range
is range 0 .. 510;
50 -- Size of hash table headers
52 function Hash
(F
: Entity_Id
) return Hash_Range
;
53 -- Hash function for hash table
55 package CUDA_Device_Entities_Table
is new
56 GNAT
.HTable
.Simple_HTable
57 (Header_Num
=> Hash_Range
,
59 No_Element
=> No_Elist
,
63 -- The keys of this table are package entities whose bodies contain at
64 -- least one procedure marked with aspect CUDA_Device. The values are
65 -- Elists of the marked entities.
67 package CUDA_Kernels_Table
is new
68 GNAT
.HTable
.Simple_HTable
69 (Header_Num
=> Hash_Range
,
71 No_Element
=> No_Elist
,
75 -- The keys of this table are package entities whose bodies contain at
76 -- least one procedure marked with aspect CUDA_Global. The values are
77 -- Elists of the marked procedures.
79 procedure Empty_CUDA_Global_Subprograms
(Pack_Id
: Entity_Id
);
80 -- For all subprograms marked CUDA_Global in Pack_Id, remove declarations
81 -- and replace statements with a single null statement.
82 -- This is required because CUDA_Global subprograms could be referring to
83 -- device-only symbols, which would result in unknown symbols at link time
85 -- We choose to empty CUDA_Global subprograms rather than completely
86 -- removing them from the package because registering CUDA_Global
87 -- subprograms with the CUDA runtime on the host requires knowing the
88 -- subprogram's host-side address.
90 function Get_CUDA_Device_Entities
(Pack_Id
: Entity_Id
) return Elist_Id
;
91 -- Returns an Elist of all entities marked with pragma CUDA_Device that
92 -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id
93 -- does not contain such entities.
95 procedure Remove_CUDA_Device_Entities
(Pack_Id
: Entity_Id
);
96 -- Removes all entities marked with the CUDA_Device pragma from package
97 -- Pack_Id. Must only be called when compiling for the host.
99 procedure Set_CUDA_Device_Entities
100 (Pack_Id
: Entity_Id
;
102 -- Stores E as the list of CUDA_Device entities belonging to the package
103 -- entity Pack_Id. Pack_Id must not have a list of device entities.
105 procedure Set_CUDA_Kernels
106 (Pack_Id
: Entity_Id
;
108 -- Stores Kernels as the list of kernels belonging to the package entity
109 -- Pack_Id. Pack_Id must not have a list of kernels.
111 ----------------------------
112 -- Add_CUDA_Device_Entity --
113 ----------------------------
115 procedure Add_CUDA_Device_Entity
116 (Pack_Id
: Entity_Id
;
119 Device_Entities
: Elist_Id
:= Get_CUDA_Device_Entities
(Pack_Id
);
121 if No
(Device_Entities
) then
122 Device_Entities
:= New_Elmt_List
;
123 Set_CUDA_Device_Entities
(Pack_Id
, Device_Entities
);
125 Append_Elmt
(E
, Device_Entities
);
126 end Add_CUDA_Device_Entity
;
128 ---------------------
129 -- Add_CUDA_Kernel --
130 ---------------------
132 procedure Add_CUDA_Kernel
133 (Pack_Id
: Entity_Id
;
136 Kernels
: Elist_Id
:= Get_CUDA_Kernels
(Pack_Id
);
139 Kernels
:= New_Elmt_List
;
140 Set_CUDA_Kernels
(Pack_Id
, Kernels
);
142 Append_Elmt
(Kernel
, Kernels
);
145 -----------------------------------
146 -- Empty_CUDA_Global_Subprograms --
147 -----------------------------------
149 procedure Empty_CUDA_Global_Subprograms
(Pack_Id
: Entity_Id
) is
150 Spec_Id
: constant Node_Id
:= Corresponding_Spec
(Pack_Id
);
151 Kernels
: constant Elist_Id
:= Get_CUDA_Kernels
(Spec_Id
);
152 Kernel_Elm
: Elmt_Id
;
154 Kernel_Body
: Node_Id
;
155 Null_Body
: Entity_Id
;
158 -- It is an error to empty CUDA_Global subprograms when not compiling
160 pragma Assert
(Debug_Flag_Underscore_C
);
166 Kernel_Elm
:= First_Elmt
(Kernels
);
167 while Present
(Kernel_Elm
) loop
168 Kernel
:= Node
(Kernel_Elm
);
169 Kernel_Body
:= Subprogram_Body
(Kernel
);
170 Loc
:= Sloc
(Kernel_Body
);
172 Null_Body
:= Make_Subprogram_Body
(Loc
,
173 Specification
=> Specification
(Kernel_Body
),
174 Declarations
=> New_List
,
175 Handled_Statement_Sequence
=>
176 Make_Handled_Sequence_Of_Statements
(Loc
,
177 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
179 Set_Corresponding_Spec
(Null_Body
,
180 Corresponding_Spec
(Kernel_Body
));
182 Rewrite
(Kernel_Body
, Null_Body
);
184 Next_Elmt
(Kernel_Elm
);
186 end Empty_CUDA_Global_Subprograms
;
188 -------------------------
189 -- Expand_CUDA_Package --
190 -------------------------
192 procedure Expand_CUDA_Package
(N
: Node_Id
) is
195 -- If not compiling for the host, do not do anything.
197 if not Debug_Flag_Underscore_C
then
201 -- Remove the content (both declarations and statements) of CUDA_Global
202 -- procedures. This is required because CUDA_Global functions could be
203 -- referencing entities available only on the device, which would result
204 -- in unknown symbol errors at link time.
206 Empty_CUDA_Global_Subprograms
(N
);
208 -- Remove CUDA_Device entities (except if they are also CUDA_Host), as
209 -- they can only be referenced from the device and might reference
210 -- device-only symbols.
212 Remove_CUDA_Device_Entities
213 (Package_Specification
(Corresponding_Spec
(N
)));
214 end Expand_CUDA_Package
;
220 function Hash
(F
: Entity_Id
) return Hash_Range
is
222 return Hash_Range
(F
mod 511);
225 ------------------------------
226 -- Get_CUDA_Device_Entities --
227 ------------------------------
229 function Get_CUDA_Device_Entities
(Pack_Id
: Entity_Id
) return Elist_Id
is
231 return CUDA_Device_Entities_Table
.Get
(Pack_Id
);
232 end Get_CUDA_Device_Entities
;
234 ----------------------
235 -- Get_CUDA_Kernels --
236 ----------------------
238 function Get_CUDA_Kernels
(Pack_Id
: Entity_Id
) return Elist_Id
is
240 return CUDA_Kernels_Table
.Get
(Pack_Id
);
241 end Get_CUDA_Kernels
;
243 ---------------------------------
244 -- Remove_CUDA_Device_Entities --
245 ---------------------------------
247 procedure Remove_CUDA_Device_Entities
(Pack_Id
: Entity_Id
) is
248 Device_Entities
: constant Elist_Id
:=
249 Get_CUDA_Device_Entities
(Pack_Id
);
250 Device_Elmt
: Elmt_Id
;
251 Device_Entity
: Entity_Id
;
254 pragma Assert
(Debug_Flag_Underscore_C
);
256 if No
(Device_Entities
) then
260 Device_Elmt
:= First_Elmt
(Device_Entities
);
261 while Present
(Device_Elmt
) loop
262 Device_Entity
:= Node
(Device_Elmt
);
263 Next_Elmt
(Device_Elmt
);
265 case Ekind
(Device_Entity
) is
266 when E_Function | E_Procedure
=>
267 Bod
:= Subprogram_Body
(Device_Entity
);
269 if Nkind
(Parent
(Bod
)) = N_Subunit
270 and then Present
(Corresponding_Stub
(Parent
(Bod
)))
273 ("Cuda_Device not suported on separate subprograms",
274 Corresponding_Stub
(Parent
(Bod
)));
277 Remove
(Subprogram_Spec
(Device_Entity
));
280 when E_Variable | E_Constant
=>
281 Remove
(Declaration_Node
(Device_Entity
));
284 pragma Assert
(False);
287 Remove_Entity_And_Homonym
(Device_Entity
);
289 end Remove_CUDA_Device_Entities
;
291 ------------------------------
292 -- Set_CUDA_Device_Entities --
293 ------------------------------
295 procedure Set_CUDA_Device_Entities
296 (Pack_Id
: Entity_Id
;
300 pragma Assert
(No
(Get_CUDA_Device_Entities
(Pack_Id
)));
301 CUDA_Device_Entities_Table
.Set
(Pack_Id
, E
);
302 end Set_CUDA_Device_Entities
;
304 ----------------------
305 -- Set_CUDA_Kernels --
306 ----------------------
308 procedure Set_CUDA_Kernels
309 (Pack_Id
: Entity_Id
;
313 pragma Assert
(No
(Get_CUDA_Kernels
(Pack_Id
)));
314 CUDA_Kernels_Table
.Set
(Pack_Id
, Kernels
);
315 end Set_CUDA_Kernels
;