[thirdparty/gcc.git] / gcc / ada / s-osinte-tru64.adb

------------------------------------------------------------------------------
--                                                                          --
--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
--                                                                          --
--                   S Y S T E M . O S _ I N T E R F A C E                  --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--         Copyright (C) 1998-2009, Free Software Foundation, Inc.          --
--                                                                          --
-- GNARL is free software; you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
------------------------------------------------------------------------------

--  This is the DEC Unix version of this package

--  This package encapsulates all direct interfaces to OS services
--  that are needed by children of System.

pragma Polling (Off);
--  Turn off polling, we do not want ATC polling to take place during
--  tasking operations. It causes infinite loops and other problems.

with Interfaces.C; use Interfaces.C;
with System.Machine_Code; use System.Machine_Code;

package body System.OS_Interface is

   --------------------
   -- Get_Stack_Base --
   --------------------

   function Get_Stack_Base (thread : pthread_t) return Address is
      pragma Unreferenced (thread);
   begin
      return Null_Address;
   end Get_Stack_Base;

   ------------------
   -- pthread_init --
   ------------------

   procedure pthread_init is
   begin
      null;
   end pthread_init;

   ------------------
   -- pthread_self --
   ------------------

   function pthread_self return pthread_t is
      Self : pthread_t;
   begin
      Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT &
           "bis $31, $0, %0",
           Outputs  => pthread_t'Asm_Output ("=r", Self),
           Clobber  => "$0",
           Volatile => True);
      return Self;
   end pthread_self;

   ----------------------
   -- Hide_Yellow_Zone --
   ----------------------

   procedure Hide_Unhide_Yellow_Zone (Hide : Boolean) is
      type Teb_Ptr is access all pthread_teb_t;
      Teb : Teb_Ptr;
      Res : Interfaces.C.int;
      pragma Unreferenced (Res);

   begin
      --  Get the Thread Environment Block address

      Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT &
           "bis $31, $0, %0",
           Outputs  => Teb_Ptr'Asm_Output ("=r", Teb),
           Clobber  => "$0",
           Volatile => True);

      --  Stick a guard page right above the Yellow Zone if it exists

      if Teb.all.stack_yellow /= Teb.all.stack_guard then
         Res :=
           mprotect
             (Teb.all.stack_yellow, Get_Page_Size,
              prot => (if Hide then PROT_ON else PROT_OFF));
      end if;
   end Hide_Unhide_Yellow_Zone;

   -----------------
   -- To_Duration --
   -----------------

   function To_Duration (TS : timespec) return Duration is
   begin
      return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
   end To_Duration;

   -----------------
   -- To_Timespec --
   -----------------

   function To_Timespec (D : Duration) return timespec is
      S : time_t;
      F : Duration;

   begin
      S := time_t (Long_Long_Integer (D));
      F := D - Duration (S);

      --  If F has negative value due to a round-up, adjust for positive F
      --  value.

      if F < 0.0 then
         S := S - 1;
         F := F + 1.0;
      end if;

      return timespec'(tv_sec => S,
                       tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
   end To_Timespec;

end System.OS_Interface;
Commit	Line	Data
84481f76 RK	1	------------------------------------------------------------------------------
84481f76 RK	2	-- --
3084fecd	3	-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
84481f76 RK	4	-- --
	5	-- S Y S T E M . O S _ I N T E R F A C E --
	6	-- --
	7	-- B o d y --
	8	-- --
748086b7	9	-- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
84481f76 RK	10	-- --
	11	-- GNARL 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- --
748086b7 JJ	13	-- ware Foundation; either version 3, or (at your option) any later ver- --
748086b7 JJ	14	-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
84481f76	15	-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
748086b7 JJ	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/>. --
84481f76	26	-- --
bcea76b6	27	-- GNARL was developed by the GNARL team at Florida State University. --
fbf5a39b	28	-- Extensive contributions were provided by Ada Core Technologies, Inc. --
84481f76 RK	29	-- --
	30	------------------------------------------------------------------------------
	31
