[m-rev.] for review: allow mutable init by impure functions

Peter Wang novalazy at gmail.com
Wed Oct 26 17:44:18 AEDT 2011


Branches: main, 11.07

Allow mutable variables to be initialised by impure functions.

Also fix bug #223.  Make thread.semaphore.init/1 and thread.mvar.init/1
impure, as they should be.  They were introduced to be used as mutable
initialisers, which led to the oversight of making them pure.

compiler/make_hlds_passes.m:
compiler/prog_mutable.m:
	Modify the generated mutable initialisation predicates such that the
	initial value may be the return value of a impure function call.

compiler/purity.m:
	Ignore warnings about unnecessary impure annotations on goals in
	generated mutable predicates.  These would now appear when
	a mutable is initialised by a call to a pure function, or
	by a constant.

doc/reference_manual.texi:
NEWS:
	Document the language change.

library/thread.mvar.m:
library/thread.semaphore.m:
	Make thread.semaphore.init/1 and thread.mvar.init/1 impure.

tests/hard_coded/Mmakefile:
tests/hard_coded/mutable_init_impure.exp:
tests/hard_coded/mutable_init_impure.m:
	Add test case.

diff --git a/NEWS b/NEWS
index 4714e1f..c68031e 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,8 @@ Changes to the Mercury language:
   (or XXXXXXXX) is a Unicode character code in hexadecimal, is replaced with
   the corresponding Unicode character.
 
+* Mutables may now be initialised by impure functions.
+
 Changes to the Mercury standard library:
 
 * We have improved Unicode support in the standard library.
diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m
index dce9932..f724793 100644
--- a/compiler/make_hlds_passes.m
+++ b/compiler/make_hlds_passes.m
@@ -2493,7 +2493,7 @@ add_ccsj_mutable_user_access_preds(ModuleName, MutableName, MutAttrs,
     list(error_spec)::in, list(error_spec)::out) is det.
 
 add_c_mutable_initialisation(IsConstant, IsThreadLocal, TargetMutableName,
-        ModuleName, MutableName, MutVarset, InitSetPredName, InitTerm, Attrs,
+        ModuleName, MutableName, MutVarset0, InitSetPredName, InitTerm, Attrs,
         Context, !Status, !ModuleInfo, !QualInfo, !Specs) :-
     % Add the `:- initialise' declaration for the mutable initialisation
     % predicate.
@@ -2506,11 +2506,16 @@ add_c_mutable_initialisation(IsConstant, IsThreadLocal, TargetMutableName,
     add_item_pass_3(InitItem, !Status, !ModuleInfo, !QualInfo, !Specs),
 
     % Add the clause for the mutable initialisation predicate.
+    varset.new_named_var("X", X, MutVarset0, MutVarset),
+    UnifyExpr =
+        unify_expr(variable(X, Context), InitTerm, purity_impure)
+            - Context,
     (
         IsConstant = yes,
-        InitClauseExpr =
-            call_expr(InitSetPredName, [InitTerm], purity_impure)
-                - Context
+        CallExpr =
+            call_expr(InitSetPredName, [variable(X, Context)], purity_impure)
+                - Context,
+        InitClauseExpr = conj_expr(UnifyExpr, CallExpr) - Context
     ;
         IsConstant = no,
         (
@@ -2549,9 +2554,10 @@ add_c_mutable_initialisation(IsConstant, IsThreadLocal, TargetMutableName,
         CallPreInitExpr =
             call_expr(PreInitPredName, [], purity_impure) - Context,
         CallSetPredExpr =
-            call_expr(InitSetPredName, [InitTerm], purity_impure) - Context,
-        InitClauseExpr = conj_expr(CallPreInitExpr, CallSetPredExpr)
-            - Context
+            call_expr(InitSetPredName, [variable(X, Context)], purity_impure)
+                - Context,
+        InitClauseExpr = goal_list_to_conj(Context,
+            [CallPreInitExpr, UnifyExpr, CallSetPredExpr])
     ),
 
     % See the comments for prog_io.parse_mutable_decl for the reason
@@ -2833,7 +2839,7 @@ add_csharp_java_mutable_primitive_preds(Lang, TargetMutableName, ModuleName,
     module_info::in, module_info::out, qual_info::in, qual_info::out,
     list(error_spec)::in, list(error_spec)::out) is det.
 
-add_csharp_java_mutable_initialisation(ModuleName, MutableName, MutVarset,
+add_csharp_java_mutable_initialisation(ModuleName, MutableName, MutVarset0,
         CallPreInitExpr, InitSetPredName, InitTerm,
         Context, !Status, !ModuleInfo, !QualInfo, !Specs) :-
     % Add the `:- initialise' declaration for the mutable initialisation
