mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-11 03:45:33 +00:00
Code Issues Projects Releases Wiki Activity
Files
4ee7e744b715b7adf665a267de3814131839a617
mercury/library/stm_builtin.m
Zoltan Somogyi a12692a0de Replace /* */ comments with // in the library. 
Keep the old style comments where they do not go to the end of the line,
or where it is important that the comment line not have a // on it.
2018-06-21 18:55:08 +02:00

607 lines
18 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2007-2009, 2011 The University of Melbourne.
% Copyright (C) 2014-2015, 2018 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% File: stm_builtin.m.
% Main author: lmika.
% Stability: low.
%
% This module defines types and predicates that can be used with the
% Software Transactional Memory constructs.
%
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- module stm_builtin.
:- interface.
:- import_module io.
%---------------------------------------------------------------------------%
%
% Transaction state
%
% The STM transaction state type is used to store a log of (tentative)
% updates to stm_vars (defined below) within an atomic block.
% Within an atomic block each call that reads or writes an stm_var has
% a pair of arguments of this type threaded through it.
% These arguments are unique so that read or writes to stm_vars cannot
% be backtracked over.
%
% Values of this type are implicitly created by the compiler at the
% beginning of an atomic block and passed to the goal within that block.
% User program should not create values of this type.
%
:- type stm.
%---------------------------------------------------------------------------%
%
% Transaction variables
%
% A transaction variable may contain a value of type T.
% It may only be accessed from within an atomic scope.
%
:- type stm_var(T).
% new_stm_var(Value, TVar, !IO):
%
% Create a new transaction variable with initial value `Value'.
%
:- pred new_stm_var(T::in, stm_var(T)::out, io::di, io::uo) is det.
% new_stm_var_atomic(Value, TVar, !STM):
%
% A version of new_stm_var which works within an atomic scope.
%
:- pred new_stm_var_atomic(T::in, stm_var(T)::out, stm::di, stm::uo) is det.
% Update the value stored in a transaction variable.
%
:- pred write_stm_var(stm_var(T)::in, T::in, stm::di, stm::uo) is det.
% Read the current value stored in a transaction variable.
%
:- 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 causes the calling thread to block until the value
% of at least one transaction variable read during the attempted
% transaction is written by another thread.
%
:- pred retry(stm::ui) is erroneous.
%---------------------------------------------------------------------------%
%
% Closure versions of atomic transactions. These predicates can be used
% to perform Software Transactional Memory without using the atomic scope.
%
% atomic_transaction(Closure, Result, !IO):
%
% Performs the Software Transactional Memory operations in Closure
% atomically. If the transaction is invalid, the Closure is
% re-executed.
%
:- pred atomic_transaction(pred(T, stm, stm)::in(pred(out, di, uo) is det),
T::out, io::di, io::uo) is det.
% or_else(AtomicClosure1, AtomicClosure2, Result, !STM):
%
% Performs the Software Transactional Memory operations in AtomicClosure1
% atomically. If a retry is thrown, AtomicClosure2 is executed atomically.
%
:- pred or_else(pred(T, stm, stm)::in(pred(out, di, uo) is det),
pred(T, stm, stm)::in(pred(out, di, uo) is det),
T::out, stm::di, stm::uo) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
%---------------------------------------------------------------------------%
:- interface.
% The remainder of this file contains the builtin predicates that the compiler
% generates calls to when implementing software transactional memory.
% These predicates should not be called by user programs directly.
% This module also defines some types that are used by those predicates.
% We throw exceptions of this type to indicate that a transaction is
% being rolled back.
%
:- type rollback_exception
---> rollback_invalid_transaction
; rollback_retry.
% Create a new transaction log.
%
:- impure pred stm_create_transaction_log(stm::uo) is det.
% Discard a transaction log.
%
:- impure pred stm_discard_transaction_log(stm::di) is det.
% stm_create_nested_transaction_log(Parent, Child):
%
% `Child' is a new transaction log whose enclosing transaction's log
% is given by `Parent'.
%
:- impure pred stm_create_nested_transaction_log(stm::ui, stm::uo) is det.
% Lock the STM global mutex.
%
:- impure pred stm_lock is det.
% Unlock the STM global mutex.
%
:- impure pred stm_unlock is det.
% Values of this type are returned by stm_validate/2 and indicate
% whether a given transaction log is valid.
%
% NOTE: The definition of this type must be kept consistent with the
% constants defined in runtime/mercury_stm.h.
%
:- type stm_validation_result
---> stm_transaction_valid
; stm_transaction_invalid.
% Record whether the (partial) transaction recorded in the given
% transaction log is valid or not.
%
:- impure pred stm_validate(stm::ui, stm_validation_result::out) is det.
% Write the changes in the given log to memory.
%
% NOTE: This predicate must *only* be called while the STM global mutex
% is locked.
%
:- impure pred stm_commit(stm::ui) is det.
% Add this thread to the wait queues of the transaction variables referred
% to by the given log and then block until another thread makes a commit
% that involves one of those transaction variables.
%
% NOTE: This predicate must *only* be called while the STM global mutex
% is locked.
%
:- impure pred stm_block(stm::ui) is det.
% This type is used in the case where an atomic_scope has no outputs
% since the call to try_stm/3 introduced by the expansion of atomic
% scopes needs to return at least one value.
%
:- type stm_dummy_output
---> stm_dummy_output.
% Used to enforce the uniqueness of outer and inner variables.
% Will be removed before stm_expansion.
%
:- pred stm_from_outer_to_inner(T::di, stm::uo) is det.
:- pred stm_from_inner_to_outer(stm::di, T::uo) is det.
% Changes the value of a transaction variable without going through
% the log. USE ONLY FOR DEBUGGING PURPOSES.
%
:- pred unsafe_write_stm_var(stm_var(T)::in, T::in, stm::di, stm::uo) is det.
:- impure pred stm_merge_nested_logs(stm::di, stm::di, stm::uo) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module exception.
:- import_module univ.
%---------------------------------------------------------------------------%
:- pragma foreign_decl("C", "#include \"mercury_stm.h\"").
:- pragma foreign_type("C", stm_var(T), "MR_STM_Var *",
[stable, can_pass_as_mercury_type]).
:- pragma foreign_type("C", stm, "MR_STM_TransLog *",
[can_pass_as_mercury_type]).
% Definitions for use with the other backends.
%
:- type stm_var(T)
---> tvar(c_pointer).
:- type stm
---> stm(c_pointer).
%---------------------------------------------------------------------------%
:- pragma foreign_proc("C",
new_stm_var(T::in, TVar::out, _IO0::di, _IO::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
MR_STM_new_stm_var(T, TVar);
").
:- pragma foreign_proc("C",
new_stm_var_atomic(T::in, TVar::out, STM0::di, STM::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
MR_STM_new_stm_var(T, TVar);
STM = STM0;
").
:- pragma foreign_proc("C",
write_stm_var(TVar::in, Value::in, STM0::di, STM::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
MR_STM_write_var(TVar, Value, STM0);
STM = STM0;
").
:- pragma foreign_proc("C",
unsafe_write_stm_var(TVar::in, Value::in, STM0::di, STM::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
MR_STM_unsafe_write_var(TVar, Value);
STM = STM0;
").
:- pragma foreign_proc("C",
read_stm_var(TVar::in, Value::out, STM0::di, STM::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
Value = MR_STM_read_var(TVar, STM0);
STM = STM0;
").
:- pragma foreign_proc("C",
stm_create_transaction_log(STM::uo),
[will_not_call_mercury, thread_safe],
"
MR_STM_create_log(STM, NULL);
#if defined(MR_STM_DEBUG)
fprintf(stderr, \"STM NEW LOG: log <0x%.8lx>\\n\",
(MR_Word)(STM));
#endif
").
:- pragma foreign_proc("C",
stm_create_nested_transaction_log(Parent::ui, Child::uo),
[will_not_call_mercury, thread_safe],
"
MR_STM_create_log(Child, Parent);
#ifdef MR_STM_DEBUG
fprintf(stderr,
\"STM: Creating nested log <0x%.8lx>, parent <0x%.8lx>\\n\",
(MR_Word)(Child), (MR_Word)(Parent));
#endif
").
:- pragma foreign_proc("C",
stm_discard_transaction_log(STM::di),
[will_not_call_mercury, thread_safe],
"
MR_STM_discard_log(STM);
").
:- pragma foreign_proc("C",
stm_merge_nested_logs(Child::di, Parent0::di, Parent::uo),
[will_not_call_mercury, thread_safe],
"
// Avoid a warning: Child, Parent0, Parent
#if defined(MR_STM_DEBUG)
fprintf(stderr, \"STM Calling Merge Nested: log <0x%.8lx>\\n\",
(MR_Word)(Child));
#endif
MR_STM_merge_transactions(Child);
Parent = Parent0;
").
:- pragma foreign_proc("C",
stm_lock,
[will_not_call_mercury, thread_safe],
"
#if defined(MR_THREAD_SAFE)
MR_LOCK(&MR_STM_lock, \"stm_lock/0\");
#endif
#if defined(MR_STM_DEBUG)
fprintf(stderr, \"STM LOCKING\\n\");
#endif
").
:- pragma foreign_proc("C",
stm_unlock,
[will_not_call_mercury, thread_safe],
"
#if defined(MR_STM_DEBUG)
fprintf(stderr, \"STM UNLOCKING\\n\");
#endif
#if defined(MR_THREAD_SAFE)
MR_UNLOCK(&MR_STM_lock, \"stm_unlock/0\");
#endif
").
:- pragma foreign_proc("C",
stm_validate(STM::ui, IsValid::out),
[will_not_call_mercury, thread_safe],
"
IsValid = MR_STM_validate(STM);
").
:- pragma foreign_proc("C",
stm_commit(STM::ui),
[will_not_call_mercury, thread_safe],
"
MR_STM_commit(STM);
").
:- pragma foreign_proc("C",
stm_from_outer_to_inner(IO::di, STM::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
STM = NULL;
MR_final_io_state(IO);
").
:- pragma foreign_proc("C",
stm_from_inner_to_outer(STM0::di, IO::uo),
[promise_pure, will_not_call_mercury, thread_safe],
"
STM0 = NULL;
IO = MR_initial_io_state();
").
%---------------------------------------------------------------------------%
% In high level C grades, stm_block calls a C procedure in the runtime that
% blocks the POSIX thread until signalled, as there is one POSIX thread for
% every Mercury thread.
% In the low level C grades, this approach cannot be taken, as when the context
% blocks the engine running in the POSIX thread needs to be able to look for
% other work (there might only be a single engine/POSIX thread).
:- pragma foreign_proc("C",
stm_block(STM::ui),
[will_not_call_mercury, thread_safe],
"
#if defined(MR_HIGHLEVEL_CODE)
MR_STM_block_thread(STM);
#else
MR_STM_wait(STM, STM);
#if defined(MR_STM_DEBUG)
fprintf(stderr, ""STM BLOCKING: log <0x%.8lx>\\n"", STM);
#endif
MR_save_context(MR_ENGINE(MR_eng_this_context));
MR_ENGINE(MR_eng_this_context)->MR_ctxt_resume =
MR_ENTRY(mercury__stm_builtin__block_thread_resume);
MR_UNLOCK(&MR_STM_lock, ""MR_STM_block_thread"");
MR_ENGINE(MR_eng_this_context) = NULL;
MR_idle();
#endif
").
% block_thread_resume is the piece of code we jump to when a thread suspended
% after a failed STM transaction resumes
:- pragma foreign_decl("C",
"
/*
INIT mercury_sys_init_stm_builtin_modules
*/
#if !defined(MR_HIGHLEVEL_CODE)
MR_define_extern_entry(mercury__stm_builtin__block_thread_resume);
#endif
").
:- pragma foreign_code("C",
"
#if !defined(MR_HIGHLEVEL_CODE)
MR_BEGIN_MODULE(hand_written_stm_builtin_module)
MR_init_entry_ai(mercury__stm_builtin__block_thread_resume);
MR_BEGIN_CODE
MR_define_entry(mercury__stm_builtin__block_thread_resume);
{
MR_proceed();
}
MR_END_MODULE
#endif
// Forward decls to suppress gcc warnings.
void mercury_sys_init_stm_builtin_modules_init(void);
void mercury_sys_init_stm_builtin_modules_init_type_tables(void);
#ifdef MR_DEEP_PROFILING
void mercury_sys_init_stm_builtin_modules_write_out_proc_statics(
FILE *deep_fp, FILE *procrep_fp);
#endif
void mercury_sys_init_stm_builtin_modules_init(void)
{
#if !defined(MR_HIGHLEVEL_CODE)
hand_written_stm_builtin_module();
#endif
}
void mercury_sys_init_stm_builtin_modules_init_type_tables(void)
{
// No types to register.
}
#ifdef MR_DEEP_PROFILING
void mercury_sys_init_stm_builtin_modules_write_out_proc_statics(
FILE *deep_fp, FILE *procrep_fp)
{
// No proc_statics to write out.
}
#endif
").
%---------------------------------------------------------------------------%
%
% Retry
%
retry(_) :-
throw(rollback_retry).
%---------------------------------------------------------------------------%
%
% Atomic transactions
%
atomic_transaction(Goal, Result, !IO) :-
promise_pure (
impure atomic_transaction_impl(Goal, Result)
).
:- pragma promise_pure(or_else/5).
or_else(TransA, TransB, Result, OuterSTM0, OuterSTM) :-
impure stm_create_nested_transaction_log(OuterSTM0, InnerSTM_A0),
promise_equivalent_solutions [ResultA, InnerSTM_A] (
unsafe_try_stm(TransA, ResultA,
InnerSTM_A0, InnerSTM_A)
),
(
ResultA = succeeded(Result),
impure stm_merge_nested_logs(InnerSTM_A, OuterSTM0, OuterSTM)
;
ResultA = exception(ExcpA),
% If transaction A retried, then we should attempt transaction B.
% Otherwise we just propagate the exception upwards.
( if ExcpA = univ(rollback_retry) then
impure stm_create_nested_transaction_log(OuterSTM0, InnerSTM_B0),
promise_equivalent_solutions [ResultB, InnerSTM_B] (
unsafe_try_stm(TransB, ResultB,
InnerSTM_B0, InnerSTM_B)
),
(
ResultB = succeeded(Result),
impure stm_merge_nested_logs(InnerSTM_B, OuterSTM0, OuterSTM)
;
ResultB = exception(ExcpB),
( if ExcpB = univ(rollback_retry) then
impure stm_lock,
impure stm_validate(InnerSTM_A, IsValidA),
impure stm_validate(InnerSTM_B, IsValidB),
( if
IsValidA = stm_transaction_valid,
IsValidB = stm_transaction_valid
then
% We want to wait on the union of the transaction
% variables accessed during both alternatives.
% We merge the transaction logs (the order does not
% matter) and then propagate the retry upwards.
impure stm_merge_nested_logs(InnerSTM_A, OuterSTM0,
OuterSTM1),
impure stm_merge_nested_logs(InnerSTM_B, OuterSTM1,
OuterSTM),
impure stm_unlock,
retry(OuterSTM)
else
impure stm_unlock,
throw(rollback_invalid_transaction)
)
else
impure stm_discard_transaction_log(InnerSTM_B),
rethrow(ResultB)
)
)
else
impure stm_discard_transaction_log(InnerSTM_A),
rethrow(ResultA)
)
).
:- impure pred atomic_transaction_impl(
pred(T, stm, stm)::in(pred(out, di, uo) is det), T::out) is det.
atomic_transaction_impl(Goal, Result) :-
impure stm_create_transaction_log(STM0),
promise_equivalent_solutions [Result0, STM] (
unsafe_try_stm(call_atomic_goal(Goal), Result0, STM0, STM)
),
(
Result0 = succeeded(Result)
;
Result0 = exception(Excp),
( if Excp = univ(rollback_invalid_transaction) then
impure stm_discard_transaction_log(STM),
impure atomic_transaction_impl(Goal, Result)
else if Excp = univ(rollback_retry) then
impure stm_lock,
impure stm_validate(STM, IsValid),
(
IsValid = stm_transaction_valid,
% NOTE: stm_block is responsible for releasing the STM lock.
impure stm_block(STM)
;
IsValid = stm_transaction_invalid,
impure stm_unlock
),
impure stm_discard_transaction_log(STM),
impure atomic_transaction_impl(Goal, Result)
else
impure stm_lock,
impure stm_validate(STM, IsValid),
impure stm_unlock,
(
IsValid = stm_transaction_valid,
rethrow(Result0)
;
IsValid = stm_transaction_invalid,
impure stm_discard_transaction_log(STM),
impure atomic_transaction_impl(Goal, Result)
)
)
).
:- pred call_atomic_goal(pred(T, stm, stm)::in(pred(out, di, uo) is det),
T::out, stm::di, stm::uo) is det.
call_atomic_goal(Goal, Result, !STM) :-
promise_pure (
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_invalid_transaction)
)
).
%---------------------------------------------------------------------------%
:- end_module stm_builtin.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink