OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-auxdec-vms-ia64.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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
-- 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 Itanium/VMS version.
33
 
34
--  The Add,Clear_Interlocked subprograms are dubiously implmented due to
35
--  the lack of a single bit sync_lock_test_and_set builtin.
36
 
37
--  The "Retry" parameter is ignored due to the lack of retry builtins making
38
--  the subprograms identical to the non-retry versions.
39
 
40
pragma Style_Checks (All_Checks);
41
--  Turn off alpha ordering check on subprograms, this unit is laid
42
--  out to correspond to the declarations in the DEC 83 System unit.
43
 
44
with Interfaces;
45
package body System.Aux_DEC is
46
 
47
   use type Interfaces.Unsigned_8;
48
 
49
   ------------------------
50
   -- Fetch_From_Address --
51
   ------------------------
52
 
53
   function Fetch_From_Address (A : Address) return Target is
54
      type T_Ptr is access all Target;
55
      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
56
      Ptr : constant T_Ptr := To_T_Ptr (A);
57
   begin
58
      return Ptr.all;
59
   end Fetch_From_Address;
60
 
61
   -----------------------
62
   -- Assign_To_Address --
63
   -----------------------
64
 
65
   procedure Assign_To_Address (A : Address; T : Target) is
66
      type T_Ptr is access all Target;
67
      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
68
      Ptr : constant T_Ptr := To_T_Ptr (A);
69
   begin
70
      Ptr.all := T;
71
   end Assign_To_Address;
72
 
73
   -----------------------
74
   -- Clear_Interlocked --
75
   -----------------------
76
 
77
   procedure Clear_Interlocked
78
     (Bit       : in out Boolean;
79
      Old_Value : out Boolean)
80
   is
81
      Clr_Bit : Boolean := Bit;
82
      Old_Uns : Interfaces.Unsigned_8;
83
 
84
      function Sync_Lock_Test_And_Set
85
        (Ptr   : Address;
86
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
87
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
88
                     "__sync_lock_test_and_set_1");
89
 
90
   begin
91
      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
92
      Bit := Clr_Bit;
93
      Old_Value := Old_Uns /= 0;
94
   end Clear_Interlocked;
95
 
96
   procedure Clear_Interlocked
97
     (Bit          : in out Boolean;
98
      Old_Value    : out Boolean;
99
      Retry_Count  : Natural;
100
      Success_Flag : out Boolean)
101
   is
102
      pragma Unreferenced (Retry_Count);
103
 
104
      Clr_Bit : Boolean := Bit;
105
      Old_Uns : Interfaces.Unsigned_8;
106
 
107
      function Sync_Lock_Test_And_Set
108
        (Ptr   : Address;
109
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
110
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
111
                     "__sync_lock_test_and_set_1");
112
 
113
   begin
114
      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
115
      Bit := Clr_Bit;
116
      Old_Value := Old_Uns /= 0;
117
      Success_Flag := True;
118
   end Clear_Interlocked;
119
 
120
   ---------------------
121
   -- Set_Interlocked --
122
   ---------------------
123
 
124
   procedure Set_Interlocked
125
     (Bit       : in out Boolean;
126
      Old_Value : out Boolean)
127
   is
128
      Set_Bit : Boolean := Bit;
129
      Old_Uns : Interfaces.Unsigned_8;
130
 
131
      function Sync_Lock_Test_And_Set
132
        (Ptr   : Address;
133
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
134
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
135
                     "__sync_lock_test_and_set_1");
136
 
137
   begin
138
      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
139
      Bit := Set_Bit;
140
      Old_Value := Old_Uns /= 0;
141
   end Set_Interlocked;
142
 
143
   procedure Set_Interlocked
144
     (Bit          : in out Boolean;
145
      Old_Value    : out Boolean;
146
      Retry_Count  : Natural;
147
      Success_Flag : out Boolean)
148
   is
149
      pragma Unreferenced (Retry_Count);
150
 
151
      Set_Bit : Boolean := Bit;
152
      Old_Uns : Interfaces.Unsigned_8;
153
 
154
      function Sync_Lock_Test_And_Set