@@ -2847,12 +2853,15 @@ add_csharp_java_mutable_initialisation(ModuleName, MutableName, MutVarset,
     add_item_pass_3(InitItem, !Status, !ModuleInfo, !QualInfo, !Specs),
 
     % Add the clause for the mutable initialisation predicate.
-    CallSetPredExpr =
-        call_expr(InitSetPredName, [InitTerm], purity_impure)
+    varset.new_named_var("X", X, MutVarset0, MutVarset),
+    UnifyExpr =
+        unify_expr(variable(X, Context), InitTerm, purity_impure)
             - Context,
-    InitClauseExpr =
-        conj_expr(CallPreInitExpr, CallSetPredExpr)
+    CallSetPredExpr =
+        call_expr(InitSetPredName, [variable(X, Context)], purity_impure)
             - Context,
+    InitClauseExpr = goal_list_to_conj(Context,
+        [CallPreInitExpr, UnifyExpr, CallSetPredExpr]),
 
     % See the comments for prog_io.parse_mutable_decl for the reason
     % why we _must_ use MutVarset here.
@@ -3081,7 +3090,7 @@ erlang_mutable_set_code(TargetMutableName) =
     list(error_spec)::in, list(error_spec)::out) is det.
 
 add_erlang_mutable_initialisation(ModuleName, MutableName,
-        MutVarset, InitSetPredName, InitTerm,
+        MutVarset0, InitSetPredName, InitTerm,
         Context, !Status, !ModuleInfo, !QualInfo, !Specs) :-
     % Add the `:- initialise' declaration for the mutable initialisation
     % predicate.
@@ -3096,11 +3105,16 @@ add_erlang_mutable_initialisation(ModuleName, MutableName,
     %
     % See the comments for prog_io.parse_mutable_decl for the reason
     % why we _must_ use MutVarset here.
+    varset.new_named_var("X", X, MutVarset0, MutVarset),
+    UnifyExpr =
+        unify_expr(variable(X, Context), InitTerm, purity_impure)
+            - Context,
+    CallExpr =
+        call_expr(InitSetPredName, [variable(X, Context)], purity_impure)
+            - Context,
+    InitClauseExpr = conj_expr(UnifyExpr, CallExpr) - Context,
     PredItemClause = item_clause_info(compiler(mutable_decl), MutVarset,
-        pf_predicate, InitPredName, [],
-        call_expr(InitSetPredName, [InitTerm], purity_impure) - Context,
-        Context, -1
-    ),
+        pf_predicate, InitPredName, [], InitClauseExpr, Context, -1),
     PredItem = item_clause(PredItemClause),
     add_item_pass_3(PredItem, !Status, !ModuleInfo, !QualInfo, !Specs).
 
diff --git a/compiler/prog_mutable.m b/compiler/prog_mutable.m
index ec54f8e..5e2a2e2 100644
--- a/compiler/prog_mutable.m
+++ b/compiler/prog_mutable.m
@@ -58,7 +58,8 @@
 %
 %   initialise_mutable_<varname> :-
 %       impure pre_initialise_mutable_<varname>,
-%       impure set_<varname>(<initval>).
+%       impure X = <initval>,
+%       impure set_<varname>(X).
 % 
 %   :- impure pred pre_initialise_mutable_<varname> is det.
 %   :- pragma foreign_proc("C",
@@ -209,7 +210,8 @@
 %   :- impure pred initialise_mutable_<varname> is det.
 %
 %   initialise_mutable_<varname> :-
-%       impure secret_initialization_only_set_<varname>(<initval>).
+%       impure X = <initval>,
+%       impure secret_initialization_only_set_<varname>(X).
 %
 %-----------------------------------------------------------------------------%
 %
@@ -230,7 +232,8 @@
 %   :- impure pred initialise_mutable_<varname> is det.
 %
 %   initialise_mutable_<varname> :-
-%       impure set_<varname>(<initval>).
+%       impure X = <initval>,
+%       impure set_<varname>(X).
 %
 % <JType> is either `int' or `java.lang.Object' (all other types).
 %
@@ -335,7 +338,8 @@
 %   :- impure pred initialise_mutable_<varname> is det.
 %
 %   initialise_mutable_<varname> :-
-%       impure secret_initialization_only_set_<varname>(<initval>).
+%       impure X = <initval>,
+%       impure secret_initialization_only_set_<varname>(X).
 %
 %-----------------------------------------------------------------------------%
 %
@@ -358,7 +362,8 @@
 %
 %   initialise_mutable_<varname> :-
 %       impure pre_initialise_mutable_<varname>,