09c239f6	32	-- This is the DEC Unix version of this package
84481f76 RK	33
	34	-- This package encapsulates all direct interfaces to OS services
	35	-- that are needed by children of System.
	36
	37	pragma Polling (Off);
	38	-- Turn off polling, we do not want ATC polling to take place during
	39	-- tasking operations. It causes infinite loops and other problems.
	40
	41	with Interfaces.C; use Interfaces.C;
bcea76b6 GB	42	with System.Machine_Code; use System.Machine_Code;
bcea76b6 GB	43
84481f76 RK	44	package body System.OS_Interface is
84481f76 RK	45
09c239f6 EB	46	--------------------
	47	-- Get_Stack_Base --
	48	--------------------
	49
	50	function Get_Stack_Base (thread : pthread_t) return Address is
	51	pragma Unreferenced (thread);
	52	begin
	53	return Null_Address;
	54	end Get_Stack_Base;
	55
84481f76 RK	56	------------------
	57	-- pthread_init --
	58	------------------
	59
	60	procedure pthread_init is
	61	begin
	62	null;
	63	end pthread_init;
	64
bcea76b6 GB	65	------------------
	66	-- pthread_self --
	67	------------------
	68
	69	function pthread_self return pthread_t is
	70	Self : pthread_t;
	71	begin
	72	Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT &
	73	"bis $31, $0, %0",
e0ae4e94 RD	74	Outputs => pthread_t'Asm_Output ("=r", Self),
	75	Clobber => "$0",
	76	Volatile => True);
bcea76b6 GB	77	return Self;
	78	end pthread_self;
	79
09c239f6 EB	80	----------------------
	81	-- Hide_Yellow_Zone --
	82	----------------------
	83
f3bc3723	84	procedure Hide_Unhide_Yellow_Zone (Hide : Boolean) is
09c239f6 EB	85	type Teb_Ptr is access all pthread_teb_t;
	86	Teb : Teb_Ptr;
	87	Res : Interfaces.C.int;
	88	pragma Unreferenced (Res);
	89
	90	begin
	91	-- Get the Thread Environment Block address
	92
	93	Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT &
	94	"bis $31, $0, %0",
e0ae4e94 RD	95	Outputs => Teb_Ptr'Asm_Output ("=r", Teb),
	96	Clobber => "$0",
	97	Volatile => True);
09c239f6 EB	98
	99	-- Stick a guard page right above the Yellow Zone if it exists
	100
	101	if Teb.all.stack_yellow /= Teb.all.stack_guard then
196b1993 AC	102	Res :=
	103	mprotect
	104	(Teb.all.stack_yellow, Get_Page_Size,
b3afa59b	105	prot => (if Hide then PROT_ON else PROT_OFF));
09c239f6	106	end if;
f3bc3723	107	end Hide_Unhide_Yellow_Zone;
09c239f6	108
84481f76 RK	109	-----------------
	110	-- To_Duration --
	111	-----------------
	112
	113	function To_Duration (TS : timespec) return Duration is
	114	begin
	115	return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
	116	end To_Duration;
	117
84481f76 RK	118	-----------------
	119	-- To_Timespec --
	120	-----------------
	121
	122	function To_Timespec (D : Duration) return timespec is
	123	S : time_t;
	124	F : Duration;
	125
	126	begin
	127	S := time_t (Long_Long_Integer (D));
	128	F := D - Duration (S);
	129
	130	-- If F has negative value due to a round-up, adjust for positive F
	131	-- value.
	132
	133	if F < 0.0 then
	134	S := S - 1;
	135	F := F + 1.0;
	136	end if;
	137
bcea76b6 GB	138	return timespec'(tv_sec => S,
bcea76b6 GB	139	tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
84481f76 RK	140	end To_Timespec;
84481f76 RK	141
84481f76	142	end System.OS_Interface;