aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/s-tpobop.adb
diff options
context:
space:
mode:
authorGeert Bosch <bosch@gcc.gnu.org>2002-03-08 21:11:04 +0100
committerGeert Bosch <bosch@gcc.gnu.org>2002-03-08 21:11:04 +0100
commit07fc65c47c45af6439208797e1ab26f7daedb666 (patch)
treeb584a79288c93215b05fb451943291ccd039388b /gcc/ada/s-tpobop.adb
parent24965e7a8ac518b99a3bd7ef5b2d8d88f96bf514 (diff)
downloadgcc-07fc65c47c45af6439208797e1ab26f7daedb666.zip
gcc-07fc65c47c45af6439208797e1ab26f7daedb666.tar.gz
gcc-07fc65c47c45af6439208797e1ab26f7daedb666.tar.bz2
41intnam.ads, [...]: Merge in ACT changes.
* 41intnam.ads, 42intnam.ads, 4aintnam.ads, 4cintnam.ads, 4dintnam.ads, 4gintnam.ads, 4hintnam.ads, 4lintnam.ads, 4mintnam.ads, 4pintnam.ads, 4rintnam.ads, 4sintnam.ads, 4uintnam.ads, 4vcalend.adb, 4zintnam.ads, 52system.ads, 5amastop.adb, 5asystem.ads, 5ataprop.adb, 5atpopsp.adb, 5avxwork.ads, 5bosinte.adb, 5bsystem.ads, 5esystem.ads, 5fsystem.ads, 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, 5gsystem.ads, 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5hparame.ads, 5hsystem.ads, 5htaprop.adb, 5htraceb.adb, 5itaprop.adb, 5ksystem.ads, 5kvxwork.ads, 5lintman.adb, 5lsystem.ads, 5mvxwork.ads, 5ninmaop.adb, 5nosinte.ads, 5ntaprop.adb, 5ointerr.adb, 5omastop.adb, 5oosinte.adb, 5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5pvxwork.ads, 5qtaprop.adb, 5sintman.adb, 5ssystem.ads, 5staprop.adb, 5stpopse.adb, 5svxwork.ads, 5tosinte.ads, 5uintman.adb, 5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vmastop.adb, 5vparame.ads, 5vsystem.ads, 5vtaprop.adb, 5vtpopde.adb, 5wmemory.adb, 5wsystem.ads, 5wtaprop.adb, 5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb, 5zosinte.ads, 5zsystem.ads, 5ztaprop.adb, 6vcpp.adb, 6vcstrea.adb, 7sintman.adb, 7staprop.adb, 7stpopsp.adb, 9drpc.adb, Make-lang.in, Makefile.in, a-caldel.adb, a-comlin.ads, a-dynpri.adb, a-except.adb, a-except.ads, a-finali.adb, a-ncelfu.ads, a-reatim.adb, a-retide.adb, a-stream.ads, a-ststio.adb, a-ststio.ads, a-stwifi.adb, a-tags.adb, a-tasatt.adb, a-textio.adb, a-tideau.adb, a-tiflau.adb, a-tigeau.adb, a-tigeau.ads, a-tiinau.adb, a-timoau.adb, a-witeio.adb, a-wtdeau.adb, a-wtenau.adb, a-wtflau.adb, a-wtgeau.adb, a-wtgeau.ads, a-wtinau.adb, a-wtmoau.adb, ada-tree.def, ada-tree.h, adaint.c, adaint.h, ali-util.adb, ali.adb, ali.ads, atree.adb, atree.ads, atree.h, back_end.adb, bcheck.adb, bindgen.adb, bindusg.adb, checks.adb, comperr.adb, config-lang.in, csets.adb, csets.ads, cstand.adb, cstreams.c, debug.adb, debug.ads, decl.c, einfo.adb, einfo.ads, einfo.h, elists.h, errout.adb, errout.ads, eval_fat.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb, exp_ch12.adb, exp_ch13.adb, exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads, exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, exp_dbug.ads, exp_disp.ads, exp_dist.adb, exp_fixd.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb, exp_strm.adb, exp_util.adb, exp_util.ads, expander.adb, expect.c, fe.h, fmap.adb, fmap.ads, fname-uf.adb, freeze.adb, frontend.adb, g-awk.adb, g-cgideb.adb, g-comlin.adb, g-comlin.ads, g-debpoo.adb, g-dirope.adb, g-dirope.ads, g-dyntab.adb, g-expect.adb, g-expect.ads, g-io.ads, g-io_aux.adb, g-io_aux.ads, g-locfil.adb, g-locfil.ads, g-os_lib.adb, g-os_lib.ads, g-regexp.adb, g-regpat.adb, g-socket.adb, g-socket.ads, g-spipat.adb, g-table.adb, g-trasym.adb, g-trasym.ads, gigi.h, gmem.c, gnat1drv.adb, gnatbind.adb, gnatbl.c, gnatchop.adb, gnatcmd.adb, gnatdll.adb, gnatfind.adb, gnatlbr.adb, gnatlink.adb, gnatls.adb, gnatmem.adb, gnatprep.adb, gnatvsn.ads, gnatxref.adb, hlo.adb, hostparm.ads, i-cobol.adb, i-cpp.adb, i-cstrea.ads, i-cstrin.adb, i-pacdec.adb, i-vxwork.ads, impunit.adb, init.c, inline.adb, io-aux.c, layout.adb, lib-load.adb, lib-util.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads, lib.adb, lib.ads, make.adb, makeusg.adb, mdll.adb, memroot.adb, misc.c, mlib-tgt.adb, mlib-utl.adb, mlib-utl.ads, mlib.adb, namet.adb, namet.ads, namet.h, nlists.h, nmake.adb, nmake.ads, nmake.adt, opt.adb, opt.ads, osint.adb, osint.ads, output.adb, output.ads, par-ch2.adb, par-ch3.adb, par-ch5.adb, par-prag.adb, par-tchk.adb, par-util.adb, par.adb, prj-attr.adb, prj-dect.adb, prj-env.adb, prj-env.ads, prj-nmsc.adb, prj-part.adb, prj-proc.adb, prj-strt.adb, prj-tree.adb, prj-tree.ads, prj.adb, prj.ads, raise.c, raise.h, repinfo.adb, restrict.adb, restrict.ads, rident.ads, rtsfind.adb, rtsfind.ads, s-arit64.adb, s-asthan.adb, s-atacco.adb, s-atacco.ads, s-auxdec.adb, s-crc32.adb, s-crc32.ads, s-direio.adb, s-fatgen.adb, s-fileio.adb, s-finimp.adb, s-gloloc.adb, s-gloloc.ads, s-interr.adb, s-mastop.adb, s-mastop.ads, s-memory.adb, s-parame.ads, s-parint.adb, s-pooglo.adb, s-pooloc.adb, s-rpc.adb, s-secsta.adb, s-sequio.adb, s-shasto.adb, s-soflin.adb, s-soflin.ads, s-stache.adb, s-taasde.adb, s-taasde.ads, s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprop.ads, s-tarest.adb, s-tasdeb.adb, s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads, s-tassta.adb, s-tasuti.adb, s-tasuti.ads, s-tataat.adb, s-tataat.ads, s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads, s-unstyp.ads, s-widenu.adb, scn-nlit.adb, scn.adb, sem.adb, sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb, sem_ch10.adb, sem_ch11.adb, sem_ch11.ads, sem_ch12.adb, sem_ch13.adb, sem_ch13.ads, sem_ch2.adb, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch6.ads, sem_ch7.adb, sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, sem_disp.adb, sem_dist.adb, sem_elab.adb, sem_elim.adb, sem_elim.ads, sem_eval.adb, sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb, sem_util.ads, sem_vfpt.adb, sem_warn.adb, sinfo.adb, sinfo.ads, sinfo.h, sinput-l.adb, sinput-l.ads, sinput.adb, sinput.ads, snames.adb, snames.ads, snames.h, sprint.adb, sprint.ads, stringt.adb, stringt.ads, stringt.h, style.adb, switch.adb, switch.ads, sysdep.c, system.ads, table.adb, targparm.adb, targparm.ads, targtyps.c, tbuild.adb, tbuild.ads, tracebak.c, trans.c, tree_gen.adb, tree_io.adb, treepr.adb, treepr.ads, treeprs.ads, treeprs.adt, ttypes.ads, types.adb, types.ads, types.h, uintp.ads, urealp.ads, usage.adb, utils.c, utils2.c, validsw.adb, xnmake.adb, xr_tabls.adb, xr_tabls.ads, xref_lib.adb, xref_lib.ads : Merge in ACT changes. * 1ssecsta.adb, 1ssecsta.ads, a-chlat9.ads, a-cwila9.ads, g-enblsp.adb, g-md5.adb, g-md5.ads, gnatname.adb, gnatname.ads, mkdir.c, osint-b.adb, osint-b.ads, osint-c.adb, osint-c.ads, osint-l.adb, osint-l.ads, osint-m.adb, osint-m.ads : New files * 3lsoccon.ads, 5qparame.ads, 5qvxwork.ads, 5smastop.adb, 5zparame.ads, gnatmain.adb, gnatmain.ads, gnatpsys.adb : Removed * mdllfile.adb, mdllfile.ads, mdlltool.adb, mdlltool.ads : Renamed to mdll-fil.ad[bs] and mdll-util.ad[bs] * mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, mdll-utl.ads : Renamed from mdllfile.ad[bs] and mdlltool.ad[bs] From-SVN: r50451
Diffstat (limited to 'gcc/ada/s-tpobop.adb')
-rw-r--r--gcc/ada/s-tpobop.adb268
1 files changed, 183 insertions, 85 deletions
diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb
index 2e86582..d3ffa6e 100644
--- a/gcc/ada/s-tpobop.adb
+++ b/gcc/ada/s-tpobop.adb
@@ -7,9 +7,9 @@
-- --
-- B o d y --
-- --
--- $Revision: 1.13 $
+-- $Revision$
-- --
--- Copyright (C) 1991-2001, Florida State University --
+-- Copyright (C) 1998-2001, 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- --
@@ -30,8 +30,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
@@ -63,6 +62,7 @@ with System.Task_Primitives.Operations;
with System.Tasking.Entry_Calls;
-- used for Wait_For_Completion
-- Wait_Until_Abortable
+-- Wait_For_Completion_With_Timeout
with System.Tasking.Initialization;
-- Used for Defer_Abort,
@@ -86,15 +86,25 @@ with System.Tasking.Rendezvous;
with System.Tasking.Debug;
-- used for Trace
+with System.Parameters;
+-- used for Single_Lock
+-- Runtime_Traces
+
+with System.Traces.Tasking;
+-- used for Send_Trace_Info
+
package body System.Tasking.Protected_Objects.Operations is
package STPO renames System.Task_Primitives.Operations;
+ use Parameters;
use Task_Primitives;
- use Tasking;
use Ada.Exceptions;
use Entries;
+ use System.Traces;
+ use System.Traces.Tasking;
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -183,7 +193,7 @@ package body System.Tasking.Protected_Objects.Operations is
-- has been "cancelled".
-- Enqueued should be true if there is any chance that the call
- -- is still on a queue. It seems to be safe to make it True if
+ -- is still on a queue. It seems to be safe to make it True if
-- the call was Onqueue at some point before return from
-- Protected_Entry_Call.
@@ -192,12 +202,12 @@ package body System.Tasking.Protected_Objects.Operations is
-- ?????
-- The need for Enqueued is less obvious.
- -- The "if enqueued()" tests are not necessary, since both
+ -- The "if enqueued ()" tests are not necessary, since both
-- Cancel_Protected_Entry_Call and Protected_Entry_Call must
- -- do the same test internally, with locking. The one that
+ -- do the same test internally, with locking. The one that
-- makes cancellation conditional may be a useful heuristic
-- since at least 1/2 the time the call should be off-queue
- -- by that point. The other one seems totally useless, since
+ -- by that point. The other one seems totally useless, since
-- Protected_Entry_Call must do the same check and then
-- possibly wait for the call to be abortable, internally.
@@ -206,8 +216,7 @@ package body System.Tasking.Protected_Objects.Operations is
-- No other task can access the call record at this point.
procedure Cancel_Protected_Entry_Call
- (Block : in out Communication_Block)
- is
+ (Block : in out Communication_Block) is
begin
Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);
end Cancel_Protected_Entry_Call;
@@ -248,7 +257,6 @@ package body System.Tasking.Protected_Objects.Operations is
Ex : Ada.Exceptions.Exception_Id)
is
Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
-
begin
pragma Debug
(Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
@@ -257,18 +265,16 @@ package body System.Tasking.Protected_Objects.Operations is
-- a protected operation.
if Entry_Call /= null then
-
-- The call was not requeued.
Entry_Call.Exception_To_Raise := Ex;
--- ?????
--- The caller should do the following, after return from this
--- procedure, if Call_In_Progress /= null
--- Write_Lock (Entry_Call.Self);
--- Initialization.Wakeup_Entry_Caller (STPO.Self, Entry_Call, Done);
--- Unlock (Entry_Call.Self);
+ -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
+ -- PO_Service_Entries on return.
+ end if;
+ if Runtime_Traces then
+ Send_Trace_Info (PO_Done, Entry_Call.Self);
end if;
end Exceptional_Complete_Entry_Body;
@@ -286,6 +292,7 @@ package body System.Tasking.Protected_Objects.Operations is
New_Object : Protection_Entries_Access;
Ceiling_Violation : Boolean;
Barrier_Value : Boolean;
+ Result : Boolean;
begin
-- When the Action procedure for an entry body returns, it is either
@@ -318,7 +325,18 @@ package body System.Tasking.Protected_Objects.Operations is
-- Body of current entry served call to completion
Object.Call_In_Progress := null;
+
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
+ STPO.Write_Lock (Entry_Call.Self);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
+ STPO.Unlock (Entry_Call.Self);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
else
-- Body of current entry requeued the call
@@ -328,13 +346,23 @@ package body System.Tasking.Protected_Objects.Operations is
-- Call was requeued to a task
- if not Rendezvous.Task_Do_Or_Queue
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
+ Result := Rendezvous.Task_Do_Or_Queue
(Self_ID, Entry_Call,
- With_Abort => Entry_Call.Requeue_With_Abort)
- then
+ With_Abort => Entry_Call.Requeue_With_Abort);
+
+ if not Result then
Queuing.Broadcast_Program_Error
- (Self_ID, Object, Entry_Call);
+ (Self_ID, Object, Entry_Call, RTS_Locked => True);
+ end if;
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
end if;
+
return;
end if;
@@ -392,10 +420,18 @@ package body System.Tasking.Protected_Objects.Operations is
else
-- Conditional_Call and With_Abort
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
STPO.Write_Lock (Entry_Call.Self);
pragma Assert (Entry_Call.State >= Was_Abortable);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
STPO.Unlock (Entry_Call.Self);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
end if;
exception
@@ -416,6 +452,7 @@ package body System.Tasking.Protected_Objects.Operations is
Caller : Task_ID;
New_Object : Protection_Entries_Access;
Ceiling_Violation : Boolean;
+ Result : Boolean;
begin
loop
@@ -433,6 +470,11 @@ package body System.Tasking.Protected_Objects.Operations is
Object.Call_In_Progress := Entry_Call;
begin
+ if Runtime_Traces then
+ Send_Trace_Info (PO_Run, Self_ID,
+ Entry_Call.Self, Entry_Index (E));
+ end if;
+
pragma Debug
(Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
Object.Entry_Bodies (
@@ -447,10 +489,19 @@ package body System.Tasking.Protected_Objects.Operations is
if Object.Call_In_Progress /= null then
Object.Call_In_Progress := null;
Caller := Entry_Call.Self;
+
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
STPO.Write_Lock (Caller);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
STPO.Unlock (Caller);
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
else
-- Call needs to be requeued
@@ -460,12 +511,21 @@ package body System.Tasking.Protected_Objects.Operations is
-- Call is to be requeued to a task entry
- if not Rendezvous.Task_Do_Or_Queue
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
+ Result := Rendezvous.Task_Do_Or_Queue
(Self_ID, Entry_Call,
- With_Abort => Entry_Call.Requeue_With_Abort)
- then
+ With_Abort => Entry_Call.Requeue_With_Abort);
+
+ if not Result then
Queuing.Broadcast_Program_Error
- (Self_ID, Object, Entry_Call);
+ (Self_ID, Object, Entry_Call, RTS_Locked => True);
+ end if;
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
end if;
else
@@ -569,29 +629,27 @@ package body System.Tasking.Protected_Objects.Operations is
-- end if;
-- end;
- -- See also Cancel_Protected_Entry_Call for code expansion of
- -- asynchronous entry call.
+ -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
+ -- entry call.
- -- The initial part of this procedure does not need to lock the
- -- the calling task's ATCB, up to the point where the call record
- -- first may be queued (PO_Do_Or_Queue), since before that no
- -- other task will have access to the record.
+ -- The initial part of this procedure does not need to lock the the calling
+ -- task's ATCB, up to the point where the call record first may be queued
+ -- (PO_Do_Or_Queue), since before that no other task will have access to
+ -- the record.
- -- If this is a call made inside of an abort deferred region,
- -- the call should be never abortable.
+ -- If this is a call made inside of an abort deferred region, the call
+ -- should be never abortable.
- -- If the call was not queued abortably, we need to wait
- -- until it is before proceeding with the abortable part.
+ -- If the call was not queued abortably, we need to wait until it is before
+ -- proceeding with the abortable part.
- -- There are some heuristics here, just to save time for
- -- frequently occurring cases. For example, we check
- -- Initially_Abortable to try to avoid calling the procedure
- -- Wait_Until_Abortable, since the normal case for async.
- -- entry calls is to be queued abortably.
+ -- There are some heuristics here, just to save time for frequently
+ -- occurring cases. For example, we check Initially_Abortable to try to
+ -- avoid calling the procedure Wait_Until_Abortable, since the normal case
+ -- for async. entry calls is to be queued abortably.
- -- Another heuristic uses the Block.Enqueued to try to avoid
- -- calling Cancel_Protected_Entry_Call if the call can be
- -- served immediately.
+ -- Another heuristic uses the Block.Enqueued to try to avoid calling
+ -- Cancel_Protected_Entry_Call if the call can be served immediately.
procedure Protected_Entry_Call
(Object : Protection_Entries_Access;
@@ -609,9 +667,13 @@ package body System.Tasking.Protected_Objects.Operations is
pragma Debug
(Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
+ if Runtime_Traces then
+ Send_Trace_Info (PO_Call, Entry_Index (E));
+ end if;
+
if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
- Raise_Exception (Storage_Error'Identity,
- "not enough ATC nesting levels");
+ Raise_Exception
+ (Storage_Error'Identity, "not enough ATC nesting levels");
end if;
Initialization.Defer_Abort (Self_ID);
@@ -685,16 +747,29 @@ package body System.Tasking.Protected_Objects.Operations is
-- Try to avoid an expensive call.
if not Initially_Abortable then
- Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
+ if Single_Lock then
+ STPO.Lock_RTS;
+ Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
+ STPO.Unlock_RTS;
+ else
+ Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
+ end if;
end if;
elsif Mode < Asynchronous_Call then
-- Simple_Call or Conditional_Call
- STPO.Write_Lock (Self_ID);
- Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call);
- STPO.Unlock (Self_ID);
+ if Single_Lock then
+ STPO.Lock_RTS;
+ Entry_Calls.Wait_For_Completion (Entry_Call);
+ STPO.Unlock_RTS;
+ else
+ STPO.Write_Lock (Self_ID);
+ Entry_Calls.Wait_For_Completion (Entry_Call);
+ STPO.Unlock (Self_ID);
+ end if;
+
Block.Cancelled := Entry_Call.State = Cancelled;
else
@@ -704,15 +779,14 @@ package body System.Tasking.Protected_Objects.Operations is
Initialization.Undefer_Abort (Self_ID);
Entry_Calls.Check_Exception (Self_ID, Entry_Call);
-
end Protected_Entry_Call;
----------------------------
-- Protected_Entry_Caller --
----------------------------
- function Protected_Entry_Caller (Object : Protection_Entries'Class)
- return Task_ID is
+ function Protected_Entry_Caller
+ (Object : Protection_Entries'Class) return Task_ID is
begin
return Object.Call_In_Progress.Self;
end Protected_Entry_Caller;
@@ -810,27 +884,23 @@ package body System.Tasking.Protected_Objects.Operations is
E : Protected_Entry_Index;
With_Abort : Boolean)
is
- Self_ID : constant Task_ID := STPO.Self;
- Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
+ Self_ID : constant Task_ID := STPO.Self;
+ Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
begin
Initialization.Defer_Abort (Self_ID);
- STPO.Write_Lock (Self_ID);
+
+ -- We do not need to lock Self_ID here since the call is not abortable
+ -- at this point, and therefore, the caller cannot cancel the call.
+
Entry_Call.Needs_Requeue := True;
Entry_Call.Requeue_With_Abort := With_Abort;
Entry_Call.Called_PO := To_Address (New_Object);
Entry_Call.Called_Task := null;
- STPO.Unlock (Self_ID);
Entry_Call.E := Entry_Index (E);
Initialization.Undefer_Abort (Self_ID);
end Requeue_Task_To_Protected_Entry;
- -- ??????
- -- Do we really need to lock Self_ID above?
- -- Might the caller be trying to cancel?
- -- If so, it should fail, since the call state should not be
- -- abortable while the call is in service.
-
---------------------
-- Service_Entries --
---------------------
@@ -855,70 +925,90 @@ package body System.Tasking.Protected_Objects.Operations is
Mode : Delay_Modes;
Entry_Call_Successful : out Boolean)
is
- Self_ID : Task_ID := STPO.Self;
+ Self_Id : constant Task_ID := STPO.Self;
Entry_Call : Entry_Call_Link;
Ceiling_Violation : Boolean;
+ Yielded : Boolean;
begin
- if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
+ if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
Raise_Exception (Storage_Error'Identity,
"not enough ATC nesting levels");
end if;
- Initialization.Defer_Abort (Self_ID);
+ if Runtime_Traces then
+ Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
+ end if;
+
+ Initialization.Defer_Abort (Self_Id);
Lock_Entries (Object, Ceiling_Violation);
if Ceiling_Violation then
- Initialization.Undefer_Abort (Self_ID);
+ Initialization.Undefer_Abort (Self_Id);
raise Program_Error;
end if;
- Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
+ Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
pragma Debug
- (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " &
- ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
+ (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
+ ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
Entry_Call :=
- Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
+ Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
Entry_Call.Next := null;
Entry_Call.Mode := Timed_Call;
Entry_Call.Cancellation_Attempted := False;
- if Self_ID.Deferral_Level > 1 then
+ if Self_Id.Deferral_Level > 1 then
Entry_Call.State := Never_Abortable;
else
Entry_Call.State := Now_Abortable;
end if;
Entry_Call.E := Entry_Index (E);
- Entry_Call.Prio := STPO.Get_Priority (Self_ID);
+ Entry_Call.Prio := STPO.Get_Priority (Self_Id);
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Called_PO := To_Address (Object);
Entry_Call.Called_Task := null;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
- PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
- PO_Service_Entries (Self_ID, Object);
+ PO_Do_Or_Queue (Self_Id, Object, Entry_Call, With_Abort => True);
+ PO_Service_Entries (Self_Id, Object);
Unlock_Entries (Object);
-- Try to avoid waiting for completed or cancelled calls.
if Entry_Call.State >= Done then
- Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
+ Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1;
pragma Debug
- (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " &
- ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
+ (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
+ ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
Entry_Call_Successful := Entry_Call.State = Done;
- Initialization.Undefer_Abort (Self_ID);
- Entry_Calls.Check_Exception (Self_ID, Entry_Call);
+ Initialization.Undefer_Abort (Self_Id);
+ Entry_Calls.Check_Exception (Self_Id, Entry_Call);
return;
end if;
+ if Single_Lock then
+ STPO.Lock_RTS;
+ else
+ STPO.Write_Lock (Self_Id);
+ end if;
+
Entry_Calls.Wait_For_Completion_With_Timeout
- (Self_ID, Entry_Call, Timeout, Mode);
- Initialization.Undefer_Abort (Self_ID);
+ (Entry_Call, Timeout, Mode, Yielded);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ else
+ STPO.Unlock (Self_Id);
+ end if;
+
+ -- ??? Do we need to yield in case Yielded is False
+
+ Initialization.Undefer_Abort (Self_Id);
Entry_Call_Successful := Entry_Call.State = Done;
- Entry_Calls.Check_Exception (Self_ID, Entry_Call);
+ Entry_Calls.Check_Exception (Self_Id, Entry_Call);
end Timed_Protected_Entry_Call;
----------------------------
@@ -953,7 +1043,6 @@ package body System.Tasking.Protected_Objects.Operations is
With_Abort : Boolean)
is
Old : Entry_Call_State := Entry_Call.State;
-
begin
pragma Assert (Old < Done);
@@ -963,6 +1052,10 @@ package body System.Tasking.Protected_Objects.Operations is
if Old < Was_Abortable and then
Entry_Call.State = Now_Abortable
then
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
STPO.Write_Lock (Entry_Call.Self);
if Entry_Call.Self.Common.State = Async_Select_Sleep then
@@ -970,6 +1063,11 @@ package body System.Tasking.Protected_Objects.Operations is
end if;
STPO.Unlock (Entry_Call.Self);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
end if;
elsif Entry_Call.Mode = Conditional_Call then