155
        (Ptr   : Address;
156
         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
157
      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
158
                     "__sync_lock_test_and_set_1");
159
   begin
160
      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
161
      Bit := Set_Bit;
162
      Old_Value := Old_Uns /= 0;
163
      Success_Flag := True;
164
   end Set_Interlocked;
165
 
166
   ---------------------
167
   -- Add_Interlocked --
168
   ---------------------
169
 
170
   procedure Add_Interlocked
171
     (Addend : Short_Integer;
172
      Augend : in out Aligned_Word;
173
      Sign   : out Integer)
174
   is
175
      Overflowed : Boolean := False;
176
      Former     : Aligned_Word;
177
 
178
      function Sync_Fetch_And_Add
179
        (Ptr   : Address;
180
         Value : Short_Integer) return Short_Integer;
181
      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
182
 
183
   begin
184
      Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
185
 
186
      if Augend.Value < 0 then
187
         Sign := -1;
188
      elsif Augend.Value > 0 then
189
         Sign := 1;
190
      else
191
         Sign := 0;
192
      end if;
193
 
194
      if Former.Value > 0 and then Augend.Value <= 0 then
195
         Overflowed := True;
196
      end if;
197
 
198
      if Overflowed then
199
         raise Constraint_Error;
200
      end if;
201
   end Add_Interlocked;
202
 
203
   ----------------
204
   -- Add_Atomic --
205
   ----------------
206
 
207
   procedure Add_Atomic
208
     (To     : in out Aligned_Integer;
209
      Amount : Integer)
210
   is
211
      procedure Sync_Add_And_Fetch
212
        (Ptr   : Address;
213
         Value : Integer);
214
      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
215
   begin
