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