:- module store. :- use_module builtin, io, private_builtin, std_util. :- type (store:store(S)) ---> store((builtin:c_pointer)) . :- type (store:some_store_type) ---> some_store_type . :- type (store:generic_ref(T, S)) ---> ref((builtin:c_pointer)) . :- type (store:generic_mutvar(T, S)) ---> mutvar((builtin:c_pointer)) . :- typeclass store:store(T) where [ ]. :- instance (store:store(store : store(S))) where [ ]. :- instance (store:store(io : state)) where [ ]. :- pragma foreign_import_module("C", store). :- pred store:do_init((store:store((store:some_store_type)))). :- mode store:do_init((builtin:uo)) is det. :- pred store:unsafe_new_uninitialized_mutvar((store:generic_mutvar(T, S)), S, S) <= (store:store(S)). :- mode store:unsafe_new_uninitialized_mutvar((builtin:out), (builtin:di), (builtin:uo)) is det. :- pred store:unsafe_ref_value((store:generic_ref(T, S)), T, S, S) <= (store:store(S)). :- mode store:unsafe_ref_value((builtin:in), (builtin:uo), (builtin:di), (builtin:uo)) is det. store:new(S_2) :- store:do_init(S_2). :- pragma foreign_proc("C", store:new_mutvar(Val :: (builtin:in), Mutvar :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " MR_incr_hp_msg(Mutvar, 1, MR_PROC_LABEL, \"store:mutvar/2\"); * (MR_Word *) Mutvar = Val; S = S0; "). :- pragma foreign_proc("C", store:get_mutvar(Mutvar :: (builtin:in), Val :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " Val = * (MR_Word *) Mutvar; S = S0; "). :- pragma foreign_proc("C", store:set_mutvar(Mutvar :: (builtin:in), Val :: (builtin:in), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " * (MR_Word *) Mutvar = Val; S = S0; "). store:new_cyclic_mutvar(Func_5, MutVar_6, DCG_0_8, DCG_2_10) :- store:unsafe_new_uninitialized_mutvar(MutVar_6, DCG_0_8, DCG_1_9), Value_7 = apply(Func_5, MutVar_6), store:set_mutvar(MutVar_6, Value_7, DCG_1_9, DCG_2_10). :- pragma foreign_proc("C", store:new_ref(Val :: (builtin:di), Ref :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " MR_incr_hp_msg(Ref, 1, MR_PROC_LABEL, \"store:ref/2\"); * (MR_Word *) Ref = Val; S = S0; "). store:ref_functor(Ref_6, Functor_7, Arity_8, DCG_0_10, DCG_1_11) :- store:unsafe_ref_value(Ref_6, Val_9, DCG_0_10, DCG_1_11), std_util:functor(Val_9, Functor_7, Arity_8). :- pragma foreign_proc("C", store:arg_ref(Ref :: (builtin:in), ArgNum :: (builtin:in), ArgRef :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], "{ MR_TypeInfo type_info; MR_TypeInfo arg_type_info; MR_TypeInfo exp_arg_type_info; MR_Word *arg_ref; type_info = (MR_TypeInfo) TypeInfo_for_T; exp_arg_type_info = (MR_TypeInfo) TypeInfo_for_ArgT; MR_save_transient_registers(); if (!MR_arg(type_info, (MR_Word *) Ref, ArgNum, &arg_type_info, &arg_ref, MR_NONCANON_ABORT)) { MR_fatal_error( \"store__arg_ref: argument number out of range\"); } if (MR_compare_type_info(arg_type_info, exp_arg_type_info) != MR_COMPARE_EQUAL) { MR_fatal_error(\"store__arg_ref: argument has wrong type\"); } MR_restore_transient_registers(); ArgRef = (MR_Word) arg_ref; S = S0; }"). :- pragma foreign_proc("C", store:new_arg_ref(Val :: (builtin:di), ArgNum :: (builtin:in), ArgRef :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], "{ MR_TypeInfo type_info; MR_TypeInfo arg_type_info; MR_TypeInfo exp_arg_type_info; MR_Word *arg_ref; type_info = (MR_TypeInfo) TypeInfo_for_T; exp_arg_type_info = (MR_TypeInfo) TypeInfo_for_ArgT; MR_save_transient_registers(); if (!MR_arg(type_info, (MR_Word *) &Val, ArgNum, &arg_type_info, &arg_ref, MR_NONCANON_ABORT)) { MR_fatal_error( \"store__new_arg_ref: argument number out of range\"); } if (MR_compare_type_info(arg_type_info, exp_arg_type_info) != MR_COMPARE_EQUAL) { MR_fatal_error( \"store__new_arg_ref: argument has wrong type\"); } MR_restore_transient_registers(); /* ** For no_tag types, the argument may have the same address as the ** term. Since the term (Val) is currently on the C stack, we can\'t ** return a pointer to it; so if that is the case, then we need ** to copy it to the heap before returning. */ if (arg_ref == &Val) { MR_incr_hp_msg(ArgRef, 1, MR_PROC_LABEL, \"store:ref/2\"); * (MR_Word *) ArgRef = Val; } else { ArgRef = (MR_Word) arg_ref; } S = S0; }"). :- pragma foreign_proc("C", store:set_ref(Ref :: (builtin:in), ValRef :: (builtin:in), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " * (MR_Word *) Ref = * (MR_Word *) ValRef; S = S0; "). :- pragma foreign_proc("C", store:set_ref_value(Ref :: (builtin:in), Val :: (builtin:di), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " * (MR_Word *) Ref = Val; S = S0; "). store:copy_ref_value(Ref_5, Val_6, DCG_0_7, DCG_1_8) :- store:unsafe_ref_value(Ref_5, Val_6, DCG_0_7, DCG_1_8). :- pragma foreign_proc("C", store:extract_ref_value(_S :: (builtin:di), Ref :: (builtin:in), Val :: (builtin:out)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " Val = * (MR_Word *) Ref; "). :- pragma foreign_proc("C", store:unsafe_arg_ref(Ref :: (builtin:in), Arg :: (builtin:in), ArgRef :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], "{ /* unsafe - does not check type & arity, won\'t handle no_tag types */ MR_Word *Ptr = (MR_Word *) MR_strip_tag((MR_Word) Ref); ArgRef = (MR_Word) &Ptr[Arg]; S = S0; }"). :- pragma foreign_proc("C", store:unsafe_new_arg_ref(Val :: (builtin:di), Arg :: (builtin:in), ArgRef :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], "{ /* unsafe - does not check type & arity, won\'t handle no_tag types */ MR_Word *Ptr = (MR_Word *) MR_strip_tag((MR_Word) Val); ArgRef = (MR_Word) &Ptr[Arg]; S = S0; }"). store:init(S_2) :- store:do_init(S_2). :- pragma foreign_proc("C", store:do_init(_S0 :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], ""). :- pragma foreign_proc("C", store:unsafe_new_uninitialized_mutvar(Mutvar :: (builtin:out), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " MR_incr_hp_msg(Mutvar, 1, MR_PROC_LABEL, \"store:mutvar/2\"); S = S0; "). :- pragma foreign_proc("C", store:unsafe_ref_value(Ref :: (builtin:in), Val :: (builtin:uo), S0 :: (builtin:di), S :: (builtin:uo)), [will_not_call_mercury, not_thread_safe, not_tabled_for_io, promise_pure], " Val = * (MR_Word *) Ref; S = S0; "). :- pragma termination_info(store:new((builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:new_mutvar((builtin:in), (builtin:out), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:get_mutvar((builtin:in), (builtin:out), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:set_mutvar((builtin:in), (builtin:in), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:new_cyclic_mutvar((builtin:in), (builtin:out), (builtin:di), (builtin:uo)), infinite, can_loop). :- pragma termination_info(store:new_ref((builtin:di), (builtin:out), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:ref_functor((builtin:in), (builtin:out), (builtin:out), (builtin:di), (builtin:uo)), infinite, can_loop). :- pragma termination_info(store:arg_ref((builtin:in), (builtin:in), (builtin:out), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:new_arg_ref((builtin:di), (builtin:in), (builtin:out), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:set_ref((builtin:in), (builtin:in), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:set_ref_value((builtin:in), (builtin:di), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:copy_ref_value((builtin:in), (builtin:uo), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:extract_ref_value((builtin:di), (builtin:in), (builtin:out)), infinite, cannot_loop). :- pragma termination_info(store:unsafe_arg_ref((builtin:in), (builtin:in), (builtin:out), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:unsafe_new_arg_ref((builtin:di), (builtin:in), (builtin:out), (builtin:di), (builtin:uo)), infinite, cannot_loop). :- pragma termination_info(store:init((builtin:uo)), infinite, cannot_loop).