216
      Sync_Add_And_Fetch (To.Value'Address, Amount);
217
   end Add_Atomic;
218
 
219
   procedure Add_Atomic
220
     (To           : in out Aligned_Integer;
221
      Amount       : Integer;
222
      Retry_Count  : Natural;
223
      Old_Value    : out Integer;
224
      Success_Flag : out Boolean)
225
   is
226
      pragma Unreferenced (Retry_Count);
227
 
228
      function Sync_Fetch_And_Add
229
        (Ptr   : Address;
230
         Value : Integer) return Integer;
231
      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
232
 
233
   begin
234
      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
235
      Success_Flag := True;
236
   end Add_Atomic;
237
 
238
   procedure Add_Atomic
239
     (To     : in out Aligned_Long_Integer;
240
      Amount : Long_Integer)
241
   is
242
      procedure Sync_Add_And_Fetch
243
        (Ptr   : Address;
244
         Value : Long_Integer);
245
      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
246
   begin
247
      Sync_Add_And_Fetch (To.Value'Address, Amount);
248
   end Add_Atomic;
249
 
250
   procedure Add_Atomic
251
     (To           : in out Aligned_Long_Integer;
252
      Amount       : Long_Integer;
253
      Retry_Count  : Natural;
254
      Old_Value    : out Long_Integer;
255
      Success_Flag : out Boolean)
256
   is
257
      pragma Unreferenced (Retry_Count);
258
 
259
      function Sync_Fetch_And_Add
260
        (Ptr   : Address;
261
         Value : Long_Integer) return Long_Integer;
262
      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");
263
      --  Why do we keep importing this over and over again???
264
 
265
   begin
266
      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
267
      Success_Flag := True;
268
   end Add_Atomic;
269
 
270
   ----------------
271
   -- And_Atomic --
272
   ----------------
273
 
274
   procedure And_Atomic
275
     (To   : in out Aligned_Integer;
276
      From : Integer)
277
   is
278
      procedure Sync_And_And_Fetch
279
        (Ptr   : Address;
280
         Value : Integer);
281
      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
282
   begin
283
      Sync_And_And_Fetch (To.Value'Address, From);
284
   end And_Atomic;
285
 
286
   procedure And_Atomic
287
     (To           : in out Aligned_Integer;
288
      From         : Integer;
289
      Retry_Count  : Natural;
290
      Old_Value    : out Integer;
291
      Success_Flag : out Boolean)
292
   is
293
      pragma Unreferenced (Retry_Count);
294
 
295
      function Sync_Fetch_And_And
296
        (Ptr   : Address;
297
         Value : Integer) return Integer;
298
      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
299
 
300
   begin
301
      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
302
      Success_Flag := True;
303
   end And_Atomic;
304
 
305
   procedure And_Atomic
306
     (To   : in out Aligned_Long_Integer;
307
      From : Long_Integer)
308
   is
309
      procedure Sync_And_And_Fetch
310
        (Ptr   : Address;
311
         Value : Long_Integer);
312
      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
313
   begin
314
      Sync_And_And_Fetch (To.Value'Address, From);
315
   end And_Atomic;
316
 
317
   procedure And_Atomic
318
     (To           : in out Aligned_Long_Integer;
319
      From         : Long_Integer;
320
      Retry_Count  : Natural;
321
      Old_Value    : out Long_Integer;
322
      Success_Flag : out Boolean)
323
   is
324
      pragma Unreferenced (Retry_Count);
325
 
326
      function Sync_Fetch_And_And
327
        (Ptr   : Address;
328
         Value : Long_Integer) return Long_Integer;
329
      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
330
 
331
   begin
332
      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
333
      Success_Flag := True;
334
   end And_Atomic;
335
 
336
   ---------------
337
   -- Or_Atomic --
338
   ---------------
339
 
340
   procedure Or_Atomic
341
     (To   : in out Aligned_Integer;
342
      From : Integer)
343
   is
344
      procedure Sync_Or_And_Fetch
345
        (Ptr   : Address;
346
         Value : Integer);
347
      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
348
 
349
   begin
350
      Sync_Or_And_Fetch (To.Value'Address, From);
351
   end Or_Atomic;
352
 
353
   procedure Or_Atomic
354
     (To           : in out Aligned_Integer;
355
      From         : Integer;
356
      Retry_Count  : Natural;
357
      Old_Value    : out Integer;
358
      Success_Flag : out Boolean)
359
   is
360
      pragma Unreferenced (Retry_Count);
361
 
362
      function Sync_Fetch_And_Or
363
        (Ptr   : Address;
364
         Value : Integer) return Integer;
365
      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
366
 
367
   begin
368
      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
369
      Success_Flag := True;
370
   end Or_Atomic;
371
 
372
   procedure Or_Atomic
373
     (To   : in out Aligned_Long_Integer;
374
      From : Long_Integer)
375
   is
376
      procedure Sync_Or_And_Fetch
377
        (Ptr   : Address;
378
         Value : Long_Integer);
379
      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
380
   begin
381
      Sync_Or_And_Fetch (To.Value'Address, From);
382
   end Or_Atomic;
383
 
384
   procedure Or_Atomic
385
     (To           : in out Aligned_Long_Integer;
386
      From         : Long_Integer;
387
      Retry_Count  : Natural;
388
      Old_Value    : out Long_Integer;
389
      Success_Flag : out Boolean)
390
   is
391
      pragma Unreferenced (Retry_Count);
392
 
393
      function Sync_Fetch_And_Or
394
        (Ptr   : Address;
395
         Value : Long_Integer) return Long_Integer;
396
      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
397
 
398
   begin
399
      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
400
      Success_Flag := True;
401
   end Or_Atomic;
402
 
403
   ------------
404
   -- Insqhi --
405
   ------------
406
 
407
   procedure Insqhi
408
     (Item   : Address;
409
      Header : Address;
410
      Status : out Insq_Status) is
411
 
412
      procedure SYS_PAL_INSQHIL
413
        (STATUS : out Integer; Header : Address; ITEM : Address);
414
      pragma Interface (External, SYS_PAL_INSQHIL);
415
      pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
416
         (Integer, Address, Address),
417
         (Value, Value, Value));
418
 
419
      Istat : Integer;
420
 
421
   begin
422
      SYS_PAL_INSQHIL (Istat, Header, Item);
423
 
424
      if Istat = 0 then
425
         Status := OK_Not_First;
426
      elsif Istat = 1 then
427
         Status := OK_First;
428
 
429
      else
430
         --  This status is never returned on IVMS
431
 
432
         Status := Fail_No_Lock;
433
      end if;
434
   end Insqhi;
435
 
436
   ------------
437
   -- Remqhi --
438
   ------------
439
 
440
   procedure Remqhi
441
     (Header : Address;
442
      Item   : out Address;
443
      Status : out Remq_Status)
444
   is
445
      --  The removed item is returned in the second function return register,
446
      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
447
      --  these registers, so inventing this odd looking record type makes that
448
      --  all work.
449
 
450
      type Remq is record
451
         Status : Long_Integer;
452
         Item   : Address;
453
      end record;
454
 
455
      procedure SYS_PAL_REMQHIL
456
        (Remret : out Remq; Header : Address);
457
      pragma Interface (External, SYS_PAL_REMQHIL);
458
      pragma Import_Valued_Procedure
459
        (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
460
         (Remq, Address),
461
         (Value, Value));
462
 
463
      --  Following variables need documentation???
464
 
465
      Rstat  : Long_Integer;
466
      Remret : Remq;
467
 
468
   begin
469
      SYS_PAL_REMQHIL (Remret, Header);
470
 
471
      Rstat := Remret.Status;
472
      Item := Remret.Item;
473
 
474
      if Rstat = 0 then
475
         Status := Fail_Was_Empty;
476
 
477
      elsif Rstat = 1 then
478
         Status := OK_Not_Empty;
479
 
480
      elsif Rstat = 2 then
481
         Status := OK_Empty;
482
 
483
      else
484
         --  This status is never returned on IVMS
485
 
486
         Status := Fail_No_Lock;
487
      end if;
488
 
489
   end Remqhi;
490
 
491
   ------------
492
   -- Insqti --
493
   ------------
494
 
495
   procedure Insqti
496
     (Item   : Address;
497
      Header : Address;
498
      Status : out Insq_Status) is
499
 
500
      procedure SYS_PAL_INSQTIL
501
        (STATUS : out Integer; Header : Address; ITEM : Address);
502
      pragma Interface (External, SYS_PAL_INSQTIL);
503
      pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
504
         (Integer, Address, Address),
505
         (Value, Value, Value));
506
 
507
      Istat : Integer;
508
 
509
   begin
510
      SYS_PAL_INSQTIL (Istat, Header, Item);
511
 
512
      if Istat = 0 then
513
         Status := OK_Not_First;
514
 
515
      elsif Istat = 1 then
516
         Status := OK_First;
517
 
518
      else
519
         --  This status is never returned on IVMS
520
 
521
         Status := Fail_No_Lock;
522
      end if;
523
   end Insqti;
524
 
525
   ------------
526
   -- Remqti --
527
   ------------
528
 
529
   procedure Remqti
530
     (Header : Address;
531
      Item   : out Address;
532
      Status : out Remq_Status)
533
   is
534
      --  The removed item is returned in the second function return register,
535
      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
536
      --  these registers, so inventing (where is rest of this comment???)
537
 
538
      type Remq is record
539
         Status : Long_Integer;
540
         Item   : Address;
541
      end record;
542
 
543
      procedure SYS_PAL_REMQTIL
544
        (Remret : out Remq; Header : Address);
545
      pragma Interface (External, SYS_PAL_REMQTIL);
546
      pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
547
         (Remq, Address),
548
         (Value, Value));
549
 
550
      Rstat  : Long_Integer;
551
      Remret : Remq;
552
 
553
   begin
554
      SYS_PAL_REMQTIL (Remret, Header);
555
 
556
      Rstat := Remret.Status;
557
      Item := Remret.Item;
558
 
559
      --  Wouldn't case be nicer here, and in previous similar cases ???
560
 
561
      if Rstat = 0 then
562
         Status := Fail_Was_Empty;
563
 
564
      elsif Rstat = 1 then
565
         Status := OK_Not_Empty;
566
 
567
      elsif Rstat = 2 then
568
         Status := OK_Empty;
569
      else
570
         --  This status is never returned on IVMS
571
 
572
         Status := Fail_No_Lock;
573
      end if;
574
   end Remqti;
575
 
576
end System.Aux_DEC;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.