File : s-auxdec.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . A U X _ D E C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2010, 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 -- --
19 -- --
20 -- --
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 pragma Style_Checks (All_Checks);
33 -- Turn off alpha ordering check on subprograms, this unit is laid
34 -- out to correspond to the declarations in the DEC 83 System unit.
35
36 with System.Soft_Links;
37
38 package body System.Aux_DEC is
39
40 package SSL renames System.Soft_Links;
41
42 -----------------------------------
43 -- Operations on Largest_Integer --
44 -----------------------------------
45
46 -- It would be nice to replace these with intrinsics, but that does
47 -- not work yet (the back end would be ok, but GNAT itself objects)
48
49 type LIU is mod 2 ** Largest_Integer'Size;
50 -- Unsigned type of same length as Largest_Integer
51
52 function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer);
53 function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU);
54
55 function "not" (Left : Largest_Integer) return Largest_Integer is
56 begin
57 return To_LI (not From_LI (Left));
58 end "not";
59
60 function "and" (Left, Right : Largest_Integer) return Largest_Integer is
61 begin
62 return To_LI (From_LI (Left) and From_LI (Right));
63 end "and";
64
65 function "or" (Left, Right : Largest_Integer) return Largest_Integer is
66 begin
67 return To_LI (From_LI (Left) or From_LI (Right));
68 end "or";
69
70 function "xor" (Left, Right : Largest_Integer) return Largest_Integer is
71 begin
72 return To_LI (From_LI (Left) xor From_LI (Right));
73 end "xor";
74
75 --------------------------------------
76 -- Arithmetic Operations on Address --
77 --------------------------------------
78
79 -- It would be nice to replace these with intrinsics, but that does
80 -- not work yet (the back end would be ok, but GNAT itself objects)
81
82 Asiz : constant Integer := Integer (Address'Size) - 1;
83
84 type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1;
85 -- Signed type of same size as Address
86
87 function To_A is new Ada.Unchecked_Conversion (SA, Address);
88 function From_A is new Ada.Unchecked_Conversion (Address, SA);
89
90 function "+" (Left : Address; Right : Integer) return Address is
91 begin
92 return To_A (From_A (Left) + SA (Right));
93 end "+";
94
95 function "+" (Left : Integer; Right : Address) return Address is
96 begin
97 return To_A (SA (Left) + From_A (Right));
98 end "+";
99
100 function "-" (Left : Address; Right : Address) return Integer is
101 pragma Unsuppress (All_Checks);
102 -- Because this can raise Constraint_Error for 64-bit addresses
103 begin
104 return Integer (From_A (Left) - From_A (Right));
105 end "-";
106
107 function "-" (Left : Address; Right : Integer) return Address is
108 begin
109 return To_A (From_A (Left) - SA (Right));
110 end "-";
111
112 ------------------------
113 -- Fetch_From_Address --
114 ------------------------
115
116 function Fetch_From_Address (A : Address) return Target is
117 type T_Ptr is access all Target;
118 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
119 Ptr : constant T_Ptr := To_T_Ptr (A);
120 begin
121 return Ptr.all;
122 end Fetch_From_Address;
123
124 -----------------------
125 -- Assign_To_Address --
126 -----------------------
127
128 procedure Assign_To_Address (A : Address; T : Target) is
129 type T_Ptr is access all Target;
130 function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
131 Ptr : constant T_Ptr := To_T_Ptr (A);
132 begin
133 Ptr.all := T;
134 end Assign_To_Address;
135
136 ---------------------------------
137 -- Operations on Unsigned_Byte --
138 ---------------------------------
139
140 -- It would be nice to replace these with intrinsics, but that does
141 -- not work yet (the back end would be ok, but GNAT itself objects)
142
143 type BU is mod 2 ** Unsigned_Byte'Size;
144 -- Unsigned type of same length as Unsigned_Byte
145
146 function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte);
147 function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU);
148
149 function "not" (Left : Unsigned_Byte) return Unsigned_Byte is
150 begin
151 return To_B (not From_B (Left));
152 end "not";
153
154 function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
155 begin
156 return To_B (From_B (Left) and From_B (Right));
157 end "and";
158
159 function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
160 begin
161 return To_B (From_B (Left) or From_B (Right));
162 end "or";
163
164 function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is
165 begin
166 return To_B (From_B (Left) xor From_B (Right));
167 end "xor";
168
169 ---------------------------------
170 -- Operations on Unsigned_Word --
171 ---------------------------------
172
173 -- It would be nice to replace these with intrinsics, but that does
174 -- not work yet (the back end would be ok, but GNAT itself objects)
175
176 type WU is mod 2 ** Unsigned_Word'Size;
177 -- Unsigned type of same length as Unsigned_Word
178
179 function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word);
180 function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU);
181
182 function "not" (Left : Unsigned_Word) return Unsigned_Word is
183 begin
184 return To_W (not From_W (Left));
185 end "not";
186
187 function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is
188 begin
189 return To_W (From_W (Left) and From_W (Right));
190 end "and";
191
192 function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is
193 begin
194 return To_W (From_W (Left) or From_W (Right));
195 end "or";
196
197 function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is
198 begin
199 return To_W (From_W (Left) xor From_W (Right));
200 end "xor";
201
202 -------------------------------------
203 -- Operations on Unsigned_Longword --
204 -------------------------------------
205
206 -- It would be nice to replace these with intrinsics, but that does
207 -- not work yet (the back end would be ok, but GNAT itself objects)
208
209 type LWU is mod 2 ** Unsigned_Longword'Size;
210 -- Unsigned type of same length as Unsigned_Longword
211
212 function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword);
213 function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU);
214
215 function "not" (Left : Unsigned_Longword) return Unsigned_Longword is
216 begin
217 return To_LW (not From_LW (Left));
218 end "not";
219
220 function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
221 begin
222 return To_LW (From_LW (Left) and From_LW (Right));
223 end "and";
224
225 function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
226 begin
227 return To_LW (From_LW (Left) or From_LW (Right));
228 end "or";
229
230 function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is
231 begin
232 return To_LW (From_LW (Left) xor From_LW (Right));
233 end "xor";
234
235 -------------------------------
236 -- Operations on Unsigned_32 --
237 -------------------------------
238
239 -- It would be nice to replace these with intrinsics, but that does
240 -- not work yet (the back end would be ok, but GNAT itself objects)
241
242 type U32 is mod 2 ** Unsigned_32'Size;
243 -- Unsigned type of same length as Unsigned_32
244
245 function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32);
246 function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32);
247
248 function "not" (Left : Unsigned_32) return Unsigned_32 is
249 begin
250 return To_U32 (not From_U32 (Left));
251 end "not";
252
253 function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
254 begin
255 return To_U32 (From_U32 (Left) and From_U32 (Right));
256 end "and";
257
258 function "or" (Left, Right : Unsigned_32) return Unsigned_32 is
259 begin
260 return To_U32 (From_U32 (Left) or From_U32 (Right));
261 end "or";
262
263 function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
264 begin
265 return To_U32 (From_U32 (Left) xor From_U32 (Right));
266 end "xor";
267
268 -------------------------------------
269 -- Operations on Unsigned_Quadword --
270 -------------------------------------
271
272 -- It would be nice to replace these with intrinsics, but that does
273 -- not work yet (the back end would be ok, but GNAT itself objects)
274
275 type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size
276 -- Unsigned type of same length as Unsigned_Quadword
277
278 function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword);
279 function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU);
280
281 function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is
282 begin
283 return To_QW (not From_QW (Left));
284 end "not";
285
286 function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
287 begin
288 return To_QW (From_QW (Left) and From_QW (Right));
289 end "and";
290
291 function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
292 begin
293 return To_QW (From_QW (Left) or From_QW (Right));
294 end "or";
295
296 function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is
297 begin
298 return To_QW (From_QW (Left) xor From_QW (Right));
299 end "xor";
300
301 -----------------------
302 -- Clear_Interlocked --
303 -----------------------
304
305 procedure Clear_Interlocked
306 (Bit : in out Boolean;
307 Old_Value : out Boolean)
308 is
309 begin
310 SSL.Lock_Task.all;
311 Old_Value := Bit;
312 Bit := False;
313 SSL.Unlock_Task.all;
314 end Clear_Interlocked;
315
316 procedure Clear_Interlocked
317 (Bit : in out Boolean;
318 Old_Value : out Boolean;
319 Retry_Count : Natural;
320 Success_Flag : out Boolean)
321 is
322 pragma Warnings (Off, Retry_Count);
323
324 begin
325 SSL.Lock_Task.all;
326 Old_Value := Bit;
327 Bit := False;
328 Success_Flag := True;
329 SSL.Unlock_Task.all;
330 end Clear_Interlocked;
331
332 ---------------------
333 -- Set_Interlocked --
334 ---------------------
335
336 procedure Set_Interlocked
337 (Bit : in out Boolean;
338 Old_Value : out Boolean)
339 is
340 begin
341 SSL.Lock_Task.all;
342 Old_Value := Bit;
343 Bit := True;
344 SSL.Unlock_Task.all;
345 end Set_Interlocked;
346
347 procedure Set_Interlocked
348 (Bit : in out Boolean;
349 Old_Value : out Boolean;
350 Retry_Count : Natural;
351 Success_Flag : out Boolean)
352 is
353 pragma Warnings (Off, Retry_Count);
354
355 begin
356 SSL.Lock_Task.all;
357 Old_Value := Bit;
358 Bit := True;
359 Success_Flag := True;
360 SSL.Unlock_Task.all;
361 end Set_Interlocked;
362
363 ---------------------
364 -- Add_Interlocked --
365 ---------------------
366
367 procedure Add_Interlocked
368 (Addend : Short_Integer;
369 Augend : in out Aligned_Word;
370 Sign : out Integer)
371 is
372 begin
373 SSL.Lock_Task.all;
374 Augend.Value := Augend.Value + Addend;
375
376 if Augend.Value < 0 then
377 Sign := -1;
378 elsif Augend.Value > 0 then
379 Sign := +1;
380 else
381 Sign := 0;
382 end if;
383
384 SSL.Unlock_Task.all;
385 end Add_Interlocked;
386
387 ----------------
388 -- Add_Atomic --
389 ----------------
390
391 procedure Add_Atomic
392 (To : in out Aligned_Integer;
393 Amount : Integer)
394 is
395 begin
396 SSL.Lock_Task.all;
397 To.Value := To.Value + Amount;
398 SSL.Unlock_Task.all;
399 end Add_Atomic;
400
401 procedure Add_Atomic
402 (To : in out Aligned_Integer;
403 Amount : Integer;
404 Retry_Count : Natural;
405 Old_Value : out Integer;
406 Success_Flag : out Boolean)
407 is
408 pragma Warnings (Off, Retry_Count);
409
410 begin
411 SSL.Lock_Task.all;
412 Old_Value := To.Value;
413 To.Value := To.Value + Amount;
414 Success_Flag := True;
415 SSL.Unlock_Task.all;
416 end Add_Atomic;
417
418 procedure Add_Atomic
419 (To : in out Aligned_Long_Integer;
420 Amount : Long_Integer)
421 is
422 begin
423 SSL.Lock_Task.all;
424 To.Value := To.Value + Amount;
425 SSL.Unlock_Task.all;
426 end Add_Atomic;
427
428 procedure Add_Atomic
429 (To : in out Aligned_Long_Integer;
430 Amount : Long_Integer;
431 Retry_Count : Natural;
432 Old_Value : out Long_Integer;
433 Success_Flag : out Boolean)
434 is
435 pragma Warnings (Off, Retry_Count);
436
437 begin
438 SSL.Lock_Task.all;
439 Old_Value := To.Value;
440 To.Value := To.Value + Amount;
441 Success_Flag := True;
442 SSL.Unlock_Task.all;
443 end Add_Atomic;
444
445 ----------------
446 -- And_Atomic --
447 ----------------
448
449 type IU is mod 2 ** Integer'Size;
450 type LU is mod 2 ** Long_Integer'Size;
451
452 function To_IU is new Ada.Unchecked_Conversion (Integer, IU);
453 function From_IU is new Ada.Unchecked_Conversion (IU, Integer);
454
455 function To_LU is new Ada.Unchecked_Conversion (Long_Integer, LU);
456 function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer);
457
458 procedure And_Atomic
459 (To : in out Aligned_Integer;
460 From : Integer)
461 is
462 begin
463 SSL.Lock_Task.all;
464 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
465 SSL.Unlock_Task.all;
466 end And_Atomic;
467
468 procedure And_Atomic
469 (To : in out Aligned_Integer;
470 From : Integer;
471 Retry_Count : Natural;
472 Old_Value : out Integer;
473 Success_Flag : out Boolean)
474 is
475 pragma Warnings (Off, Retry_Count);
476
477 begin
478 SSL.Lock_Task.all;
479 Old_Value := To.Value;
480 To.Value := From_IU (To_IU (To.Value) and To_IU (From));
481 Success_Flag := True;
482 SSL.Unlock_Task.all;
483 end And_Atomic;
484
485 procedure And_Atomic
486 (To : in out Aligned_Long_Integer;
487 From : Long_Integer)
488 is
489 begin
490 SSL.Lock_Task.all;
491 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
492 SSL.Unlock_Task.all;
493 end And_Atomic;
494
495 procedure And_Atomic
496 (To : in out Aligned_Long_Integer;
497 From : Long_Integer;
498 Retry_Count : Natural;
499 Old_Value : out Long_Integer;
500 Success_Flag : out Boolean)
501 is
502 pragma Warnings (Off, Retry_Count);
503
504 begin
505 SSL.Lock_Task.all;
506 Old_Value := To.Value;
507 To.Value := From_LU (To_LU (To.Value) and To_LU (From));
508 Success_Flag := True;
509 SSL.Unlock_Task.all;
510 end And_Atomic;
511
512 ---------------
513 -- Or_Atomic --
514 ---------------
515
516 procedure Or_Atomic
517 (To : in out Aligned_Integer;
518 From : Integer)
519 is
520 begin
521 SSL.Lock_Task.all;
522 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
523 SSL.Unlock_Task.all;
524 end Or_Atomic;
525
526 procedure Or_Atomic
527 (To : in out Aligned_Integer;
528 From : Integer;
529 Retry_Count : Natural;
530 Old_Value : out Integer;
531 Success_Flag : out Boolean)
532 is
533 pragma Warnings (Off, Retry_Count);
534
535 begin
536 SSL.Lock_Task.all;
537 Old_Value := To.Value;
538 To.Value := From_IU (To_IU (To.Value) or To_IU (From));
539 Success_Flag := True;
540 SSL.Unlock_Task.all;
541 end Or_Atomic;
542
543 procedure Or_Atomic
544 (To : in out Aligned_Long_Integer;
545 From : Long_Integer)
546 is
547 begin
548 SSL.Lock_Task.all;
549 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
550 SSL.Unlock_Task.all;
551 end Or_Atomic;
552
553 procedure Or_Atomic
554 (To : in out Aligned_Long_Integer;
555 From : Long_Integer;
556 Retry_Count : Natural;
557 Old_Value : out Long_Integer;
558 Success_Flag : out Boolean)
559 is
560 pragma Warnings (Off, Retry_Count);
561
562 begin
563 SSL.Lock_Task.all;
564 Old_Value := To.Value;
565 To.Value := From_LU (To_LU (To.Value) or To_LU (From));
566 Success_Flag := True;
567 SSL.Unlock_Task.all;
568 end Or_Atomic;
569
570 ------------------------------------
571 -- Declarations for Queue Objects --
572 ------------------------------------
573
574 type QR;
575
576 type QR_Ptr is access QR;
577
578 type QR is record
579 Forward : QR_Ptr;
580 Backward : QR_Ptr;
581 end record;
582
583 function To_QR_Ptr is new Ada.Unchecked_Conversion (Address, QR_Ptr);
584 function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address);
585
586 ------------
587 -- Insqhi --
588 ------------
589
590 procedure Insqhi
591 (Item : Address;
592 Header : Address;
593 Status : out Insq_Status)
594 is
595 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
596 Next : constant QR_Ptr := Hedr.Forward;
597 Itm : constant QR_Ptr := To_QR_Ptr (Item);
598
599 begin
600 SSL.Lock_Task.all;
601
602 Itm.Forward := Next;
603 Itm.Backward := Hedr;
604 Hedr.Forward := Itm;
605
606 if Next = null then
607 Status := OK_First;
608
609 else
610 Next.Backward := Itm;
611 Status := OK_Not_First;
612 end if;
613
614 SSL.Unlock_Task.all;
615 end Insqhi;
616
617 ------------
618 -- Remqhi --
619 ------------
620
621 procedure Remqhi
622 (Header : Address;
623 Item : out Address;
624 Status : out Remq_Status)
625 is
626 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
627 Next : constant QR_Ptr := Hedr.Forward;
628
629 begin
630 SSL.Lock_Task.all;
631
632 Item := From_QR_Ptr (Next);
633
634 if Next = null then
635 Status := Fail_Was_Empty;
636
637 else
638 Hedr.Forward := To_QR_Ptr (Item).Forward;
639
640 if Hedr.Forward = null then
641 Status := OK_Empty;
642
643 else
644 Hedr.Forward.Backward := Hedr;
645 Status := OK_Not_Empty;
646 end if;
647 end if;
648
649 SSL.Unlock_Task.all;
650 end Remqhi;
651
652 ------------
653 -- Insqti --
654 ------------
655
656 procedure Insqti
657 (Item : Address;
658 Header : Address;
659 Status : out Insq_Status)
660 is
661 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
662 Prev : constant QR_Ptr := Hedr.Backward;
663 Itm : constant QR_Ptr := To_QR_Ptr (Item);
664
665 begin
666 SSL.Lock_Task.all;
667
668 Itm.Backward := Prev;
669 Itm.Forward := Hedr;
670 Hedr.Backward := Itm;
671
672 if Prev = null then
673 Status := OK_First;
674
675 else
676 Prev.Forward := Itm;
677 Status := OK_Not_First;
678 end if;
679
680 SSL.Unlock_Task.all;
681 end Insqti;
682
683 ------------
684 -- Remqti --
685 ------------
686
687 procedure Remqti
688 (Header : Address;
689 Item : out Address;
690 Status : out Remq_Status)
691 is
692 Hedr : constant QR_Ptr := To_QR_Ptr (Header);
693 Prev : constant QR_Ptr := Hedr.Backward;
694
695 begin
696 SSL.Lock_Task.all;
697
698 Item := From_QR_Ptr (Prev);
699
700 if Prev = null then
701 Status := Fail_Was_Empty;
702
703 else
704 Hedr.Backward := To_QR_Ptr (Item).Backward;
705
706 if Hedr.Backward = null then
707 Status := OK_Empty;
708
709 else
710 Hedr.Backward.Forward := Hedr;
711 Status := OK_Not_Empty;
712 end if;
713 end if;
714
715 SSL.Unlock_Task.all;
716 end Remqti;
717
718 end System.Aux_DEC;