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-2019, 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   function sysconf (name : int) return long;
263   pragma Import (C, sysconf);
264
265   SC_NPROCESSORS_ONLN : constant := 15;
266
267   -------------
268   -- Process --
269   -------------
270
271   type pid_t is private;
272
273   function kill (pid : pid_t; sig : Signal) return int;
274   pragma Import (C, kill, "kill");
275
276   function getpid return pid_t;
277   pragma Import (C, getpid, "getpid");
278
279   -------------
280   -- Threads --
281   -------------
282
283   type Thread_Body is access
284     function (arg : System.Address) return System.Address;
285   pragma Convention (C, Thread_Body);
286
287   function Thread_Body_Access is new
288     Ada.Unchecked_Conversion (System.Address, Thread_Body);
289
290   THR_DETACHED  : constant := 64;
291   THR_BOUND     : constant := 1;
292   THR_NEW_LWP   : constant := 2;
293   USYNC_THREAD  : constant := 0;
294
295   type thread_t is new unsigned;
296   subtype Thread_Id is thread_t;
297   --  These types should be commented ???
298
299   function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t);
300
301   type mutex_t is limited private;
302
303   type cond_t is limited private;
304
305   type thread_key_t is private;
306
307   function thr_create
308     (stack_base    : System.Address;
309      stack_size    : size_t;
310      start_routine : Thread_Body;
311      arg           : System.Address;
312      flags         : int;
313      new_thread    : access thread_t) return int;
314   pragma Import (C, thr_create, "thr_create");
315
316   function thr_min_stack return size_t;
317   pragma Import (C, thr_min_stack, "thr_min_stack");
318
319   function thr_self return thread_t;
320   pragma Import (C, thr_self, "thr_self");
321
322   function mutex_init
323     (mutex : access mutex_t;
324      mtype : int;
325      arg   : System.Address) return int;
326   pragma Import (C, mutex_init, "mutex_init");
327
328   function mutex_destroy (mutex : access mutex_t) return int;
329   pragma Import (C, mutex_destroy, "mutex_destroy");
330
331   function mutex_lock (mutex : access mutex_t) return int;
332   pragma Import (C, mutex_lock, "mutex_lock");
333
334   function mutex_unlock (mutex : access mutex_t) return int;
335   pragma Import (C, mutex_unlock, "mutex_unlock");
336
337   function cond_init
338     (cond  : access cond_t;
339      ctype : int;
340      arg   : int) return int;
341   pragma Import (C, cond_init, "cond_init");
342
343   function cond_wait
344     (cond : access cond_t; mutex : access mutex_t) return int;
345   pragma Import (C, cond_wait, "cond_wait");
346
347   function cond_timedwait
348     (cond    : access cond_t;
349      mutex   : access mutex_t;
350      abstime : access timespec) return int;
351   pragma Import (C, cond_timedwait, "cond_timedwait");
352
353   function cond_signal (cond : access cond_t) return int;
354   pragma Import (C, cond_signal, "cond_signal");
355
356   function cond_destroy (cond : access cond_t) return int;
357   pragma Import (C, cond_destroy, "cond_destroy");
358
359   function thr_setspecific
360     (key : thread_key_t; value : System.Address) return int;
361   pragma Import (C, thr_setspecific, "thr_setspecific");
362
363   function thr_getspecific
364     (key   : thread_key_t;
365      value : access System.Address) return int;
366   pragma Import (C, thr_getspecific, "thr_getspecific");
367
368   function thr_keycreate
369     (key : access thread_key_t; destructor : System.Address) return int;
370   pragma Import (C, thr_keycreate, "thr_keycreate");
371
372   function thr_setprio (thread : thread_t; priority : int) return int;
373   pragma Import (C, thr_setprio, "thr_setprio");
374
375   procedure thr_exit (status : System.Address);
376   pragma Import (C, thr_exit, "thr_exit");
377
378   function thr_setconcurrency (new_level : int) return int;
379   pragma Import (C, thr_setconcurrency, "thr_setconcurrency");
380
381   function sigwait (set : access sigset_t; sig : access Signal) return int;
382   pragma Import (C, sigwait, "__posix_sigwait");
383
384   function thr_kill (thread : thread_t; sig : Signal) return int;
385   pragma Import (C, thr_kill, "thr_kill");
386
387   function thr_sigsetmask
388     (how  : int;
389      set  : access sigset_t;
390      oset : access sigset_t) return int;
391   pragma Import (C, thr_sigsetmask, "thr_sigsetmask");
392
393   function pthread_sigmask
394     (how  : int;
395      set  : access sigset_t;
396      oset : access sigset_t) return int;
397   pragma Import (C, pthread_sigmask, "thr_sigsetmask");
398
399   function thr_suspend (target_thread : thread_t) return int;
400   pragma Import (C, thr_suspend, "thr_suspend");
401
402   function thr_continue (target_thread : thread_t) return int;
403   pragma Import (C, thr_continue, "thr_continue");
404
405   procedure thr_yield;
406   pragma Import (C, thr_yield, "thr_yield");
407
408   ---------
409   -- LWP --
410   ---------
411
412   P_PID   : constant := 0;
413   P_LWPID : constant := 8;
414
415   PC_GETCID    : constant := 0;
416   PC_GETCLINFO : constant := 1;
417   PC_SETPARMS  : constant := 2;
418   PC_GETPARMS  : constant := 3;
419   PC_ADMIN     : constant := 4;
420
421   PC_CLNULL : constant := -1;
422
423   RT_NOCHANGE : constant := -1;
424   RT_TQINF    : constant := -2;
425   RT_TQDEF    : constant := -3;
426
427   PC_CLNMSZ : constant := 16;
428
429   PC_VERSION : constant := 1;
430
431   type lwpid_t is new int;
432
433   type pri_t is new short;
434
435   type id_t is new long;
436
437   P_MYID : constant := -1;
438   --  The specified LWP or process is the current one
439
440   type struct_pcinfo is record
441      pc_cid    : id_t;
442      pc_clname : String (1 .. PC_CLNMSZ);
443      rt_maxpri : short;
444   end record;
445   pragma Convention (C, struct_pcinfo);
446
447   type struct_pcparms is record
448      pc_cid     : id_t;
449      rt_pri     : pri_t;
450      rt_tqsecs  : long;
451      rt_tqnsecs : long;
452   end record;
453   pragma Convention (C, struct_pcparms);
454
455   function priocntl
456     (ver     : int;
457      id_type : int;
458      id      : lwpid_t;
459      cmd     : int;
460      arg     : System.Address) return Interfaces.C.long;
461   pragma Import (C, priocntl, "__priocntl");
462
463   function lwp_self return lwpid_t;
464   pragma Import (C, lwp_self, "_lwp_self");
465
466   type processorid_t is new int;
467   type processorid_t_ptr is access all processorid_t;
468
469   --  Constants for function processor_bind
470
471   PBIND_QUERY : constant processorid_t := -2;
472   --  The processor bindings are not changed
473
474   PBIND_NONE  : constant processorid_t := -1;
475   --  The processor bindings of the specified LWPs are cleared
476
477   --  Flags for function p_online
478
479   PR_OFFLINE : constant int := 1;
480   --  Processor is offline, as quiet as possible
481
482   PR_ONLINE  : constant int := 2;
483   --  Processor online
484
485   PR_STATUS  : constant int := 3;
486   --  Value passed to p_online to request status
487
488   function p_online (processorid : processorid_t; flag : int) return int;
489   pragma Import (C, p_online, "p_online");
490
491   function processor_bind
492     (id_type : int;
493      id      : id_t;
494      proc_id : processorid_t;
495      obind   : processorid_t_ptr) return int;
496   pragma Import (C, processor_bind, "processor_bind");
497
498   type psetid_t is new int;
499
500   function pset_create (pset : access psetid_t) return int;
501   pragma Import (C, pset_create, "pset_create");
502
503   function pset_assign
504     (pset    : psetid_t;
505      proc_id : processorid_t;
506      opset   : access psetid_t) return int;
507   pragma Import (C, pset_assign, "pset_assign");
508
509   function pset_bind
510     (pset    : psetid_t;
511      id_type : int;
512      id      : id_t;
513      opset   : access psetid_t) return int;
514   pragma Import (C, pset_bind, "pset_bind");
515
516   procedure pthread_init;
517   --  Dummy procedure to share s-intman.adb with other Solaris targets
518
519private
520
521   type array_type_1 is array (0 .. 3) of unsigned_long;
522   type sigset_t is record
523      X_X_sigbits : array_type_1;
524   end record;
525   pragma Convention (C, sigset_t);
526
527   type pid_t is new long;
528
529   type time_t is new long;
530
531   type timespec is record
532      tv_sec  : time_t;
533      tv_nsec : long;
534   end record;
535   pragma Convention (C, timespec);
536
537   type array_type_9 is array (0 .. 3) of unsigned_char;
538   type record_type_3 is record
539      flag  : array_type_9;
540      Xtype : unsigned_long;
541   end record;
542   pragma Convention (C, record_type_3);
543
544   type upad64_t is new Interfaces.Unsigned_64;
545
546   type mutex_t is record
547      flags : record_type_3;
548      lock  : upad64_t;
549      data  : upad64_t;
550   end record;
551   pragma Convention (C, mutex_t);
552
553   type cond_t is record
554      flags : record_type_3;
555      data  : upad64_t;
556   end record;
557   pragma Convention (C, cond_t);
558
559   type thread_key_t is new unsigned;
560
561end System.OS_Interface;
562