-%       impure set_<varname>(<initvalue>).
+%       impure X = <initvalue>,
+%       impure set_<varname>(X).
 %
 %   :- pragma foreign_proc("C#",
 %       pre_initialise_mutable_<varname>,
@@ -407,7 +412,8 @@
 %   :- impure pred initialise_mutable_<varname> is det.
 %
 %   initialise_mutable_<varname> :-
-%       impure set_<varname>(<initval>).
+%       impure X = <initval>,
+%       impure set_<varname>(X).
 %
 %   :- impure pred set_<varname>(<vartype>::in(<varinst>)) is det.
 %   :- pragma foreign_proc("Erlang",
@@ -464,7 +470,8 @@
 %   :- impure pred initialise_mutable_<varname> is det.
 %
 %   initialise_mutable_<varname> :-
-%       impure secret_initialization_only_set_<varname>(<initval>).
+%       impure X = <initval>,
+%       impure secret_initialization_only_set_<varname>(X).
 %
 % The transformation for thread_local mutables has not been decided (we need a
 % way for spawned processes to inherit all the thread-local mutable values of
diff --git a/compiler/purity.m b/compiler/purity.m
index d65957f..7d35a2d 100644
--- a/compiler/purity.m
+++ b/compiler/purity.m
@@ -855,20 +855,20 @@ check_higher_order_purity(GoalInfo, ConsId, Var, Args, ActualPurity, !Info) :-
     % variable's type.
     VarTypes = !.Info ^ pi_vartypes,
     map.lookup(VarTypes, Var, TypeOfVar),
+    PredInfo = !.Info ^ pi_pred_info,
+    pred_info_get_markers(PredInfo, CallerMarkers),
     Context = goal_info_get_context(GoalInfo),
     (
         ConsId = cons(PName, _, _),
         type_is_higher_order_details(TypeOfVar, TypePurity, PredOrFunc,
             _EvalMethod, VarArgTypes)
     ->
-        PredInfo = !.Info ^ pi_pred_info,
         pred_info_get_typevarset(PredInfo, TVarSet),
         pred_info_get_exist_quant_tvars(PredInfo, ExistQTVars),
         pred_info_get_head_type_params(PredInfo, HeadTypeParams),
         map.apply_to_list(Args, VarTypes, ArgTypes0),
         list.append(ArgTypes0, VarArgTypes, PredArgTypes),
         ModuleInfo = !.Info ^ pi_module_info,
-        pred_info_get_markers(PredInfo, CallerMarkers),
         (
             get_pred_id_by_types(calls_are_fully_qualified(CallerMarkers),
                 PName, PredOrFunc, TVarSet, ExistQTVars, PredArgTypes,
@@ -897,8 +897,14 @@ check_higher_order_purity(GoalInfo, ConsId, Var, Args, ActualPurity, !Info) :-
         ( DeclaredPurity = purity_semipure
         ; DeclaredPurity = purity_impure
         ),
-        Spec = impure_unification_expr_error(Context, DeclaredPurity),
-        purity_info_add_message(Spec, !Info)
+        % Don't warn about bogus purity annotations in compiler-generated
+        % mutable predicates.
+        ( check_marker(CallerMarkers, marker_mutable_access_pred) ->
+            true
+        ;
+            Spec = impure_unification_expr_error(Context, DeclaredPurity),
+            purity_info_add_message(Spec, !Info)
+        )
     ;
         DeclaredPurity = purity_pure
     ).
@@ -1034,12 +1040,16 @@ perform_goal_purity_checks(Context, PredId, DeclaredPurity, ActualPurity,
         % We don't warn about exaggerated impurity decls in class methods
         % or instance methods --- it just means that the predicate provided
         % as an implementation was more pure than necessary.
+        % Don't warn about exaggerated impurity decls in compiler-generated
+        % mutable predicates either.
 
         pred_info_get_markers(PredInfo, Markers),
         (
             check_marker(Markers, marker_class_method)
         ;
             check_marker(Markers, marker_class_instance_method)
+        ;
+            check_marker(Markers, marker_mutable_access_pred)
         )
     ->
         true
diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi
index 04938ab..c917eba 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -4795,7 +4795,7 @@ are equivalent to, the builtin insts @samp{free}, @samp{unique},
 
 The initial value of a mutable, @samp{initial_value}, may be any Mercury
 expression with type @samp{vartype} and inst @samp{varinst} subject to
-the above restrictions.
+the above restrictions. It may be impure.
 
 The following @samp{attributes} must be supported:
 
diff --git a/library/thread.mvar.m b/library/thread.mvar.m
index 6da8c96..18b695f 100644
--- a/library/thread.mvar.m
+++ b/library/thread.mvar.m
@@ -33,7 +33,7 @@
 
     % Create an empty mvar.
     %
-:- func mvar.init = (mvar(T)::uo) is det.
+:- impure func mvar.init = (mvar(T)::uo) is det.
 
     % Create an empty mvar.
     %
@@ -84,15 +84,16 @@
                 mutvar(T)   % data
             ).
 
-mvar.init(mvar.init, !IO).
-
-mvar.init = mvar(Full, Empty, Ref) :-
+mvar.init(Mvar, !IO) :-
     promise_pure (
-        Full = semaphore.init(0),
-        Empty = semaphore.init(1),      % Initially a mvar starts empty.
-        impure new_mutvar0(Ref)
+        impure Mvar = mvar.init
     ).
 
+mvar.init = mvar(Full, Empty, Ref) :-
+    impure Full = semaphore.init(0),
+    impure Empty = semaphore.init(1),   % Initially a mvar starts empty.
+    impure new_mutvar0(Ref).
+
 mvar.take(mvar(Full, Empty, Ref), Data, !IO) :-
     promise_pure (
         semaphore.wait(Full, !IO),
diff --git a/library/thread.semaphore.m b/library/thread.semaphore.m
index 6f18517..19c2004 100644
--- a/library/thread.semaphore.m
+++ b/library/thread.semaphore.m
@@ -40,12 +40,12 @@
 
     % Returns a new semaphore `Sem' with its counter initialized to Count.
     %
-:- func semaphore.init(int::in) = (semaphore::uo) is det.
+:- impure func semaphore.init(int::in) = (semaphore::uo) is det.
 
     % A synonym for the above.
     %
 :- pragma obsolete(semaphore.new/1).
-:- func semaphore.new(int::in) = (semaphore::uo) is det.
+:- impure func semaphore.new(int::in) = (semaphore::uo) is det.
 
     % wait(Sem, !IO) blocks until the counter associated with `Sem'
     % becomes greater than 0, whereupon it wakes, decrements the
@@ -118,14 +118,17 @@ ML_finalize_semaphore(void *obj, void *cd);
 new(Semaphore, !IO) :-
     init(Semaphore, !IO).
 
-new(Count) = init(Count).
+new(Count) = Semaphore :-
+    impure Semaphore = init(Count).
 
 init(Semaphore, !IO) :-
-    Semaphore = init(0).
+    promise_pure (
+        impure Semaphore = init(0)
+    ).
 
 :- pragma foreign_proc("C",
     init(Count::in) = (Semaphore::uo),
-    [promise_pure, will_not_call_mercury, thread_safe],
+    [will_not_call_mercury, thread_safe],
 "
     ML_Semaphore    *sem;
 
@@ -155,7 +158,7 @@ init(Semaphore, !IO) :-
 
 :- pragma foreign_proc("C#",
     init(Count::in) = (Semaphore::uo),
-    [promise_pure, will_not_call_mercury, thread_safe],
+    [will_not_call_mercury, thread_safe],
 "
     Semaphore = new thread__semaphore.ML_Semaphore();
     Semaphore.count = Count;
@@ -163,7 +166,7 @@ init(Semaphore, !IO) :-
 
 :- pragma foreign_proc("Java",
     init(Count::in) = (Semaphore::uo),
-    [promise_pure, will_not_call_mercury, thread_safe],
+    [will_not_call_mercury, thread_safe],
 "
     Semaphore = new java.util.concurrent.Semaphore(Count);
 ").
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 05af31d..9a785a6 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -184,6 +184,7 @@ ORDINARY_PROGS=	\
 	multi_map_test \
 	multimode \
 	multimode_addr \
+	mutable_init_impure \
 	mutable_init_order \
 	myset_test \
 	name_mangling \
diff --git a/tests/hard_coded/mutable_init_impure.exp b/tests/hard_coded/mutable_init_impure.exp
new file mode 100644
index 0000000..a9d787c
--- /dev/null
+++ b/tests/hard_coded/mutable_init_impure.exp
@@ -0,0 +1 @@
+Success.
diff --git a/tests/hard_coded/mutable_init_impure.m b/tests/hard_coded/mutable_init_impure.m
new file mode 100644
index 0000000..8ed82b8
--- /dev/null
+++ b/tests/hard_coded/mutable_init_impure.m
@@ -0,0 +1,35 @@
+% Test initialisation of mutables by impure functions.
+
+:- module mutable_init_impure.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module thread.
+:- import_module thread.semaphore.
+
+:- mutable(sem1, semaphore, init_sem, ground, [untrailed, attach_to_io_state]).
+:- mutable(sem2, semaphore, init_sem, ground, [untrailed, constant]).
+
+:- impure func init_sem = semaphore.
+
+init_sem = Sem :-
+    impure Sem = semaphore.init(1).
+
+main(!IO) :-
+    get_sem1(Sem1, !IO),
+    semaphore.wait(Sem1, !IO),
+
+    get_sem2(Sem2),
+    semaphore.wait(Sem2, !IO),
+
+    io.write_string("Success.\n", !IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et

--------------------------------------------------------------------------
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
--------------------------------------------------------------------------



More information about the reviews mailing list