1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
5--                   S Y S T E M . O S _ I N T E R F A C E                  --
6--                                                                          --
7--                                  S p e c                                 --
8--                                                                          --
9--             Copyright (C) 1991-2017, Florida State University            --
10--          Copyright (C) 1995-2020, Free Software Foundation, Inc.         --
11--                                                                          --
12-- GNAT is free software;  you can  redistribute it  and/or modify it under --
13-- terms of the  GNU General Public License as published  by the Free Soft- --
14-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
15-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
16-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
17-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
18--                                                                          --
19-- As a special exception under Section 7 of GPL version 3, you are granted --
20-- additional permissions described in the GCC Runtime Library Exception,   --
21-- version 3.1, as published by the Free Software Foundation.               --
22--                                                                          --
23-- You should have received a copy of the GNU General Public License and    --
24-- a copy of the GCC Runtime Library Exception along with this program;     --
25-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
26-- <http://www.gnu.org/licenses/>.                                          --
27--                                                                          --
28-- GNARL was developed by the GNARL team at Florida State University.       --
29-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
30--                                                                          --
31------------------------------------------------------------------------------
32
33--  This is a Solaris (native) version of this package
34
35--  This package includes all direct interfaces to OS services
36--  that are needed by the tasking run-time (libgnarl).
37
38--  PLEASE DO NOT add any with-clauses to this package or remove the pragma
39--  Preelaborate. This package is designed to be a bottom-level (leaf) package.
40
41with Interfaces.C;
42
43with Ada.Unchecked_Conversion;
44
45package System.OS_Interface is
46   pragma Preelaborate;
47
48   subtype int            is Interfaces.C.int;
49   subtype short          is Interfaces.C.short;
50   subtype long           is Interfaces.C.long;
51   subtype unsigned       is Interfaces.C.unsigned;
52   subtype unsigned_short is Interfaces.C.unsigned_short;
53   subtype unsigned_long  is Interfaces.C.unsigned_long;
54   subtype unsigned_char  is Interfaces.C.unsigned_char;
55   subtype plain_char     is Interfaces.C.plain_char;
56   subtype size_t         is Interfaces.C.size_t;
57
58   -----------
59   -- Errno --
60   -----------
61
62   function errno return int;
63   pragma Import (C, errno, "__get_errno");
64
65   EAGAIN    : constant := 11;
66   EINTR     : constant := 4;
67   EINVAL    : constant := 22;
68   ENOMEM    : constant := 12;
69   ETIME     : constant := 62;
70   ETIMEDOUT : constant := 145;
71
72   -------------
73   -- Signals --
74   -------------
75
76   Max_Interrupt : constant := 45;
77   type Signal is new int range 0 .. Max_Interrupt;
78   for Signal'Size use int'Size;
79
80   SIGHUP     : constant := 1; --  hangup
81   SIGINT     : constant := 2; --  interrupt (rubout)
82   SIGQUIT    : constant := 3; --  quit (ASCD FS)
83   SIGILL     : constant := 4; --  illegal instruction (not reset)
84   SIGTRAP    : constant := 5; --  trace trap (not reset)
85   SIGIOT     : constant := 6; --  IOT instruction
86   SIGABRT    : constant := 6; --  used by abort, replace SIGIOT in the  future
87   SIGEMT     : constant := 7; --  EMT instruction
88   SIGFPE     : constant := 8; --  floating point exception
89   SIGKILL    : constant := 9; --  kill (cannot be caught or ignored)
90   SIGBUS     : constant := 10; --  bus error
91   SIGSEGV    : constant := 11; --  segmentation violation
92   SIGSYS     : constant := 12; --  bad argument to system call
93   SIGPIPE    : constant := 13; --  write on a pipe with no one to read it
94   SIGALRM    : constant := 14; --  alarm clock
95   SIGTERM    : constant := 15; --  software termination signal from kill
96   SIGUSR1    : constant := 16; --  user defined signal 1
97   SIGUSR2    : constant := 17; --  user defined signal 2
98   SIGCLD     : constant := 18; --  alias for SIGCHLD
99   SIGCHLD    : constant := 18; --  child status change
100   SIGPWR     : constant := 19; --  power-fail restart
101   SIGWINCH   : constant := 20; --  window size change
102   SIGURG     : constant := 21; --  urgent condition on IO channel
103   SIGPOLL    : constant := 22; --  pollable event occurred
104   SIGIO      : constant := 22; --  I/O possible (Solaris SIGPOLL alias)
105   SIGSTOP    : constant := 23; --  stop (cannot be caught or ignored)
106   SIGTSTP    : constant := 24; --  user stop requested from tty
107   SIGCONT    : constant := 25; --  stopped process has been continued
108   SIGTTIN    : constant := 26; --  background tty read attempted
109   SIGTTOU    : constant := 27; --  background tty write attempted
110   SIGVTALRM  : constant := 28; --  virtual timer expired
111   SIGPROF    : constant := 29; --  profiling timer expired
112   SIGXCPU    : constant := 30; --  CPU time limit exceeded
113   SIGXFSZ    : constant := 31; --  filesize limit exceeded
114   SIGWAITING : constant := 32; --  process's lwps blocked (Solaris)
115   SIGLWP     : constant := 33; --  used by thread library (Solaris)
116   SIGFREEZE  : constant := 34; --  used by CPR (Solaris)
117   SIGTHAW    : constant := 35; --  used by CPR (Solaris)
118   SIGCANCEL  : constant := 36; --  thread cancellation signal (libthread)
119
120   type Signal_Set is array (Natural range <>) of Signal;
121
122   Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
123
124   --  Following signals should not be disturbed.
125   --  See c-posix-signals.c in FLORIST.
126
127   Reserved : constant Signal_Set :=
128     (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV);
129
130   type sigset_t is private;
131
132   function sigaddset (set : access sigset_t; sig : Signal) return int;
133   pragma Import (C, sigaddset, "sigaddset");
134
135   function sigdelset (set : access sigset_t; sig : Signal) return int;
136   pragma Import (C, sigdelset, "sigdelset");
137
138   function sigfillset (set : access sigset_t) return int;
139   pragma Import (C, sigfillset, "sigfillset");
140
141   function sigismember (set : access sigset_t; sig : Signal) return int;
142   pragma Import (C, sigismember, "sigismember");
143
144   function sigemptyset (set : access sigset_t) return int;
145   pragma Import (C, sigemptyset, "sigemptyset");
146
147   type union_type_3 is new String (1 .. 116);
148   type siginfo_t is record
149      si_signo     : int;
150      si_code      : int;
151      si_errno     : int;
152      X_data       : union_type_3;
153   end record;
154   pragma Convention (C, siginfo_t);
155
156   --  The types mcontext_t and gregset_t are part of the ucontext_t
157   --  information, which is specific to Solaris2.4 for SPARC
158   --  The ucontext_t info seems to be used by the handler
159   --  for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or
160   --  a Constraint_Error (bad pointer).  The original code that did this
161   --  is suspect, so it is not clear whether we really need this part of
162   --  the signal context information, or perhaps something else.
163   --  More analysis is needed, after which these declarations may need to
164   --  be changed.
165
166   type greg_t is new int;
167
168   type gregset_t is array (0 .. 18) of greg_t;
169
170   type union_type_2 is new String (1 .. 128);
171   type record_type_1 is record
172      fpu_fr       : union_type_2;
173      fpu_q        : System.Address;
174      fpu_fsr      : unsigned;
175      fpu_qcnt     : unsigned_char;
176      fpu_q_entrysize  : unsigned_char;
177      fpu_en       : unsigned_char;
178   end record;
179   pragma Convention (C, record_type_1);
180
181   type array_type_7 is array (Integer range 0 .. 20) of long;
182   type mcontext_t is record
183      gregs        : gregset_t;
184      gwins        : System.Address;
185      fpregs       : record_type_1;
186      filler       : array_type_7;
187   end record;
188   pragma Convention (C, mcontext_t);
189
190   type record_type_2 is record
191      ss_sp        : System.Address;
192      ss_size      : int;
193      ss_flags     : int;
194   end record;
195   pragma Convention (C, record_type_2);
196
197   type array_type_8 is array (Integer range 0 .. 22) of long;
198   type ucontext_t is record
199      uc_flags     : unsigned_long;
200      uc_link      : System.Address;
201      uc_sigmask   : sigset_t;
202      uc_stack     : record_type_2;
203      uc_mcontext  : mcontext_t;
204      uc_filler    : array_type_8;
205   end record;
206   pragma Convention (C, ucontext_t);
207
208   type Signal_Handler is access procedure
209     (signo   : Signal;
210      info    : access siginfo_t;
211      context : access ucontext_t);
212
213   type union_type_1 is new plain_char;
214   type array_type_2 is array (Integer range 0 .. 1) of int;
215   type struct_sigaction is record
216      sa_flags   : int;
217      sa_handler : System.Address;
218      sa_mask    : sigset_t;
219      sa_resv    : array_type_2;
220   end record;
221   pragma Convention (C, struct_sigaction);
222   type struct_sigaction_ptr is access all struct_sigaction;
223
224   SIG_BLOCK   : constant := 1;
225   SIG_UNBLOCK : constant := 2;
226   SIG_SETMASK : constant := 3;
227
228   SIG_DFL : constant := 0;
229   SIG_IGN : constant := 1;
230
231   function sigaction
232     (sig  : Signal;
233      act  : struct_sigaction_ptr;
234      oact : struct_sigaction_ptr) return int;
235   pragma Import (C, sigaction, "sigaction");
236
237   ----------
238   -- Time --
239   ----------
240
241   type timespec is private;
242
243   type clockid_t is new int;
244
245   function clock_gettime
246     (clock_id : clockid_t; tp : access timespec) return int;
247   pragma Import (C, clock_gettime, "clock_gettime");
248
249   function clock_getres
250     (clock_id : clockid_t; res : access timespec) return int;
251   pragma Import (C, clock_getres, "clock_getres");
252
253   function To_Duration (TS : timespec) return Duration;
254   pragma Inline (To_Duration);
255
256   function To_Timespec (D : Duration) return timespec;
257   pragma Inline (To_Timespec);
258
259   function sysconf (name : int) return long;
260   pragma Import (C, sysconf);
261
262   SC_NPROCESSORS_ONLN : constant := 15;
263
264   -------------
265   -- Process --
266   -------------
267
268   type pid_t is private;
269
270   function kill (pid : pid_t; sig : Signal) return int;
271   pragma Import (C, kill, "kill");
272
273   function getpid return pid_t;
274   pragma Import (C, getpid, "getpid");
275
276   -------------
277   -- Threads --
278   -------------
279
280   type Thread_Body is access
281     function (arg : System.Address) return System.Address;
282   pragma Convention (C, Thread_Body);
283
284   function Thread_Body_Access is new
285     Ada.Unchecked_Conversion (System.Address, Thread_Body);
286
287   THR_DETACHED  : constant := 64;
288   THR_BOUND     : constant := 1;
289   THR_NEW_LWP   : constant := 2;
290   USYNC_THREAD  : constant := 0;
291
292   type thread_t is new unsigned;
293   subtype Thread_Id is thread_t;
294   --  These types should be commented ???
295
296   function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t);
297
298   type mutex_t is limited private;
299
300   type cond_t is limited private;
301
302   type thread_key_t is private;
303
304   function thr_create
305     (stack_base    : System.Address;
306      stack_size    : size_t;
307      start_routine : Thread_Body;
308      arg           : System.Address;
309      flags         : int;
310      new_thread    : access thread_t) return int;
311   pragma Import (C, thr_create, "thr_create");
312
313   function thr_min_stack return size_t;
314   pragma Import (C, thr_min_stack, "thr_min_stack");
315
316   function thr_self return thread_t;
317   pragma Import (C, thr_self, "thr_self");
318
319   function mutex_init
320     (mutex : access mutex_t;
321      mtype : int;
322      arg   : System.Address) return int;
323   pragma Import (C, mutex_init, "mutex_init");
324
325   function mutex_destroy (mutex : access mutex_t) return int;
326   pragma Import (C, mutex_destroy, "mutex_destroy");
327
328   function mutex_lock (mutex : access mutex_t) return int;
329   pragma Import (C, mutex_lock, "mutex_lock");
330
331   function mutex_unlock (mutex : access mutex_t) return int;
332   pragma Import (C, mutex_unlock, "mutex_unlock");
333
334   function cond_init
335     (cond  : access cond_t;
336      ctype : int;
337      arg   : int) return int;
338   pragma Import (C, cond_init, "cond_init");
339
340   function cond_wait
341     (cond : access cond_t; mutex : access mutex_t) return int;
342   pragma Import (C, cond_wait, "cond_wait");
343
344   function cond_timedwait
345     (cond    : access cond_t;
346      mutex   : access mutex_t;
347      abstime : access timespec) return int;
348   pragma Import (C, cond_timedwait, "cond_timedwait");
349
350   function cond_signal (cond : access cond_t) return int;
351   pragma Import (C, cond_signal, "cond_signal");
352
353   function cond_destroy (cond : access cond_t) return int;
354   pragma Import (C, cond_destroy, "cond_destroy");
355
356   function thr_setspecific
357     (key : thread_key_t; value : System.Address) return int;
358   pragma Import (C, thr_setspecific, "thr_setspecific");
359
360   function thr_getspecific
361     (key   : thread_key_t;
362      value : access System.Address) return int;
363   pragma Import (C, thr_getspecific, "thr_getspecific");
364
365   function thr_keycreate
366     (key : access thread_key_t; destructor : System.Address) return int;
367   pragma Import (C, thr_keycreate, "thr_keycreate");
368
369   function thr_setprio (thread : thread_t; priority : int) return int;
370   pragma Import (C, thr_setprio, "thr_setprio");
371
372   procedure thr_exit (status : System.Address);
373   pragma Import (C, thr_exit, "thr_exit");
374
375   function thr_setconcurrency (new_level : int) return int;
376   pragma Import (C, thr_setconcurrency, "thr_setconcurrency");
377
378   function sigwait (set : access sigset_t; sig : access Signal) return int;
379   pragma Import (C, sigwait, "__posix_sigwait");
380
381   function thr_kill (thread : thread_t; sig : Signal) return int;
382   pragma Import (C, thr_kill, "thr_kill");
383
384   function thr_sigsetmask
385     (how  : int;
386      set  : access sigset_t;
387      oset : access sigset_t) return int;
388   pragma Import (C, thr_sigsetmask, "thr_sigsetmask");
389
390   function pthread_sigmask
391     (how  : int;
392      set  : access sigset_t;
393      oset : access sigset_t) return int;
394   pragma Import (C, pthread_sigmask, "thr_sigsetmask");
395
396   function thr_suspend (target_thread : thread_t) return int;
397   pragma Import (C, thr_suspend, "thr_suspend");
398
399   function thr_continue (target_thread : thread_t) return int;
400   pragma Import (C, thr_continue, "thr_continue");
401
402   procedure thr_yield;
403   pragma Import (C, thr_yield, "thr_yield");
404
405   ---------
406   -- LWP --
407   ---------
408
409   P_PID   : constant := 0;
410   P_LWPID : constant := 8;
411
412   PC_GETCID    : constant := 0;
413   PC_GETCLINFO : constant := 1;
414   PC_SETPARMS  : constant := 2;
415   PC_GETPARMS  : constant := 3;
416   PC_ADMIN     : constant := 4;
417
418   PC_CLNULL : constant := -1;
419
420   RT_NOCHANGE : constant := -1;
421   RT_TQINF    : constant := -2;
422   RT_TQDEF    : constant := -3;
423
424   PC_CLNMSZ : constant := 16;
425
426   PC_VERSION : constant := 1;
427
428   type lwpid_t is new int;
429
430   type pri_t is new short;
431
432   type id_t is new long;
433
434   P_MYID : constant := -1;
435   --  The specified LWP or process is the current one
436
437   type struct_pcinfo is record
438      pc_cid    : id_t;
439      pc_clname : String (1 .. PC_CLNMSZ);
440      rt_maxpri : short;
441   end record;
442   pragma Convention (C, struct_pcinfo);
443
444   type struct_pcparms is record
445      pc_cid     : id_t;
446      rt_pri     : pri_t;
447      rt_tqsecs  : long;
448      rt_tqnsecs : long;
449   end record;
450   pragma Convention (C, struct_pcparms);
451
452   function priocntl
453     (ver     : int;
454      id_type : int;
455      id      : lwpid_t;
456      cmd     : int;
457      arg     : System.Address) return Interfaces.C.long;
458   pragma Import (C, priocntl, "__priocntl");
459
460   function lwp_self return lwpid_t;
461   pragma Import (C, lwp_self, "_lwp_self");
462
463   type processorid_t is new int;
464   type processorid_t_ptr is access all processorid_t;
465
466   --  Constants for function processor_bind
467
468   PBIND_QUERY : constant processorid_t := -2;
469   --  The processor bindings are not changed
470
471   PBIND_NONE  : constant processorid_t := -1;
472   --  The processor bindings of the specified LWPs are cleared
473
474   --  Flags for function p_online
475
476   PR_OFFLINE : constant int := 1;
477   --  Processor is offline, as quiet as possible
478
479   PR_ONLINE  : constant int := 2;
480   --  Processor online
481
482   PR_STATUS  : constant int := 3;
483   --  Value passed to p_online to request status
484
485   function p_online (processorid : processorid_t; flag : int) return int;
486   pragma Import (C, p_online, "p_online");
487
488   function processor_bind
489     (id_type : int;
490      id      : id_t;
491      proc_id : processorid_t;
492      obind   : processorid_t_ptr) return int;
493   pragma Import (C, processor_bind, "processor_bind");
494
495   type psetid_t is new int;
496
497   function pset_create (pset : access psetid_t) return int;
498   pragma Import (C, pset_create, "pset_create");
499
500   function pset_assign
501     (pset    : psetid_t;
502      proc_id : processorid_t;
503      opset   : access psetid_t) return int;
504   pragma Import (C, pset_assign, "pset_assign");
505
506   function pset_bind
507     (pset    : psetid_t;
508      id_type : int;
509      id      : id_t;
510      opset   : access psetid_t) return int;
511   pragma Import (C, pset_bind, "pset_bind");
512
513   procedure pthread_init;
514   --  Dummy procedure to share s-intman.adb with other Solaris targets
515
516private
517
518   type array_type_1 is array (0 .. 3) of unsigned_long;
519   type sigset_t is record
520      X_X_sigbits : array_type_1;
521   end record;
522   pragma Convention (C, sigset_t);
523
524   type pid_t is new long;
525
526   type time_t is new long;
527
528   type timespec is record
529      tv_sec  : time_t;
530      tv_nsec : long;
531   end record;
532   pragma Convention (C, timespec);
533
534   type array_type_9 is array (0 .. 3) of unsigned_char;
535   type record_type_3 is record
536      flag  : array_type_9;
537      Xtype : unsigned_long;
538   end record;
539   pragma Convention (C, record_type_3);
540
541   type upad64_t is new Interfaces.Unsigned_64;
542
543   type mutex_t is record
544      flags : record_type_3;
545      lock  : upad64_t;
546      data  : upad64_t;
547   end record;
548   pragma Convention (C, mutex_t);
549
550   type cond_t is record
551      flags : record_type_3;
552      data  : upad64_t;
553   end record;
554   pragma Convention (C, cond_t);
555
556   type thread_key_t is new unsigned;
557
558end System.OS_Interface;
559