[m-rev.] diff: add support for atomic execution of closures using STM

[Julien Fischer]

Estimated hours taken: 2
Branches: main

Add a higher-order predicate for atomically executing closures using
STM.  This will eventually be replaced by the atomic scopes, but until
they are available having this facility available assists with working
on the STM runtime support.

This diff also includes the Mercury interface to the STM retry operation.
(I was working on this when I realised the above would be useful, which
is why it is in the same workspace.)  The runtime support for retry is
not included in this diff.

library/stm_builtin.m:
 	Add a higher-order predicate that atomically executes a closure
 	using STM.  (This is like the one in the prototype STM implementation
 	except that it handles exceptions properly.)

 	Add the Mercury interface to the STM retry operation.
 	(The runtime support for this has not been implemented; it will
 	currently cause execution to abort.)

runtime/mercury_stm.h:
runtime/mercury_stm.c:
 	Add a stub function for MR_stm_retry_impl.

Julien.

Index: library/stm_builtin.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/library/stm_builtin.m,v
retrieving revision 1.9
diff -u -r1.9 stm_builtin.m
--- library/stm_builtin.m	13 Sep 2007 04:40:51 -0000	1.9
+++ library/stm_builtin.m	14 Sep 2007 07:42:28 -0000
@@ -67,6 +67,30 @@
  :- pred read_stm_var(stm_var(T)::in, T::out, stm::di, stm::uo) is det.

  %-----------------------------------------------------------------------------%
+%
+% Retry
+%
+
+    % Abort the current transaction and restart it from the beginning.
+    % Operationally this casuses the calling thread to block until the value
+    % of at least one transaction variable read during the attempted
+    % transaction is written by another thread.
+    %
+    % XXX the implementation of this predicate is incomplete.  Calling it
+    % will currently cause the program to abort execution.
+    %
+:- pred retry(stm::di) is erroneous.
+
+%-----------------------------------------------------------------------------%
+%
+% Atomic transactions
+%
+
+:- pred atomic_transaction(pred(T, stm, stm), T, io, io).
+:- mode atomic_transaction(in(pred(out, di, uo) is det), out, di, uo)
+    is det.
+
+%-----------------------------------------------------------------------------%
  %-----------------------------------------------------------------------------%

  :- implementation.
@@ -157,6 +181,9 @@
  :- implementation.

  :- import_module exception.
+:- import_module univ.
+
+%-----------------------------------------------------------------------------%

  :- pragma foreign_decl("C", "#include \"mercury_stm.h\"").

@@ -277,47 +304,86 @@
  ").

  %-----------------------------------------------------------------------------%
+%
+% Retry
+%

-/* To Implement:
-**
-**  retry(STM) :-
-**      stm_lock,
-**      stm_validate(STM, Valid),
-**      (
-**          Valid = yes,
-**          stm_wait(STM),        % Add wait variables to TVars
-**          stm_unlock, 
-**          block_and_wait(STM)
-**      ; 
-**          Valid = no,
-**          stm_unlock,
-**          throw(RollbackException)
-**      ).
-**
-**  :- pred block_and_wait(stm::di) is failure.
-**
-**  block_and_wait(STM) :-
-**      block_thread(STM),      ***
-**      stm_lock,
-**      stm_validate(STM, Valid),
-**      (
-**          Valid = yes,
-**          stm_unlock,
-**          block_and_wait,
-**      ;
-**          Valid = no,
-**          stm_unwait(STM),    % Remove wait variables from TVar
-**          stm_unlock
-**          throw(RollbackException)
-**      ).
-** 
-**  Need to implement:
-**
-**  :- impure pred block_thread(stm::ui) is det.
-**      % Blocks the current thread until another transaction is committed.
-**      % XXX: What to do when there is only one thread?
-*       % XXX: this needs to be fixed - juliensf.
-*/
+retry(STM) :-
+    promise_pure (
+        impure retry_impl(STM),
+        throw(rollback_exception)
+    ).
+
+:- impure pred retry_impl(stm::di) is det.
+:- pragma foreign_proc("C",
+    retry_impl(STM::di),
+    [will_not_call_mercury],
+"
+    MR_STM_retry_impl(STM);
+").
+
+    % For the non-C backends.
+    %
+retry_impl(_) :-
+    impure impure_true.
+
+%-----------------------------------------------------------------------------%
+%
+% Atomic transactions
+%
+
+:- pragma promise_pure(atomic_transaction/4).
+atomic_transaction(Goal, Result, !IO) :-
+    impure atomic_transaction_impl(Goal, Result). 
+
+:- impure pred atomic_transaction_impl(pred(T, stm, stm), T).
+:- mode atomic_transaction_impl(in(pred(out, di, uo) is det), out)
+    is det.
+
+atomic_transaction_impl(Goal, Result) :-
+    impure stm_create_state(STM0),
+    promise_equivalent_solutions [Result0, STM] (
+        unsafe_try_stm(call_atomic_goal(Goal), Result0, STM0, STM)
+    ),
+    (
+        Result0 = succeeded(Result)
+    ;
+        Result0 = exception(Excp),
+        ( Excp = univ(rollback_exception) ->
+            impure atomic_transaction_impl(Goal, Result)
+        ;
+            impure stm_lock,
+            impure stm_validate(STM, IsValid),
+            impure stm_unlock,
+            (
+                IsValid = stm_transaction_valid,
+                rethrow(Result0)
+            ;
+                IsValid = stm_transaction_invalid,
+                impure stm_drop_state(STM),
+                impure atomic_transaction_impl(Goal, Result)
+            )
+        )
+    ).
+
+:- pragma promise_pure(call_atomic_goal/4).
+:- pred call_atomic_goal(pred(T, stm, stm), T, stm, stm).
+:- mode call_atomic_goal(in(pred(out, di, uo) is det), out, di, uo)
+    is det.
+
+call_atomic_goal(Goal, Result, !STM) :-
+    Goal(Result, !STM),
+    impure stm_lock,
+    impure stm_validate(!.STM, IsValid),
+    (
+        IsValid = stm_transaction_valid,
+        impure stm_commit(!.STM),
+        impure stm_unlock
+    ;
+        IsValid = stm_transaction_invalid,
+        impure stm_unlock,
+        throw(rollback_exception)
+    ).

  %----------------------------------------------------------------------------%
  :- end_module stm_builtin.
Index: runtime/mercury_stm.c
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_stm.c,v
retrieving revision 1.1
diff -u -r1.1 mercury_stm.c
--- runtime/mercury_stm.c	13 Sep 2007 04:40:52 -0000	1.1
+++ runtime/mercury_stm.c	14 Sep 2007 07:42:28 -0000
@@ -159,3 +159,9 @@

      return var->MR_STM_var_value;
  }
+
+void
+MR_STM_retry_impl(MR_STM_TransLog *log)
+{
+    MR_fatal_error("Sorry, STM retry not yet implemented.");
+} 
Index: runtime/mercury_stm.h
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/runtime/mercury_stm.h,v
retrieving revision 1.1
diff -u -r1.1 mercury_stm.h
--- runtime/mercury_stm.h	13 Sep 2007 04:40:52 -0000	1.1
+++ runtime/mercury_stm.h	14 Sep 2007 07:42:28 -0000
@@ -174,6 +174,9 @@
  extern MR_Word
  MR_STM_read_var(MR_STM_Var *var, MR_STM_TransLog *log);

+extern void
+MR_STM_retry_impl(MR_STM_TransLog *log);
+
  #if defined(MR_THREAD_SAFE)
      extern MercuryLock  MR_STM_lock;
  #endif

--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------