[m-rev.] for review: Aditi and `--highlevel-code'
Simon Taylor
stayl at cs.mu.OZ.AU
Wed Mar 5 00:34:45 AEDT 2003
Estimated hours taken: 80
Branches: main
Make Aditi work with `--highlevel-code'.
(Note that this doesn't work with the current CVS version
of Aditi. The Aditi developers have rewritten the Aditi client
API, and haven't maintained the old version of the API, so Mercury
queries don't work at the moment. extras/aditi will be updated to
use the new interface as a separate change.)
extras/aditi/aditi_private_builtin.m:
extras/aditi/aditi.m:
Move code to implement Aditi calls and updates into
a aditi_private_builtin.m. These operations are now
implemented using ordinary Mercury foreign procedures,
rather than hand-coded C modules.
compiler/magic.m:
Use calls to ordinary calls to predicates defined in
extras/aditi/aditi_private_builtin.m to implement the
procedures which interface between top-down Mercury
code and Aditi procedures.
compiler/aditi_backend.pp:
compiler/aditi_builtin_ops.m:
compiler/mercury_compile.m:
compiler/notes/compiler_design.html:
Add a pass to convert Aditi builtins (calls and updates)
into ordinary calls to predicates defined in
extras/aditi/aditi_private_builtin.m.
compiler/hlds_goal.m:
compiler/hlds_pred.m:
Add a new generic_call type -- `unsafe_cast'.
aditi_builtin_ops.m needs to be able to cast
closures from one type and inst to another.
Delete the `aditi_call' alternative for `aditi_builtin',
which is not needed after the change to magic.m described
above.
Add predicates `construct_tuple' and `deconstruct_tuple'.
compiler/*hlds.*.m:
compiler/call_gen.m:
compiler/ml_call_gen.m:
Handle unsafe cast goals.
compiler/common.m:
compiler/higher_order.m:
compiler/unify_proc.m:
Generate unsafe_cast goals instead of calls to
private_builtin.unsafe_type_cast.
compiler/purity.m:
Convert calls to private_builtin.unsafe_type_cast into
unsafe_cast goals.
compiler/ml_code_gen.m:
Don't attempt to generate code for Aditi procedures.
Remove special case handling of calls to
private_builtin.unsafe_type_cast -- such
calls are now transformed away.
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
compiler/maybe_mlds_to_gcc.m:
Add the RL code to the generated C file.
compiler/llds_out.m:
compiler/c_util.m:
compiler/compile_target_code.m:
Move code to generate a `.rlo' file and work out the
name of the RL constant embeeded in the C file for
a module into c_util.m, for use by the MLDS backend.
compiler/modules.m:
Automatically import aditi_private_builtin when compiling
with `--aditi'.
We generate a C constant for the RL code for each module,
so modules compiled with `--aditi' need to be treated
by the build system as if they contain foreign code.
compiler/polymorphism.m:
Tuple insertion and deletion no longer need special treatment.
compiler/llds.m:
compiler/ll_backend.*.m:
Delete the Aditi alternatives of the `code_addr' type.
compiler/mode_util.m:
Add function versions of in_mode, out_mode, etc.
compiler/prog_util.m:
Add aditi_public_builtin_module (returns `aditi') and
aditi_private_builtin_module (returns `aditi_private_builtin').
tests/valid/aditi_private_builtin.m:
tests/invalid/aditi_private_builtin.m:
tests/valid/Mercury.options:
tests/invalid/Mercury.options:
Add a cut down version of extras/aditi/aditi_private_builtin.m
for use in running the tests.
Index: compiler/aditi_backend.pp
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/aditi_backend.pp,v
retrieving revision 1.1
diff -u -u -r1.1 aditi_backend.pp
--- compiler/aditi_backend.pp 26 Jul 2002 09:06:49 -0000 1.1
+++ compiler/aditi_backend.pp 4 Mar 2003 05:20:37 -0000
@@ -21,6 +21,7 @@
:- include_module dnf.
:- include_module magic, magic_util.
:- include_module context.
+ :- include_module aditi_builtin_ops.
%:- end_module aditi_hlds.
%
Index: compiler/aditi_builtin_ops.m
===================================================================
RCS file: compiler/aditi_builtin_ops.m
diff -N compiler/aditi_builtin_ops.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/aditi_builtin_ops.m 3 Mar 2003 14:58:40 -0000
@@ -0,0 +1,703 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2003 University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+% File: aditi_builtin_ops.m
+% Main author: stayl
+%
+% Transform Aditi builtin generic_call goals into calls to
+% the predicates in extras/aditi/aditi_private_builtin.m.
+%
+%-----------------------------------------------------------------------------%
+:- module aditi_backend__aditi_builtin_ops.
+
+:- interface.
+
+:- import_module hlds__hlds_module, hlds__hlds_pred.
+:- import_module io.
+
+ % Transform Aditi builtin generic_call goals into calls to
+ % the predicates in extras/aditi/aditi_private_builtin.m.
+:- pred transform_aditi_builtins(module_info, module_info,
+ io__state, io__state).
+:- mode transform_aditi_builtins(in, out, di, uo) is det.
+
+ % Change the goal for the given procedure to call the
+ % corresponding Aditi procedure.
+:- pred create_aditi_call_proc(pred_proc_id, module_info, module_info).
+:- mode create_aditi_call_proc(in, in, out) is det.
+
+%-----------------------------------------------------------------------------%
+:- implementation.
+
+:- import_module aditi_backend__rl.
+:- import_module hlds__hlds_goal, hlds__hlds_data, hlds__instmap.
+:- import_module hlds__quantification, hlds__passes_aux.
+:- import_module check_hlds__mode_util, check_hlds__type_util.
+:- import_module check_hlds__polymorphism.
+:- import_module parse_tree__prog_data, parse_tree__prog_util.
+:- import_module parse_tree__prog_out, parse_tree__inst.
+
+:- import_module assoc_list, bool, int, list, map.
+:- import_module require, set, string, std_util, term.
+
+transform_aditi_builtins(ModuleInfo0, ModuleInfo) -->
+ passes_aux__process_all_nonimported_nonaditi_procs(
+ update_module_io(transform_aditi_builtins_in_proc), _,
+ ModuleInfo0, ModuleInfo).
+
+:- pred transform_aditi_builtins_in_proc(pred_id, proc_id,
+ proc_info, proc_info, module_info, module_info,
+ io__state, io__state).
+:- mode transform_aditi_builtins_in_proc(in, in, in, out,
+ in, out, di, uo) is det.
+
+transform_aditi_builtins_in_proc(PredId, _ProcId, ProcInfo0, ProcInfo,
+ ModuleInfo0, ModuleInfo, IO, IO) :-
+ proc_info_goal(ProcInfo0, Goal0),
+ construct_aditi_transform_info(ModuleInfo0, PredId, ProcInfo0,
+ Info0),
+ transform_aditi_builtins_in_goal(Goal0, Goal, Info0, Info),
+ deconstruct_aditi_transform_info(Info, PredId,
+ ModuleInfo1, ProcInfo1, Changed),
+ ( Changed = yes ->
+ proc_info_set_goal(ProcInfo1, Goal, ProcInfo2),
+ requantify_proc(ProcInfo2, ProcInfo3),
+ recompute_instmap_delta_proc(yes, ProcInfo3, ProcInfo,
+ ModuleInfo1, ModuleInfo)
+ ;
+ ProcInfo = ProcInfo1,
+ ModuleInfo = ModuleInfo1
+ ).
+
+:- pred transform_aditi_builtins_in_goal(hlds_goal, hlds_goal,
+ aditi_transform_info, aditi_transform_info).
+:- mode transform_aditi_builtins_in_goal(in, out, in, out) is det.
+
+transform_aditi_builtins_in_goal(Goal0 - GoalInfo, Goal - GoalInfo) -->
+ transform_aditi_builtins_in_goal_expr(Goal0, GoalInfo, Goal).
+
+:- pred transform_aditi_builtins_in_goal_expr(hlds_goal_expr, hlds_goal_info,
+ hlds_goal_expr, aditi_transform_info, aditi_transform_info).
+:- mode transform_aditi_builtins_in_goal_expr(in, in, out, in, out) is det.
+
+transform_aditi_builtins_in_goal_expr(Goal0, GoalInfo, Goal) -->
+ { Goal0 = unify(_, _, _, Unification, _) },
+ (
+ { Unification = construct(Var, ConsId, Args, _, _, _, _) },
+ { ConsId = pred_const(PredId, ProcId, aditi_bottom_up) }
+ ->
+ ^ changed := yes,
+ transform_aditi_bottom_up_closure(Var, PredId, ProcId,
+ Args, GoalInfo, Goal)
+ ;
+ { Goal = Goal0 }
+ ).
+transform_aditi_builtins_in_goal_expr(Goal0, GoalInfo, Goal) -->
+ { Goal0 = generic_call(Call, Args, Modes, Det) },
+ (
+ { Call = higher_order(_, _, _, _) },
+ { Goal = Goal0 }
+ ;
+ { Call = class_method(_, _, _, _) },
+ { Goal = Goal0 }
+ ;
+ { Call = unsafe_cast },
+ { Goal = Goal0 }
+ ;
+ { Call = aditi_builtin(Builtin0, _) },
+ ^ changed := yes,
+ transform_aditi_builtin(Builtin0, Args, Modes, Det,
+ GoalInfo, Goal)
+ ).
+transform_aditi_builtins_in_goal_expr(conj(Goals0), _, conj(Goals)) -->
+ list__map_foldl(transform_aditi_builtins_in_goal, Goals0, Goals).
+transform_aditi_builtins_in_goal_expr(disj(Goals0), _, disj(Goals)) -->
+ list__map_foldl(transform_aditi_builtins_in_goal, Goals0, Goals).
+transform_aditi_builtins_in_goal_expr(par_conj(Goals0), _, par_conj(Goals)) -->
+ list__map_foldl(transform_aditi_builtins_in_goal, Goals0, Goals).
+transform_aditi_builtins_in_goal_expr(
+ if_then_else(Vars, Cond0, Then0, Else0),
+ _, if_then_else(Vars, Cond, Then, Else)) -->
+ transform_aditi_builtins_in_goal(Cond0, Cond),
+ transform_aditi_builtins_in_goal(Then0, Then),
+ transform_aditi_builtins_in_goal(Else0, Else).
+transform_aditi_builtins_in_goal_expr(switch(Var, CanFail, Cases0), _,
+ switch(Var, CanFail, Cases)) -->
+ list__map_foldl(
+ (pred(Case0::in, Case::out, in, out) is det -->
+ { Case0 = case(ConsId, Goal0) },
+ transform_aditi_builtins_in_goal(Goal0, Goal),
+ { Case = case(ConsId, Goal) }
+ ), Cases0, Cases).
+transform_aditi_builtins_in_goal_expr(not(Goal0), _, not(Goal)) -->
+ transform_aditi_builtins_in_goal(Goal0, Goal).
+transform_aditi_builtins_in_goal_expr(some(A, B, Goal0), _,
+ some(A, B, Goal)) -->
+ transform_aditi_builtins_in_goal(Goal0, Goal).
+transform_aditi_builtins_in_goal_expr(Goal, _, Goal) -->
+ { Goal = foreign_proc(_, _, _, _, _, _, _) }.
+transform_aditi_builtins_in_goal_expr(Goal, _, Goal) -->
+ { Goal = call(_, _, _, _, _, _) }.
+transform_aditi_builtins_in_goal_expr(shorthand(_), _, _) -->
+ { error("transform_aditi_builtins_in_goal_expr: shorthand") }.
+
+:- pred transform_aditi_bottom_up_closure(prog_var, pred_id, proc_id,
+ list(prog_var), hlds_goal_info, hlds_goal_expr,
+ aditi_transform_info, aditi_transform_info).
+:- mode transform_aditi_bottom_up_closure(in, in, in, in, in,
+ out, in, out) is det.
+
+transform_aditi_bottom_up_closure(Var, PredId, ProcId, Args,
+ _GoalInfo, Goal) -->
+ %
+ % Transform a closure
+ %
+ % Var = (aditi_bottom_up pred(DB::aditi_mui, X::out, ...) is nondet :-
+ % p(NonLocal1, NonLocal2, ..., DB, X, ...)
+ % )
+ %
+ % into
+ %
+ % ProcName = "<RL proc name for p>",
+ % InputSchema = "<RL input schema for p>",
+ % InputTuple = <tuple of InputArgs>,
+ % TypeInfo = <type-info for InputTuple>,
+ % NewVar = (pred(Relation::out) is det :-
+ % aditi_private_builtin__do_call_returning_relation(TypeInfo,
+ % ProcName, InputSchema, InputTuple, Relation)
+ % ),
+ % unsafe_cast(NewVar, Var).
+ %
+ % The code to transform bulk updates below will cast the closure
+ % back to its real type (pred(c_pointer::out) is det) before
+ % passing it to `aditi_private_builtin__do_bulk_*'.
+ %
+
+ create_bulk_update_closure_var(NewVar),
+ ProcInfo =^ proc_info,
+ { proc_info_vartypes(ProcInfo, VarTypes) },
+ { map__apply_to_list(Args, VarTypes, InputTupleTypes) },
+
+ ModuleInfo0 =^ module_info,
+ { lookup_builtin_pred_proc_id(ModuleInfo0,
+ aditi_private_builtin_module, "do_call_returning_relation", 4,
+ only_mode, BuiltinPredId, BuiltinProcId) },
+
+ %
+ % Build the input arguments describing the procedure to call.
+ %
+ { rl__get_c_interface_rl_proc_name(ModuleInfo0,
+ proc(PredId, ProcId), RLProcName) },
+ { rl__proc_name_to_string(RLProcName, RLProcNameStr) },
+ { rl__schema_to_string(ModuleInfo0, InputTupleTypes, InputSchema) },
+ { ConstArgs = [string(RLProcNameStr), string(InputSchema)] },
+ generate_const_args(ConstArgs, ConstArgVars, ConstArgGoals),
+
+ %
+ % Build the vectors of input arguments and type-infos.
+ %
+ handle_input_tuple(Args, InputTupleVar, InputTupleTypeInfo,
+ TupleGoals),
+
+ { BuiltinArgs = list__append([InputTupleTypeInfo | ConstArgVars],
+ [InputTupleVar]) },
+ { list__length(BuiltinArgs, NumBuiltinArgs) },
+
+ { Functor = cons(qualified(aditi_private_builtin_module,
+ "do_call_returning_relation"), 5) },
+ { Rhs = functor(Functor, no, BuiltinArgs) },
+
+ { UniMode = ((free_inst - ground_inst) ->
+ (ground_inst - ground_inst)) },
+ { list__duplicate(NumBuiltinArgs, UniMode, UniModes) },
+ { BuiltinConsId = pred_const(BuiltinPredId, BuiltinProcId, normal) },
+ { ExprnId = no },
+ { Unification = construct(NewVar, BuiltinConsId, BuiltinArgs,
+ UniModes, construct_dynamically,
+ cell_is_unique, ExprnId) },
+ { set__list_to_set([NewVar | BuiltinArgs], NonLocals) },
+ { instmap_delta_from_assoc_list([NewVar - ground_inst],
+ InstMapDelta) },
+ { goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo) },
+ { UnifyMode = out_mode - in_mode },
+ { UnifyContext = unify_context(explicit, []) },
+ { UnifyGoal = unify(NewVar, Rhs, UnifyMode,
+ Unification, UnifyContext) - GoalInfo },
+
+ %
+ % Change the import_status to exported, so dead_proc_elim.m
+ % will not attempt to remove the predicate after the reference
+ % to it is transformed away here.
+ %
+ ModuleInfo1 =^ module_info,
+ { module_info_pred_proc_info(ModuleInfo1, PredId, ProcId,
+ CalleePredInfo0, CalleeProcInfo) },
+ { pred_info_import_status(CalleePredInfo0, CalleeStatus) },
+ (
+ { status_defined_in_this_module(CalleeStatus, yes) },
+ \+ { hlds_pred__pred_info_is_base_relation(CalleePredInfo0) }
+ ->
+ { pred_info_set_import_status(CalleePredInfo0,
+ exported, CalleePredInfo) },
+ { module_info_set_pred_info(ModuleInfo1, PredId,
+ CalleePredInfo, ModuleInfo) },
+ ^ module_info := ModuleInfo
+ ;
+ { CalleePredInfo = CalleePredInfo0 }
+ ),
+
+ %
+ % Cast the closure to the type and inst of the original closure,
+ % so that the HLDS is still type and mode correct.
+ %
+ { pred_info_get_is_pred_or_func(CalleePredInfo, CalleePredOrFunc) },
+ { proc_info_argmodes(CalleeProcInfo, CalleeArgModes) },
+ {
+ list__drop(list__length(Args), CalleeArgModes,
+ NonCurriedArgModes0)
+ ->
+ NonCurriedArgModes = NonCurriedArgModes0
+ ;
+ error("transform_aditi_bottom_up_closure: list__drop failed")
+ },
+ { proc_info_interface_determinism(CalleeProcInfo, CalleeDetism) },
+ { CastOutputInst = ground(shared,
+ higher_order(pred_inst_info(CalleePredOrFunc,
+ NonCurriedArgModes, CalleeDetism))) },
+
+ { CastInputInst = ground(shared,
+ higher_order(pred_inst_info(predicate,
+ [out_mode], det))) },
+ { CastModes = [(CastInputInst -> CastInputInst),
+ (free_inst -> CastOutputInst)] },
+ { CastGoal = generic_call(unsafe_cast, [NewVar, Var],
+ CastModes, det) - GoalInfo },
+
+ { Goals = list__condense([ConstArgGoals, TupleGoals,
+ [UnifyGoal, CastGoal]]) },
+ { Goal = conj(Goals) }.
+
+:- pred transform_aditi_builtin(aditi_builtin, list(prog_var),
+ list(mode), determinism, hlds_goal_info, hlds_goal_expr,
+ aditi_transform_info, aditi_transform_info).
+:- mode transform_aditi_builtin(in, in, in, in, in, out, in, out) is det.
+
+transform_aditi_builtin(Builtin, Args, Modes, Det, GoalInfo, Goal) -->
+ ModuleInfo =^ module_info,
+ { aditi_builtin_info(ModuleInfo, Builtin,
+ BuiltinProcName, BuiltinProcArity, ConstArgs) },
+ { lookup_builtin_pred_proc_id(ModuleInfo, aditi_private_builtin_module,
+ BuiltinProcName, BuiltinProcArity, only_mode,
+ PredId, ProcId) },
+ generate_const_args(ConstArgs, ConstArgVars, ConstArgGoals),
+ transform_aditi_builtin_2(Builtin, Args, Modes, Det,
+ GoalInfo, proc(PredId, ProcId),
+ qualified(aditi_private_builtin_module, BuiltinProcName),
+ ConstArgVars, CallGoals),
+ { list__append(ConstArgGoals, CallGoals, Goals) },
+ { conj_list_to_goal(Goals, GoalInfo, Goal - _) }.
+
+
+:- pred transform_aditi_builtin_2(aditi_builtin, list(prog_var),
+ list(mode), determinism, hlds_goal_info, pred_proc_id,
+ sym_name, list(prog_var), list(hlds_goal),
+ aditi_transform_info, aditi_transform_info).
+:- mode transform_aditi_builtin_2(in, in, in, in, in, in, in, in,
+ out, in, out) is det.
+
+transform_aditi_builtin_2(aditi_tuple_insert_delete(_, _),
+ Args0, _Modes0, _Det, _GoalInfo, BuiltinPredProcId,
+ BuiltinSymName, ConstArgs, Goals) -->
+
+ { get_state_args_det(Args0, TupleArgs0, State0Arg, StateArg) },
+ ProcInfo =^ proc_info,
+ { proc_info_vartypes(ProcInfo, VarTypes) },
+ { map__apply_to_list(TupleArgs0, VarTypes, TupleTypes0) },
+
+ % Remove the `aditi__state' from the list of arguments.
+ { type_util__remove_aditi_state(TupleTypes0, TupleArgs0, TupleArgs) },
+
+ %
+ % Produce code to create the vectors of type-infos and arguments
+ % for the tuple.
+ %
+ handle_input_tuple(TupleArgs, InputTuple,
+ InputTupleTypeInfo, TupleGoals),
+
+ % Produce the call
+ % aditi_private_builtin__do_insert_tuple(InputTupleTypeInfo,
+ % RelationName, InputTuple, State0, State)
+ %
+ % or
+ %
+ % aditi_private_builtin__do_insert_tuple(InputTupleTypeInfo,
+ % RelationName, DeleteProc, DeleteProcInputSchema,
+ % InputTuple, State0, State)
+ %
+ { list__append([InputTupleTypeInfo | ConstArgs],
+ [InputTuple, State0Arg, StateArg], CallArgs) },
+ { BuiltinPredProcId = proc(BuiltinPredId, BuiltinProcId) },
+
+ { set__list_to_set(CallArgs, NonLocals) },
+ { instmap_delta_from_assoc_list([StateArg - ground_inst],
+ InstMapDelta) },
+ { goal_info_init(NonLocals, InstMapDelta, det, pure, CallGoalInfo) },
+ { CallGoal = call(BuiltinPredId, BuiltinProcId, CallArgs,
+ not_builtin, no, BuiltinSymName) - CallGoalInfo },
+
+ { Goals = list__append(TupleGoals, [CallGoal]) }.
+
+transform_aditi_builtin_2(
+ aditi_insert_delete_modify(Op, PredId, _),
+ Args, _Modes, _Det, _GoalInfo, BuiltinPredProcId,
+ BuiltinSymName, ConstArgs, Goals) -->
+
+ { Args = [Closure0, State0Arg0, StateArg0] ->
+ Closure = Closure0,
+ State0Arg = State0Arg0,
+ StateArg = StateArg0
+ ;
+ error(
+ "transform_aditi_builtin_2: wrong number of arguments in bulk update")
+ },
+
+ create_bulk_update_closure_var(CastClosure),
+
+ %
+ % Cast the closure to the type expected by the predicate
+ % to perform the update in aditi_private_builtin.m
+ %
+ ModuleInfo =^ module_info,
+ { module_info_pred_info(ModuleInfo, PredId, PredInfo) },
+ { pred_info_arg_types(PredInfo, ArgTypes) },
+ { pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
+ { list__length(ArgTypes, PredArity) },
+ {
+ Op = delete(_),
+ ClosurePredOrFunc = PredOrFunc,
+ ClosureArity = PredArity
+ ;
+ Op = bulk_insert,
+ ClosurePredOrFunc = PredOrFunc,
+ ClosureArity = PredArity
+ ;
+ Op = modify(_),
+ ClosurePredOrFunc = predicate,
+ ClosureArity = PredArity * 2
+ },
+ { list__duplicate(ClosureArity, out_mode, ClosureModes) },
+
+ { CastInputInst = ground(shared,
+ higher_order(pred_inst_info(ClosurePredOrFunc,
+ ClosureModes, nondet))) },
+ { CastOutputInst = ground(shared,
+ higher_order(pred_inst_info(predicate, [out_mode], det))) },
+ { CastModes = [(CastInputInst -> CastInputInst),
+ (free_inst -> CastOutputInst)] },
+
+ { set__list_to_set([Closure, CastClosure], NonLocals) },
+ { instmap_delta_from_assoc_list([CastClosure - CastOutputInst],
+ InstMapDelta) },
+ { goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo) },
+ { CastGoal = generic_call(unsafe_cast, [Closure, CastClosure],
+ CastModes, det) - GoalInfo },
+
+ % Produce the call
+ % aditi_private_builtin__do_bulk_*(RelationName, UpdateProc,
+ % Closure, State0, State)
+ %
+
+ { list__append(ConstArgs, [CastClosure, State0Arg, StateArg],
+ CallArgs) },
+
+ { BuiltinPredProcId = proc(BuiltinPredId, BuiltinProcId) },
+ { CallGoal = call(BuiltinPredId, BuiltinProcId, CallArgs, not_builtin,
+ no, BuiltinSymName) - GoalInfo },
+
+ { Goals = [CastGoal, CallGoal] }.
+
+create_aditi_call_proc(PredProcId, ModuleInfo0, ModuleInfo) :-
+ module_info_pred_proc_info(ModuleInfo0, PredProcId,
+ PredInfo0, ProcInfo0),
+ rl__get_c_interface_rl_proc_name(ModuleInfo0, PredProcId, ProcName),
+ rl__proc_name_to_string(ProcName, ProcNameStr),
+ Changed = no,
+ Info0 = aditi_transform_info(ModuleInfo0,
+ PredInfo0, ProcInfo0, Changed),
+ proc_info_headvars(ProcInfo0, HeadVars),
+ proc_info_argmodes(ProcInfo0, ArgModes),
+ proc_info_interface_determinism(ProcInfo0, Det),
+ create_aditi_call_goal(ProcNameStr, HeadVars, ArgModes, Det, Goal,
+ Info0, Info),
+ Info = aditi_transform_info(ModuleInfo1, PredInfo, ProcInfo1, _),
+ proc_info_set_goal(ProcInfo1, Goal, ProcInfo2),
+ requantify_proc(ProcInfo2, ProcInfo3),
+ recompute_instmap_delta_proc(yes, ProcInfo3, ProcInfo,
+ ModuleInfo1, ModuleInfo2),
+ module_info_set_pred_proc_info(ModuleInfo2,
+ PredProcId, PredInfo, ProcInfo, ModuleInfo).
+
+ %
+ % Produce the call
+ % aditi_private_builtin__do_*_call(InputTupleTypeInfo,
+ % OutputTupleTypeInfo, ProcName, NumInputs, InputSchema,
+ % NumOutputs, InputTuple, OutputTuple).
+ %
+:- pred create_aditi_call_goal(string, list(prog_var), list(mode), determinism,
+ hlds_goal, aditi_transform_info, aditi_transform_info).
+:- mode create_aditi_call_goal(in, in, in, in, out, in, out) is det.
+
+create_aditi_call_goal(ProcName, HeadVars0, ArgModes0, Det, Goal) -->
+ ProcInfo0 =^ proc_info,
+ ModuleInfo0 =^ module_info,
+
+ { Det = det, Proc = "do_det_call"
+ ; Det = semidet, Proc = "do_semidet_call"
+ ; Det = nondet, Proc = "do_nondet_call"
+ ; Det = multidet, Proc = "do_multi_call"
+ ; Det = cc_nondet, Proc = "do_cc_nondet_call"
+ ; Det = cc_multidet, Proc = "do_cc_multi_call"
+ ; Det = failure, Proc = "do_failure_call"
+ ; Det = erroneous, Proc = "do_erroneous_call"
+ },
+ { lookup_builtin_pred_proc_id(ModuleInfo0,
+ aditi_private_builtin_module, Proc, 4, only_mode,
+ BuiltinPredId, BuiltinProcId) },
+ { BuiltinSymName = qualified(aditi_private_builtin_module, Proc) },
+
+ { proc_info_vartypes(ProcInfo0, VarTypes) },
+ { map__apply_to_list(HeadVars0, VarTypes, ArgTypes0) },
+
+ %
+ % Remove `aditi__state' arguments -- they do not appear as attributes
+ % in Aditi relations.
+ %
+ { type_util__remove_aditi_state(ArgTypes0, ArgModes0, ArgModes) },
+ { type_util__remove_aditi_state(ArgTypes0, HeadVars0, HeadVars) },
+ { partition_args(ModuleInfo0, ArgModes, HeadVars,
+ InputArgs, OutputArgs) },
+
+ %
+ % Generate arguments to describe the procedure to call.
+ %
+ { map__apply_to_list(InputArgs, VarTypes, InputTypes) },
+ { rl__schema_to_string(ModuleInfo0, InputTypes, InputSchema) },
+ { ConstArgs = [string(ProcName), string(InputSchema)] },
+ generate_const_args(ConstArgs, ConstArgVars, ConstArgGoals),
+
+ %
+ % Build a tuple containing the input arguments.
+ %
+ handle_input_tuple(InputArgs, InputTupleVar, InputTupleTypeInfo,
+ InputTupleGoals),
+
+ %
+ % Build a goal to deconstruct the vector of output arguments.
+ %
+ make_tuple_var(OutputArgs, OutputTupleVar,
+ OutputTupleTypeInfo, OutputTypeInfoGoals),
+ { deconstruct_tuple(OutputTupleVar, OutputArgs, OutputGoal) },
+
+ %
+ % Build the call.
+ %
+ { CallArgs = list__append(
+ [InputTupleTypeInfo, OutputTupleTypeInfo | ConstArgVars],
+ [InputTupleVar, OutputTupleVar]) },
+ { set__list_to_set(CallArgs, NonLocals) },
+ { determinism_components(Det, _, at_most_zero) ->
+ instmap_delta_init_unreachable(InstMapDelta)
+ ;
+ instmap_delta_from_assoc_list([OutputTupleVar - ground_inst],
+ InstMapDelta)
+ },
+ { goal_info_init(NonLocals, InstMapDelta, Det, pure, GoalInfo) },
+ { CallGoal = call(BuiltinPredId, BuiltinProcId, CallArgs,
+ not_builtin, no, BuiltinSymName) - GoalInfo },
+
+ { Goals = list__condense(
+ [ConstArgGoals, InputTupleGoals, OutputTypeInfoGoals,
+ [CallGoal, OutputGoal]]) },
+ { Goal = conj(Goals) - GoalInfo }.
+
+:- pred make_tuple_var(list(prog_var), prog_var, prog_var, list(hlds_goal),
+ aditi_transform_info, aditi_transform_info).
+:- mode make_tuple_var(in, out, out, out, in, out) is det.
+
+make_tuple_var(Args, TupleVar, TupleTypeInfo, TupleTypeInfoGoal) -->
+ ProcInfo0 =^ proc_info,
+ { proc_info_vartypes(ProcInfo0, VarTypes) },
+ { map__apply_to_list(Args, VarTypes, ArgTypes) },
+ { construct_type(unqualified("{}") - list__length(Args),
+ ArgTypes, TupleType) },
+ { proc_info_create_var_from_type(ProcInfo0, TupleType, no,
+ TupleVar, ProcInfo) },
+ ^ proc_info := ProcInfo,
+ make_type_info_for_var(TupleVar, TupleTypeInfo, TupleTypeInfoGoal).
+
+:- pred make_type_info_for_var(prog_var, prog_var,
+ list(hlds_goal), aditi_transform_info, aditi_transform_info).
+:- mode make_type_info_for_var(in, out, out, in, out) is det.
+
+make_type_info_for_var(Var, TypeInfo, Goals) -->
+ PredInfo0 =^ pred_info,
+ ProcInfo0 =^ proc_info,
+ ModuleInfo0 =^ module_info,
+ { proc_info_vartypes(ProcInfo0, VarTypes0) },
+ { map__lookup(VarTypes0, Var, Type) },
+ { create_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0) },
+ { term__context_init(Context) },
+ { polymorphism__make_type_info_vars([Type], Context, TypeInfos, Goals,
+ PolyInfo0, PolyInfo) },
+ {
+ TypeInfos = [TypeInfo0]
+ ->
+ TypeInfo = TypeInfo0
+ ;
+ error("make_type_infos_for_var")
+ },
+ { poly_info_extract(PolyInfo, PredInfo0, PredInfo,
+ ProcInfo0, ProcInfo, ModuleInfo) },
+ ^ pred_info := PredInfo,
+ ^ proc_info := ProcInfo,
+ ^ module_info := ModuleInfo.
+
+:- pred handle_input_tuple(list(prog_var), prog_var, prog_var,
+ list(hlds_goal), aditi_transform_info, aditi_transform_info).
+:- mode handle_input_tuple(in, out, out, out, in, out) is det.
+
+handle_input_tuple(Args, ArgTupleVar, TypeInfoVar, Goals) -->
+ make_tuple_var(Args, ArgTupleVar, TypeInfoVar, TypeInfoGoals),
+ { construct_tuple(ArgTupleVar, Args, ArgTupleGoal) },
+ { Goals = [ArgTupleGoal | TypeInfoGoals] }.
+
+ % An argument passed to an Aditi builtin to describe the
+ % predicate being called or updated.
+:- type const_arg
+ ---> int(int)
+ ; string(string)
+ .
+
+:- pred generate_const_args(list(const_arg), list(prog_var), list(hlds_goal),
+ aditi_transform_info, aditi_transform_info).
+:- mode generate_const_args(in, out, out, in, out) is det.
+
+generate_const_args([], [], []) --> [].
+generate_const_args([ConstArg | ConstArgs], [ConstArgVar | ConstArgVars],
+ [ConstGoal | ConstGoals]) -->
+ ProcInfo0 =^ proc_info,
+ {
+ ConstArg = int(Int),
+ make_int_const_construction(Int, no, ConstGoal, ConstArgVar,
+ ProcInfo0, ProcInfo)
+ ;
+ ConstArg = string(String),
+ make_string_const_construction(String, no, ConstGoal,
+ ConstArgVar, ProcInfo0, ProcInfo)
+ },
+ ^ proc_info := ProcInfo,
+ generate_const_args(ConstArgs, ConstArgVars, ConstGoals).
+
+ % Create a variable for the query closure passed to a bulk update.
+ % The closure returns a reference to the answer relation for the
+ % query, rather than returning the answer tuples non-deterministically.
+:- pred create_bulk_update_closure_var(prog_var,
+ aditi_transform_info, aditi_transform_info).
+:- mode create_bulk_update_closure_var(out, in, out) is det.
+
+create_bulk_update_closure_var(NewVar, Info0, Info) :-
+ construct_higher_order_pred_type(pure, normal,
+ [c_pointer_type], PredType),
+ proc_info_create_var_from_type(Info0 ^ proc_info, PredType, no,
+ NewVar, ProcInfo),
+ Info = Info0 ^ proc_info := ProcInfo.
+
+ % Work out which predicate from aditi_private_builtin.m
+ % should be called to perform an Aditi builtin, and work
+ % out what arguments should be passed to describe the
+ % predicate being called or updated.
+:- pred aditi_builtin_info(module_info, aditi_builtin,
+ string, arity, list(const_arg)).
+:- mode aditi_builtin_info(in, in, out, out, out) is det.
+
+aditi_builtin_info(ModuleInfo, aditi_tuple_insert_delete(Op, PredId),
+ BuiltinProcName, BuiltinProcArity, ConstArgs) :-
+ rl__permanent_relation_name(ModuleInfo, PredId, RelName),
+ (
+ Op = insert,
+ BuiltinProcName = "do_insert_tuple",
+ BuiltinProcArity = 4,
+ UpdateProcArgs = []
+ ;
+ Op = delete,
+ BuiltinProcName = "do_delete_tuple",
+ BuiltinProcArity = 6,
+ rl__get_delete_proc_name(ModuleInfo, PredId, DeleteProcName),
+ rl__proc_name_to_string(DeleteProcName, DeleteProcStr),
+
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_arg_types(PredInfo, ArgTypes0),
+ type_util__remove_aditi_state(ArgTypes0, ArgTypes0, ArgTypes),
+ rl__schema_to_string(ModuleInfo, ArgTypes, InputSchema),
+
+ UpdateProcArgs = [string(DeleteProcStr), string(InputSchema)]
+ ),
+ ConstArgs = [string(RelName) | UpdateProcArgs].
+aditi_builtin_info(ModuleInfo, aditi_insert_delete_modify(Op, PredId, _),
+ BuiltinProcName, BuiltinProcArity, ConstArgs) :-
+
+ rl__permanent_relation_name(ModuleInfo, PredId, RelName),
+ (
+ Op = delete(BulkFilter),
+ BuiltinProcName = "do_bulk_delete",
+ require(unify(BulkFilter, bulk),
+ "sorry, top-down Aditi updates not yet implemented"),
+ rl__get_delete_proc_name(ModuleInfo, PredId, UpdateProcName)
+ ;
+ Op = bulk_insert,
+ BuiltinProcName = "do_bulk_insert",
+ rl__get_insert_proc_name(ModuleInfo, PredId, UpdateProcName)
+ ;
+ Op = modify(BulkFilter),
+ BuiltinProcName = "do_bulk_modify",
+ require(unify(BulkFilter, bulk),
+ "sorry, top-down Aditi updates not yet implemented"),
+ rl__get_modify_proc_name(ModuleInfo, PredId, UpdateProcName)
+ ),
+ BuiltinProcArity = 5,
+ rl__proc_name_to_string(UpdateProcName, UpdateProcStr),
+ ConstArgs = [string(RelName), string(UpdateProcStr)].
+
+:- pred construct_aditi_transform_info(module_info, pred_id, proc_info,
+ aditi_transform_info).
+:- mode construct_aditi_transform_info(in, in, in, out) is det.
+
+construct_aditi_transform_info(ModuleInfo, PredId, ProcInfo, Info) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ Changed = no,
+ Info = aditi_transform_info(ModuleInfo, PredInfo, ProcInfo, Changed).
+
+:- pred deconstruct_aditi_transform_info(aditi_transform_info, pred_id,
+ module_info, proc_info, bool).
+:- mode deconstruct_aditi_transform_info(in, in, out, out, out) is det.
+
+deconstruct_aditi_transform_info(Info, PredId,
+ ModuleInfo, ProcInfo, Changed) :-
+ ModuleInfo0 = Info ^ module_info,
+ ProcInfo = Info ^ proc_info,
+ PredInfo = Info ^ pred_info,
+ Changed = Info ^ changed,
+ module_info_set_pred_info(ModuleInfo0, PredId, PredInfo, ModuleInfo).
+
+:- type aditi_transform_info
+ ---> aditi_transform_info(
+ module_info :: module_info,
+ pred_info :: pred_info,
+ proc_info :: proc_info,
+ changed :: bool
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: compiler/c_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/c_util.m,v
retrieving revision 1.12
diff -u -u -r1.12 c_util.m
--- compiler/c_util.m 24 Nov 2002 03:57:22 -0000 1.12
+++ compiler/c_util.m 22 Dec 2002 02:03:11 -0000
@@ -17,8 +17,9 @@
:- module backend_libs__c_util.
:- interface.
-:- import_module io, char, string, int.
-:- import_module backend_libs__builtin_ops.
+:- import_module io, char, string, int, std_util.
+:- import_module backend_libs__builtin_ops, parse_tree__prog_data.
+:- import_module aditi_backend, aditi_backend__rl_file.
%-----------------------------------------------------------------------------%
%
@@ -134,10 +135,25 @@
:- mode c_util__binary_infix_op(in, out) is semidet.
%-----------------------------------------------------------------------------%
+
+ % Currently the `.rlo' files are stored as static data in the
+ % executable. It may be better to store them in separate files
+ % in a known location and load them at runtime.
+:- pred c_util__output_rl_file(module_name, maybe(rl_file),
+ io__state, io__state).
+:- mode c_util__output_rl_file(in, in, di, uo) is det.
+
+ % Returns the name of the Aditi-RL code constant
+ % for a given module.
+:- pred c_util__make_rl_data_name(module_name, string).
+:- mode c_util__make_rl_data_name(in, out) is det.
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module libs__globals, libs__options.
+:- import_module ll_backend__llds_out. % XXX for llds_out__sym_name_mangle.
:- import_module list, bool.
%-----------------------------------------------------------------------------%
@@ -365,5 +381,52 @@
c_util__binary_infix_op(>, ">").
c_util__binary_infix_op(<=, "<=").
c_util__binary_infix_op(>=, ">=").
+
+%-----------------------------------------------------------------------------%
+
+c_util__output_rl_file(ModuleName, MaybeRLFile) -->
+ globals__io_lookup_bool_option(aditi, Aditi),
+ ( { Aditi = no } ->
+ []
+ ;
+ io__write_string("\n\n/* Aditi-RL code for this module. */\n"),
+ { c_util__make_rl_data_name(ModuleName, RLDataConstName) },
+ io__write_string("const char "),
+ io__write_string(RLDataConstName),
+ io__write_string("[] = {"),
+ (
+ { MaybeRLFile = yes(RLFile) },
+ rl_file__write_binary(c_util__output_rl_byte,
+ RLFile, Length),
+ io__write_string("0};\n")
+ ;
+ { MaybeRLFile = no },
+ io__write_string("};\n"),
+ { Length = 0 }
+ ),
+
+ % Store the length of the data in
+ % mercury__aditi_rl_data__<module>__length.
+
+ { string__append(RLDataConstName, "__length",
+ RLDataConstLength) },
+ io__write_string("const int "),
+ io__write_string(RLDataConstLength),
+ io__write_string(" = "),
+ io__write_int(Length),
+ io__write_string(";\n\n")
+ ).
+
+:- pred c_util__output_rl_byte(int, io__state, io__state).
+:- mode c_util__output_rl_byte(in, di, uo) is det.
+
+c_util__output_rl_byte(Byte) -->
+ io__write_int(Byte),
+ io__write_string(", ").
+
+c_util__make_rl_data_name(ModuleName, RLDataConstName) :-
+ llds_out__sym_name_mangle(ModuleName, MangledModuleName),
+ string__append("mercury__aditi_rl_data__", MangledModuleName,
+ RLDataConstName).
%-----------------------------------------------------------------------------%
Index: compiler/call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/call_gen.m,v
retrieving revision 1.152
diff -u -u -r1.152 call_gen.m
--- compiler/call_gen.m 27 Jan 2003 09:20:44 -0000 1.152
+++ compiler/call_gen.m 1 Mar 2003 13:34:46 -0000
@@ -36,10 +36,6 @@
list(prog_var)::in, code_tree::out, code_info::in, code_info::out)
is det.
-:- pred call_gen__maybe_remove_aditi_state_args(generic_call::in,
- list(prog_var)::in, list(type)::in, list(mode)::in,
- list(prog_var)::out, list(type)::out, list(mode)::out) is det.
-
% call_gen__generic_call_info(CodeModel, GenericCall,
% CodeAddr, FirstImmediateInputReg).
:- pred call_gen__generic_call_info(code_model::in, generic_call::in,
@@ -133,11 +129,32 @@
% the runtime system leaves them in.
%
-call_gen__generate_generic_call(_OuterCodeModel, GenericCall, Args0,
+call_gen__generate_generic_call(OuterCodeModel, GenericCall, Args0,
Modes0, Det, GoalInfo, Code) -->
- list__map_foldl(code_info__variable_type, Args0, Types0),
- { call_gen__maybe_remove_aditi_state_args(GenericCall,
- Args0, Types0, Modes0, Args, Types, Modes) },
+ % `unsafe_cast' differs from the other generic call types in
+ % that there is no address.
+ ( { GenericCall = unsafe_cast } ->
+ ( { Args0 = [InputArg, OutputArg] } ->
+ call_gen__generate_assign_builtin(OutputArg,
+ leaf(InputArg), Code)
+ ;
+ { error(
+ "call_gen__generate_generic_call: invalid unsafe_cast call") }
+ )
+ ;
+ call_gen__generate_generic_call_2(OuterCodeModel,
+ GenericCall, Args0, Modes0, Det, GoalInfo, Code)
+ ).
+
+:- pred call_gen__generate_generic_call_2(code_model, generic_call,
+ list(prog_var), list(mode), determinism,
+ hlds_goal_info, code_tree, code_info, code_info).
+:- mode call_gen__generate_generic_call_2(in, in, in, in, in, in,
+ out, in, out) is det.
+
+call_gen__generate_generic_call_2(_OuterCodeModel, GenericCall, Args,
+ Modes, Det, GoalInfo, Code) -->
+ list__map_foldl(code_info__variable_type, Args, Types),
{ determinism_to_code_model(Det, CodeModel) },
{ call_gen__generic_call_info(CodeModel, GenericCall,
@@ -213,42 +230,6 @@
FailHandlingCode))))
}.
-call_gen__maybe_remove_aditi_state_args(GenericCall, Args0, Types0, Modes0,
- Args, Types, Modes) :-
- ( GenericCall = aditi_builtin(aditi_tuple_insert_delete(_, _), _) ->
- % Remove the `aditi__state' argument and its type-info from
- % the tuple to insert or delete. This must be done after
- % mode analysis (so that removal of the `aditi__state' does
- % not stuff up the argument numbers in error messages).
- % Here is as good a place as any.
- get_state_args_det(Types0, TupleTypes, _, _),
- call_gen__remove_tuple_state_arg(TupleTypes, Args0, Args),
- call_gen__remove_tuple_state_arg(TupleTypes, Types0, Types),
- call_gen__remove_tuple_state_arg(TupleTypes, Modes0, Modes)
- ;
- Args = Args0,
- Types = Types0,
- Modes = Modes0
- ).
-
-:- pred call_gen__remove_tuple_state_arg(list(type)::in, list(T)::in,
- list(T)::out) is det.
-
-call_gen__remove_tuple_state_arg(TupleTypes, Args0, Args) :-
- get_state_args_det(Args0, OtherArgs0, State0Arg, StateArg),
- assoc_list__from_corresponding_lists(TupleTypes, OtherArgs0,
- TypesAndArgs0),
- list__filter(
- (pred((Type - _)::in) is semidet :-
- \+ type_is_aditi_state(Type),
- \+ (
- polymorphism__type_info_type(Type, TheType),
- type_is_aditi_state(TheType)
- )
- ), TypesAndArgs0, TypesAndArgs),
- assoc_list__values(TypesAndArgs, OtherArgs),
- list__append(OtherArgs, [State0Arg, StateArg], Args).
-
%---------------------------------------------------------------------------%
% The registers before the first input argument are all live.
@@ -272,42 +253,11 @@
do_call_closure, [PredVar - arg_info(1, top_in)], 4).
call_gen__generic_call_info(_, class_method(TCVar, _, _, _),
do_call_class_method, [TCVar - arg_info(1, top_in)], 5).
-call_gen__generic_call_info(CodeModel, aditi_builtin(aditi_call(_,_,_,_),_),
- CodeAddr, [], 5) :-
- ( CodeModel = model_det, CodeAddr = do_det_aditi_call
- ; CodeModel = model_semi, CodeAddr = do_semidet_aditi_call
- ; CodeModel = model_non, CodeAddr = do_nondet_aditi_call
- ).
-call_gen__generic_call_info(CodeModel,
- aditi_builtin(aditi_tuple_insert_delete(InsertDelete, _), _),
- CodeAddr, [], 5) :-
- ( InsertDelete = insert, CodeAddr = do_aditi_insert
- ; InsertDelete = delete, CodeAddr = do_aditi_delete
- ),
- require(unify(CodeModel, model_det),
- "aditi_insert/delete not model_det").
-call_gen__generic_call_info(CodeModel,
- aditi_builtin(
- aditi_insert_delete_modify(InsertDelMod, _, _), _),
- CodeAddr, [], FirstReg) :-
- call_gen__aditi_insert_delete_modify_info(InsertDelMod,
- CodeAddr, FirstReg),
- require(unify(CodeModel, model_det),
- "aditi_insert_delete_modify not model_det").
-
-:- pred call_gen__aditi_insert_delete_modify_info(
- aditi_insert_delete_modify::in, code_addr::out, int::out) is det.
-
-call_gen__aditi_insert_delete_modify_info(bulk_insert,
- do_aditi_bulk_insert, 3).
-call_gen__aditi_insert_delete_modify_info(delete(filter), _, _) :-
- error("Sorry, not yet implemented: aditi_delete(filter)").
-call_gen__aditi_insert_delete_modify_info(delete(bulk),
- do_aditi_bulk_delete, 3).
-call_gen__aditi_insert_delete_modify_info(modify(filter), _, _) :-
- error("Sorry, not yet implemented: aditi_modify(filter)").
-call_gen__aditi_insert_delete_modify_info(modify(bulk),
- do_aditi_bulk_modify, 3).
+ % Casts are generated inline.
+call_gen__generic_call_info(_, unsafe_cast, do_not_reached, [], 1).
+call_gen__generic_call_info(_, aditi_builtin(_, _), _, _, _) :-
+ % These should have been transformed into normal calls.
+ error("call_gen__generic_call_info: aditi_builtin").
% Some of the values that generic call passes to the dispatch routine
% to specify what code is being indirectly called come from HLDS
@@ -349,155 +299,11 @@
assign(reg(r, 4), const(int_const(NOutVars))) -
"Assign number of output arguments"
]) }.
-call_gen__generic_call_nonvar_setup(aditi_builtin(Builtin, _),
- InVars, OutVars, Code) -->
- call_gen__aditi_builtin_setup(Builtin, InVars, OutVars, Code).
-
-:- pred call_gen__aditi_builtin_setup(aditi_builtin::in,
- list(prog_var)::in, list(prog_var)::in, code_tree::out,
- code_info::in, code_info::out) is det.
-
-call_gen__aditi_builtin_setup(
- aditi_call(PredProcId, NumInputs, InputTypes, NumOutputs),
- _, _, SetupCode) -->
- code_info__get_module_info(ModuleInfo),
- { rl__get_entry_proc_name(ModuleInfo, PredProcId, ProcName) },
- { rl__proc_name_to_string(ProcName, ProcStr) },
- { rl__schema_to_string(ModuleInfo, InputTypes, InputSchema) },
- code_info__clobber_regs([reg(r, 1), reg(r, 2), reg(r, 3), reg(r, 4)]),
- { SetupCode = node([
- assign(reg(r, 1), const(string_const(ProcStr))) -
- "Assign name of procedure to call",
- assign(reg(r, 2), const(int_const(NumInputs))) -
- "Assign number of input arguments",
- assign(reg(r, 3), const(string_const(InputSchema))) -
- "Assign schema of input arguments",
- assign(reg(r, 4), const(int_const(NumOutputs))) -
- "Assign number of output arguments"
- ]) }.
-
-call_gen__aditi_builtin_setup(
- aditi_tuple_insert_delete(InsertOrDelete, PredId),
- InputArgs, _, SetupCode) -->
- code_info__clobber_regs([reg(r, 1), reg(r, 2), reg(r, 3), reg(r, 4)]),
- call_gen__setup_base_relation_name(PredId, NameCode),
-
- code_info__get_module_info(ModuleInfo),
- { module_info_pred_info(ModuleInfo, PredId, PredInfo) },
- { pred_info_arity(PredInfo, PredArity) },
- % The `aditi__state' was removed.
- { TupleArity = PredArity - 1 },
- { ArityCode = node([
- assign(reg(r, 2), const(int_const(TupleArity))) -
- "Assign arity of relation to insert into"
- ]) },
-
- (
- { InsertOrDelete = insert },
- { ProcCode = empty }
- ;
- { InsertOrDelete = delete },
-
- %
- % For now tuple deletions need to be done as bulk
- % deletions. The API function to delete a single
- % tuple only works if the relation being
- % deleted from has an index.
- %
-
- call_gen__setup_update_proc_name(rl__get_delete_proc_name,
- PredId, reg(r, 3), ProcNameCode),
-
- %
- % Work out the schema of the input relation of the
- % deletion procedure
- %
- { list__reverse(InputArgs, RevInputArgs) },
- {
- RevInputArgs = [_DiState | RevTupleArgs],
- list__reverse(RevTupleArgs, TupleArgs0),
- list__length(TupleArgs0, TupleArityTimes2),
-
- % Remove the type-infos for the tuple arguments.
- list__drop(TupleArityTimes2 // 2,
- TupleArgs0, TupleArgs1)
- ->
- TupleArgs = TupleArgs1
- ;
- error(
- "call_gen__aditi_builtin_setup: error in schema for aditi_delete")
- },
- list__map_foldl(code_info__variable_type,
- TupleArgs, TupleTypes),
- { rl__schema_to_string(ModuleInfo, TupleTypes, InputSchema) },
- { ProcSchemaCode =
- node([
- assign(reg(r, 4),
- const(string_const(InputSchema))) -
- "Assign schema of tuple to insert/delete"
- ]) },
-
- { ProcCode = tree(ProcNameCode, ProcSchemaCode) }
- ),
- { SetupCode = tree(NameCode, tree(ArityCode, ProcCode)) }.
-
-call_gen__aditi_builtin_setup(
- aditi_insert_delete_modify(InsertDelMod, PredId, _),
- _, _, SetupCode) -->
- call_gen__aditi_insert_delete_modify_setup(InsertDelMod,
- PredId, SetupCode).
-
-:- pred call_gen__aditi_insert_delete_modify_setup(
- aditi_insert_delete_modify::in, pred_id::in, code_tree::out,
- code_info::in, code_info::out) is det.
-
-call_gen__aditi_insert_delete_modify_setup(bulk_insert, PredId, SetupCode) -->
- code_info__clobber_regs([reg(r, 1), reg(r, 2)]),
- call_gen__setup_base_relation_name(PredId, RelNameCode),
- call_gen__setup_update_proc_name(rl__get_insert_proc_name,
- PredId, reg(r, 2), ProcNameCode),
- { SetupCode = tree(RelNameCode, ProcNameCode) }.
-call_gen__aditi_insert_delete_modify_setup(delete(_), PredId, SetupCode) -->
- code_info__clobber_regs([reg(r, 1), reg(r, 2)]),
- call_gen__setup_base_relation_name(PredId, RelNameCode),
- call_gen__setup_update_proc_name(rl__get_delete_proc_name,
- PredId, reg(r, 2), ProcNameCode),
- { SetupCode = tree(RelNameCode, ProcNameCode) }.
-call_gen__aditi_insert_delete_modify_setup(modify(_), PredId, SetupCode) -->
- code_info__clobber_regs([reg(r, 1), reg(r, 2)]),
- call_gen__setup_base_relation_name(PredId, RelNameCode),
- call_gen__setup_update_proc_name(rl__get_modify_proc_name,
- PredId, reg(r, 2), ProcNameCode),
- { SetupCode = tree(RelNameCode, ProcNameCode) }.
-
-:- pred call_gen__setup_base_relation_name(pred_id::in,
- code_tree::out, code_info::in, code_info::out) is det.
-
-call_gen__setup_base_relation_name(PredId, SetupCode) -->
- code_info__get_module_info(ModuleInfo),
- { rl__permanent_relation_name(ModuleInfo, PredId, ProcStr) },
- { SetupCode = node([
- assign(reg(r, 1), const(string_const(ProcStr))) -
- "Assign name of base relation"
- ]) }.
-
-:- pred call_gen__setup_update_proc_name(
- pred(module_info, pred_id, rl_proc_name),
- pred_id, lval, code_tree, code_info, code_info).
-:- mode call_gen__setup_update_proc_name(pred(in, in, out) is det,
- in, in, out, in, out) is det.
-
-call_gen__setup_update_proc_name(NamePred, PredId, Lval, ProcNameCode) -->
- code_info__get_module_info(ModuleInfo),
- { NamePred(ModuleInfo, PredId, ProcName) },
- { rl__proc_name_to_string(ProcName, ProcNameStr) },
- { ProcNameCode =
- node([
- assign(Lval,
- const(string_const(ProcNameStr))) -
- "Assign name of update RL procedure"
- ])
- }.
+call_gen__generic_call_nonvar_setup(unsafe_cast, _, _, _) -->
+ { error("call_gen__generic_call_nonvar_setup: unsafe_cast") }.
+call_gen__generic_call_nonvar_setup(aditi_builtin(_, _), _, _, _) -->
+ % These should have been transformed into normal calls.
+ { error("call_gen__generic_call_info: aditi_builtin") }.
%---------------------------------------------------------------------------%
@@ -665,12 +471,8 @@
(
{ SimpleCode = assign(Var, AssignExpr) }
->
- ( code_info__variable_is_forward_live(Var) ->
- { Rval = convert_simple_expr(AssignExpr) },
- code_info__assign_expr_to_var(Var, Rval, Code)
- ;
- { Code = empty }
- )
+ call_gen__generate_assign_builtin(Var,
+ AssignExpr, Code)
;
{ error("Malformed det builtin predicate") }
)
@@ -689,6 +491,18 @@
;
{ CodeModel = model_non },
{ error("Nondet builtin predicate") }
+ ).
+
+:- pred call_gen__generate_assign_builtin(prog_var, simple_expr(prog_var),
+ code_tree, code_info, code_info).
+:- mode call_gen__generate_assign_builtin(in, in, out, in, out) is det.
+
+call_gen__generate_assign_builtin(Var, AssignExpr, Code) -->
+ ( code_info__variable_is_forward_live(Var) ->
+ { Rval = convert_simple_expr(AssignExpr) },
+ code_info__assign_expr_to_var(Var, Rval, Code)
+ ;
+ { Code = empty }
).
:- func convert_simple_expr(simple_expr(prog_var)) = rval.
Index: compiler/common.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/common.m,v
retrieving revision 1.67
diff -u -u -r1.67 common.m
--- compiler/common.m 28 Feb 2003 00:21:36 -0000 1.67
+++ compiler/common.m 2 Mar 2003 10:45:51 -0000
@@ -659,23 +659,19 @@
hlds_goal_info, hlds_goal, simplify_info, simplify_info).
:- mode common__generate_assign(in, in, in, in, out, in, out) is det.
-common__generate_assign(ToVar, FromVar, UniMode,
- GoalInfo0, Goal, Info0, Info) :-
- goal_info_get_instmap_delta(GoalInfo0, InstMapDelta0),
+common__generate_assign(ToVar, FromVar, UniMode, _, Goal, Info0, Info) :-
simplify_info_get_var_types(Info0, VarTypes),
map__lookup(VarTypes, ToVar, ToVarType),
map__lookup(VarTypes, FromVar, FromVarType),
set__list_to_set([ToVar, FromVar], NonLocals),
+ UniMode = ((_ - ToVarInst0) -> (_ - ToVarInst)),
( common__types_match_exactly(ToVarType, FromVarType) ->
- UniMode = ((_ - ToVarInst0) -> (_ - ToVarInst)),
- UnifyContext = unify_context(explicit, []),
UnifyMode = (ToVarInst0 -> ToVarInst) -
(ToVarInst -> ToVarInst),
+ UnifyContext = unify_context(explicit, []),
GoalExpr = unify(ToVar, var(FromVar), UnifyMode,
- assign(ToVar, FromVar), UnifyContext),
- instmap_delta_from_assoc_list([ToVar - ToVarInst],
- InstMapDelta)
+ assign(ToVar, FromVar), UnifyContext)
;
% If the cells we are optimizing don't have exactly the same
% type, we insert explicit type casts to ensure type
@@ -684,13 +680,17 @@
% Unfortunately this loses information for other optimizations,
% since the call to the type cast hides the equivalence of
% the input and output.
- simplify_info_get_module_info(Info0, ModuleInfo),
- goal_info_get_context(GoalInfo0, Context),
- goal_util__generate_simple_call(mercury_private_builtin_module,
- "unsafe_type_cast", [FromVar, ToVar], only_mode,
- det, no, [], ModuleInfo, Context, GoalExpr - _),
- instmap_delta_restrict(InstMapDelta0, NonLocals, InstMapDelta)
+ Modes = [(ToVarInst -> ToVarInst),
+ (free -> ToVarInst)],
+ GoalExpr = generic_call(unsafe_cast, [FromVar, ToVar],
+ Modes, det)
),
+
+ % `ToVar' may not appear in the original instmap_delta,
+ % so we can't just use instmap_delta_restrict on the
+ % original instmap_delta here.
+ instmap_delta_from_assoc_list([ToVar - ToVarInst], InstMapDelta),
+
goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo),
Goal = GoalExpr - GoalInfo,
common__record_equivalence(ToVar, FromVar, Info0, Info).
Index: compiler/compile_target_code.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/compile_target_code.m,v
retrieving revision 1.40
diff -u -u -r1.40 compile_target_code.m
--- compiler/compile_target_code.m 14 Feb 2003 09:57:24 -0000 1.40
+++ compiler/compile_target_code.m 28 Feb 2003 16:28:33 -0000
@@ -168,10 +168,10 @@
:- import_module libs__globals, libs__options, libs__handle_options.
:- import_module hlds__error_util, hlds__passes_aux, libs__trace_params.
:- import_module parse_tree__prog_out.
+:- import_module backend_libs__c_util.
:- import_module backend_libs__foreign.
-:- import_module ll_backend__llds_out. % for llds_out__make_init_name and
- % llds_out__make_rl_data_name
+:- import_module ll_backend__llds_out. % for llds_out__make_init_name
:- import_module char, dir, getopt, int, require, string.
@@ -741,7 +741,7 @@
io__write_string(InitFileStream, InitFuncName),
io__nl(InitFileStream),
( { Aditi = yes } ->
- { llds_out__make_rl_data_name(ModuleName,
+ { c_util__make_rl_data_name(ModuleName,
RLName) },
io__write_string(InitFileStream,
"ADITI_DATA "),
Index: compiler/deep_profiling.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/deep_profiling.m,v
retrieving revision 1.15
diff -u -u -r1.15 deep_profiling.m
--- compiler/deep_profiling.m 28 Feb 2003 00:21:36 -0000 1.15
+++ compiler/deep_profiling.m 4 Mar 2003 13:02:12 -0000
@@ -1023,9 +1023,24 @@
{ GoalAndInfo = Goal0 - Info0 }
).
-transform_goal(Path, Goal0 - Info0, GoalAndInfo, yes) -->
- { Goal0 = generic_call(_, _, _, _) },
- wrap_call(Path, Goal0 - Info0, GoalAndInfo).
+transform_goal(Path, Goal0 - Info0, GoalAndInfo, AddedImpurity) -->
+ { Goal0 = generic_call(GenericCall, _, _, _) },
+ (
+ { GenericCall = higher_order(_, _, _, _) },
+ wrap_call(Path, Goal0 - Info0, GoalAndInfo),
+ { AddedImpurity = yes }
+ ;
+ { GenericCall = class_method(_, _, _, _) },
+ wrap_call(Path, Goal0 - Info0, GoalAndInfo),
+ { AddedImpurity = yes }
+ ;
+ { GenericCall = unsafe_cast },
+ { GoalAndInfo = Goal0 - Info0 },
+ { AddedImpurity = no }
+ ;
+ { GenericCall = aditi_builtin(_, _) },
+ { error("deep_profiling__transform_call: aditi_builtin") }
+ ).
:- pred transform_conj(int::in, goal_path::in,
list(hlds_goal)::in, list(hlds_goal)::out, bool::out,
@@ -1172,8 +1187,11 @@
]) - PrepareCallGoalInfo,
CallSite = method_call(FileName, LineNumber, GoalPath)
;
+ Generic = unsafe_cast,
+ error("deep_profiling__wrap_call: unsafe_cast")
+ ;
Generic = aditi_builtin(_, _),
- error("deep profiling and aditi do not mix")
+ error("deep_profiling__wrap_call: aditi_builtin")
),
goal_info_get_code_model(GoalInfo0, GoalCodeModel),
module_info_globals(ModuleInfo, Globals),
Index: compiler/exprn_aux.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/exprn_aux.m,v
retrieving revision 1.43
diff -u -u -r1.43 exprn_aux.m
--- compiler/exprn_aux.m 7 May 2002 11:02:43 -0000 1.43
+++ compiler/exprn_aux.m 22 Dec 2002 02:21:27 -0000
@@ -164,14 +164,6 @@
exprn_aux__addr_is_constant(do_trace_redo_fail_deep, _, no).
exprn_aux__addr_is_constant(do_call_closure, _, no).
exprn_aux__addr_is_constant(do_call_class_method, _, no).
-exprn_aux__addr_is_constant(do_det_aditi_call, _, no).
-exprn_aux__addr_is_constant(do_semidet_aditi_call, _, no).
-exprn_aux__addr_is_constant(do_nondet_aditi_call, _, no).
-exprn_aux__addr_is_constant(do_aditi_insert, _, no).
-exprn_aux__addr_is_constant(do_aditi_delete, _, no).
-exprn_aux__addr_is_constant(do_aditi_bulk_insert, _, no).
-exprn_aux__addr_is_constant(do_aditi_bulk_delete, _, no).
-exprn_aux__addr_is_constant(do_aditi_bulk_modify, _, no).
exprn_aux__addr_is_constant(do_not_reached, _, no).
:- pred exprn_aux__label_is_constant(label::in, bool::in, bool::in, bool::out)
Index: compiler/follow_vars.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/follow_vars.m,v
retrieving revision 1.64
diff -u -u -r1.64 follow_vars.m
--- compiler/follow_vars.m 28 Mar 2002 03:42:55 -0000 1.64
+++ compiler/follow_vars.m 1 Mar 2003 13:35:35 -0000
@@ -223,26 +223,28 @@
error("find_follow_vars_in_goal_2: unexpected shorthand").
find_follow_vars_in_goal_expr(
- generic_call(GenericCall, Args, Modes, Det), GoalInfo,
- VarTypes, ModuleInfo, _FollowVarsMap0, _NextNonReserved0,
- generic_call(GenericCall, Args, Modes, Det), GoalInfo,
- FollowVarsMap, NextNonReserved) :-
- determinism_to_code_model(Det, CodeModel),
- map__apply_to_list(Args, VarTypes, Types),
- call_gen__maybe_remove_aditi_state_args(GenericCall,
- Args, Types, Modes, EffArgs, EffTypes, EffModes),
- make_arg_infos(EffTypes, EffModes, CodeModel, ModuleInfo, EffArgInfos),
- assoc_list__from_corresponding_lists(EffArgs, EffArgInfos,
- EffArgsInfos),
- arg_info__partition_args(EffArgsInfos, EffInVarInfos, _),
- assoc_list__keys(EffInVarInfos, EffInVars),
- call_gen__generic_call_info(CodeModel, GenericCall, _,
- SpecifierArgInfos, FirstInput),
- map__init(FollowVarsMap0),
- find_follow_vars_from_arginfo(SpecifierArgInfos, FollowVarsMap0, 1,
- FollowVarsMap1, _),
- find_follow_vars_from_sequence(EffInVars, FirstInput, FollowVarsMap1,
- FollowVarsMap, NextNonReserved).
+ Call @ generic_call(GenericCall, Args, Modes, Det), GoalInfo,
+ VarTypes, ModuleInfo, FollowVarsMap0, NextNonReserved0,
+ Call, GoalInfo, FollowVarsMap, NextNonReserved) :-
+ % unsafe_casts are generated inline.
+ ( GenericCall = unsafe_cast ->
+ FollowVarsMap = FollowVarsMap0,
+ NextNonReserved = NextNonReserved0
+ ;
+ determinism_to_code_model(Det, CodeModel),
+ map__apply_to_list(Args, VarTypes, Types),
+ make_arg_infos(Types, Modes, CodeModel, ModuleInfo, ArgInfos),
+ assoc_list__from_corresponding_lists(Args,
+ ArgInfos, ArgsInfos),
+ arg_info__partition_args(ArgsInfos, InVarInfos, _),
+ assoc_list__keys(InVarInfos, InVars),
+ call_gen__generic_call_info(CodeModel, GenericCall, _,
+ SpecifierArgInfos, FirstInput),
+ find_follow_vars_from_arginfo(SpecifierArgInfos,
+ map__init, 1, FollowVarsMap1, _),
+ find_follow_vars_from_sequence(InVars, FirstInput,
+ FollowVarsMap1, FollowVarsMap, NextNonReserved)
+ ).
find_follow_vars_in_goal_expr(call(PredId, ProcId, Args, State, E, F),
GoalInfo, _, ModuleInfo, FollowVarsMap0, NextNonReserved0,
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.82
diff -u -u -r1.82 goal_util.m
--- compiler/goal_util.m 28 Feb 2003 06:40:40 -0000 1.82
+++ compiler/goal_util.m 28 Feb 2003 15:50:50 -0000
@@ -504,6 +504,7 @@
goal_util__rename_generic_call(class_method(Var0, Method, ClassId, MethodId),
Must, Subn, class_method(Var, Method, ClassId, MethodId)) :-
goal_util__rename_var(Var0, Must, Subn, Var).
+goal_util__rename_generic_call(unsafe_cast, _, _, unsafe_cast).
goal_util__rename_generic_call(aditi_builtin(Builtin, PredCallId),
_Must, _Subn, aditi_builtin(Builtin, PredCallId)).
@@ -675,6 +676,7 @@
goal_util__generic_call_vars(higher_order(Var, _, _, _), [Var]).
goal_util__generic_call_vars(class_method(Var, _, _, _), [Var]).
+goal_util__generic_call_vars(unsafe_cast, []).
goal_util__generic_call_vars(aditi_builtin(_, _), []).
%-----------------------------------------------------------------------------%
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.103
diff -u -u -r1.103 higher_order.m
--- compiler/higher_order.m 28 Feb 2003 06:40:40 -0000 1.103
+++ compiler/higher_order.m 1 Mar 2003 08:22:50 -0000
@@ -1935,10 +1935,10 @@
;
NeedIntCast = yes,
goal_info_get_context(OrigGoalInfo, Context),
- generate_unsafe_type_cast(ModuleInfo, Context,
+ generate_unsafe_type_cast(Context,
CompareType, Arg1, CastArg1, CastGoal1,
ProcInfo0, ProcInfo1),
- generate_unsafe_type_cast(ModuleInfo, Context,
+ generate_unsafe_type_cast(Context,
CompareType, Arg2, CastArg2, CastGoal2,
ProcInfo1, ProcInfo),
NewCallArgs = [ComparisonResult,
@@ -2042,10 +2042,10 @@
Info = Info0 ^ proc_info := ProcInfo2
;
NeedIntCast = yes,
- generate_unsafe_type_cast(ModuleInfo, Context,
+ generate_unsafe_type_cast(Context,
CompareType, UnwrappedArg1, CastArg1,
CastGoal1, ProcInfo2, ProcInfo3),
- generate_unsafe_type_cast(ModuleInfo, Context,
+ generate_unsafe_type_cast(Context,
CompareType, UnwrappedArg2, CastArg2,
CastGoal2, ProcInfo3, ProcInfo4),
NewCallArgs = [ComparisonResult,
@@ -2183,32 +2183,21 @@
SpecialId = compare
).
-:- pred generate_unsafe_type_cast(module_info::in, prog_context::in,
+:- pred generate_unsafe_type_cast(prog_context::in,
(type)::in, prog_var::in, prog_var::out, hlds_goal::out,
proc_info::in, proc_info::out) is det.
-generate_unsafe_type_cast(ModuleInfo, Context, ToType, Arg, CastArg, Goal,
+generate_unsafe_type_cast(Context, ToType, Arg, CastArg, Goal,
ProcInfo0, ProcInfo) :-
- module_info_get_predicate_table(ModuleInfo, PredicateTable),
- mercury_private_builtin_module(MercuryBuiltin),
- (
- predicate_table_search_pred_m_n_a(PredicateTable,
- is_fully_qualified, MercuryBuiltin,
- "unsafe_type_cast", 2, [PredIdPrime])
- ->
- PredId = PredIdPrime
- ;
- error("generate_unsafe_type_cast: pred table lookup failed")
- ),
- hlds_pred__initial_proc_id(ProcId),
proc_info_create_var_from_type(ProcInfo0, ToType, no,
CastArg, ProcInfo),
set__list_to_set([Arg, CastArg], NonLocals),
- instmap_delta_from_assoc_list([CastArg - ground(shared, none)],
+ instmap_delta_from_assoc_list([CastArg - ground_inst],
InstMapDelta),
- goal_info_init(NonLocals, InstMapDelta, det, pure, Context, GoalInfo),
- Goal = call(PredId, ProcId, [Arg, CastArg], inline_builtin,
- no, qualified(MercuryBuiltin, "unsafe_type_cast")) - GoalInfo.
+ goal_info_init(NonLocals, InstMapDelta, det, pure,
+ Context, GoalInfo),
+ Goal = generic_call(unsafe_cast, [Arg, CastArg],
+ [in_mode, out_mode], det) - GoalInfo.
:- pred unwrap_no_tag_arg((type)::in, prog_context::in, sym_name::in,
prog_var::in, prog_var::out, hlds_goal::out,
Index: compiler/hlds_goal.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_goal.m,v
retrieving revision 1.102
diff -u -u -r1.102 hlds_goal.m
--- compiler/hlds_goal.m 28 Feb 2003 00:21:37 -0000 1.102
+++ compiler/hlds_goal.m 1 Mar 2003 06:49:17 -0000
@@ -227,6 +227,11 @@
simple_call_id % name of the called method
)
+ % unsafe_cast(Input, Output).
+ % Assigns `Input' to `Output', performing a type
+ % and/or inst cast.
+ ; unsafe_cast
+
; aditi_builtin(
aditi_builtin,
simple_call_id
@@ -998,41 +1003,44 @@
list(string)).
:- mode get_pragma_foreign_var_names(in, out) is det.
+ %
+ % Produce a goal to construct or deconstruct a
+ % tuple containing the given list of arguments,
+ % filling in the non-locals, instmap_delta and
+ % determinism fields of the goal_info.
+ %
+
+:- pred construct_tuple(prog_var, list(prog_var), hlds_goal).
+:- mode construct_tuple(in, in, out) is det.
+
+:- pred deconstruct_tuple(prog_var, list(prog_var), hlds_goal).
+:- mode deconstruct_tuple(in, in, out) is det.
+
%-----------------------------------------------------------------------------%
%
% Stuff specific to Aditi.
%
- % Builtin Aditi operations.
+ % Builtin Aditi operations.
+ % These are transformed into ordinary Mercury calls
+ % by aditi_builtin_ops.m before code generation.
:- type aditi_builtin
--->
- % Call an Aditi predicate from Mercury compiled to C.
- % This is introduced by magic.m.
- % Arguments:
- % type-infos for the input arguments
- % the input arguments
- % type-infos for the output arguments
- % the output arguments
- aditi_call(
- pred_proc_id, % procedure to call
- int, % number of inputs
- list(type), % types of input arguments
- int % number of outputs
- )
-
% Insert or delete a single tuple into/from a base relation.
% Arguments:
- % type-infos for the arguments of the tuple to insert
% the arguments of tuple to insert
- % aditi__state::di, aditi__state::uo
- ; aditi_tuple_insert_delete(
+ % aditi__state::di, aditi__state::uo
+ aditi_tuple_insert_delete(
aditi_insert_delete,
pred_id % base relation to insert into
)
% Insert/delete/modify operations which take
% an input closure.
- % These operations all have two variants.
+ % Arguments:
+ % the closure producing the tuples to insert/delete/modify
+ % aditi__state::di, aditi__state::uo
+ % These operations all have two variants.
%
% A pretty syntax:
%
@@ -1129,9 +1137,11 @@
:- implementation.
:- import_module check_hlds__purity.
-:- import_module check_hlds__det_analysis, parse_tree__prog_util.
+:- import_module check_hlds__det_analysis, check_hlds__mode_util.
+:- import_module parse_tree__prog_util.
:- import_module check_hlds__type_util.
-:- import_module require, string, term, varset.
+:- import_module parse_tree__prog_util.
+:- import_module assoc_list, require, string, term, varset.
%-----------------------------------------------------------------------------%
%
@@ -1143,12 +1153,14 @@
hlds_goal__generic_call_id(
class_method(_, _, ClassId, MethodId),
generic_call(class_method(ClassId, MethodId))).
+hlds_goal__generic_call_id(unsafe_cast, generic_call(unsafe_cast)).
hlds_goal__generic_call_id(aditi_builtin(Builtin, Name),
generic_call(aditi_builtin(Builtin, Name))).
generic_call_pred_or_func(higher_order(_, _, PredOrFunc, _)) = PredOrFunc.
generic_call_pred_or_func(class_method(_, _, _, CallId)) =
simple_call_id_pred_or_func(CallId).
+generic_call_pred_or_func(unsafe_cast) = predicate.
generic_call_pred_or_func(aditi_builtin(_, CallId)) =
simple_call_id_pred_or_func(CallId).
@@ -1788,6 +1800,42 @@
instmap_delta_init_reachable(InstMapDelta0),
instmap_delta_insert(InstMapDelta0, Var, Inst, InstMapDelta),
goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo).
+
+construct_tuple(Tuple, Args, Goal) :-
+ list__length(Args, Arity),
+ ConsId = cons(unqualified("{}"), Arity),
+ Rhs = functor(ConsId, no, Args),
+ UnifyMode = (free_inst -> ground_inst) - (ground_inst -> ground_inst),
+ UniMode = ((free_inst - ground_inst) -> (ground_inst - ground_inst)),
+ list__duplicate(Arity, UniMode, UniModes),
+ ExprnId = no,
+ Unification = construct(Tuple, ConsId, Args, UniModes,
+ construct_dynamically, cell_is_unique, ExprnId),
+ UnifyContext = unify_context(explicit, []),
+ Unify = unify(Tuple, Rhs, UnifyMode, Unification, UnifyContext),
+ set__list_to_set([Tuple | Args], NonLocals),
+ instmap_delta_from_assoc_list([Tuple - ground_inst], InstMapDelta),
+ goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo),
+ Goal = Unify - GoalInfo.
+
+deconstruct_tuple(Tuple, Args, Goal) :-
+ list__length(Args, Arity),
+ ConsId = cons(unqualified("{}"), Arity),
+ Rhs = functor(ConsId, no, Args),
+ UnifyMode = (ground_inst -> free_inst) - (ground_inst -> ground_inst),
+ UniMode = ((ground_inst - free_inst) -> (ground_inst - ground_inst)),
+ list__duplicate(Arity, UniMode, UniModes),
+ UnifyContext = unify_context(explicit, []),
+ CanGC = no,
+ Unification = deconstruct(Tuple, ConsId, Args,
+ UniModes, cannot_fail, CanGC),
+ Unify = unify(Tuple, Rhs, UnifyMode, Unification, UnifyContext),
+ set__list_to_set([Tuple | Args], NonLocals),
+ list__duplicate(Arity, ground_inst, DeltaValues),
+ assoc_list__from_corresponding_lists(Args, DeltaValues, DeltaAL),
+ instmap_delta_from_assoc_list(DeltaAL, InstMapDelta),
+ goal_info_init(NonLocals, InstMapDelta, det, pure, GoalInfo),
+ Goal = Unify - GoalInfo.
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.297
diff -u -u -r1.297 hlds_out.m
--- compiler/hlds_out.m 28 Feb 2003 06:40:41 -0000 1.297
+++ compiler/hlds_out.m 28 Feb 2003 15:50:51 -0000
@@ -471,6 +471,9 @@
hlds_out__write_generic_call_id(class_method(_ClassId, MethodId)) -->
hlds_out__write_simple_call_id(MethodId).
+hlds_out__write_generic_call_id(unsafe_cast) -->
+ io__write_string("unsafe_cast").
+
hlds_out__write_generic_call_id(
aditi_builtin(AditiBuiltin, CallId)) -->
{ hlds_out__aditi_builtin_name(AditiBuiltin, Name) },
@@ -495,14 +498,11 @@
(
(
% The text printed for generic calls other than
- % `aditi_call' and `class__method' does not need
- % the "call to" prefix ("in call to higher-order
- % call" is redundant, it's much better to just say
- % "in higher-order call").
+ % `class__method' does not need the "call to"
+ % prefix ("in call to higher-order call" is redundant,
+ % it's much better to just say "in higher-order call").
{ CallId = generic_call(GenericCall) },
- \+ { GenericCall = class_method(_, _) },
- \+ { GenericCall = aditi_builtin(aditi_call(_, _,
- _, _), _) }
+ \+ { GenericCall = class_method(_, _) }
;
% For calls from type class instance implementations
% that were defined using the named syntax rather
@@ -558,6 +558,10 @@
io__write_string("argument "),
io__write_int(ArgNum).
+hlds_out__write_arg_number(generic_call(unsafe_cast), ArgNum) -->
+ io__write_string("argument "),
+ io__write_int(ArgNum).
+
hlds_out__write_arg_number(generic_call(aditi_builtin(Builtin, CallId)),
ArgNum) -->
hlds_out__write_aditi_builtin_arg_number(Builtin, CallId, ArgNum).
@@ -566,10 +570,6 @@
int, io__state, io__state).
:- mode hlds_out__write_aditi_builtin_arg_number(in, in, in, di, uo) is det.
-hlds_out__write_aditi_builtin_arg_number(aditi_call(_, _, _, _), _, ArgNum) -->
- io__write_string("argument "),
- io__write_int(ArgNum).
-
hlds_out__write_aditi_builtin_arg_number(
aditi_tuple_insert_delete(InsertDelete, _),
_ - _/Arity, ArgNum) -->
@@ -934,6 +934,38 @@
% string(Verbose))
;
[]
+ ),
+
+ { pred_info_get_maybe_instance_method_constraints(PredInfo,
+ MaybeCs) },
+ ( { MaybeCs = yes(MethodConstraints) } ->
+ { MethodConstraints = instance_method_constraints(
+ ClassId, InstanceTypes, InstanceConstraints,
+ ClassMethodConstraints) },
+ io__write_string("% instance method constraints:\n"),
+ { ClassId = class_id(ClassName, _) },
+ mercury_output_constraint(TVarSet, AppendVarnums,
+ constraint(ClassName, InstanceTypes)),
+ io__nl,
+ io__write_string("instance constraints: "),
+ io__write_list(InstanceConstraints, ", ",
+ mercury_output_constraint(TVarSet, AppendVarnums)),
+ io__nl,
+
+ { ClassMethodConstraints = constraints(
+ MethodUnivConstraints,
+ MethodExistConstraints) },
+ io__write_string("method univ constraints: "),
+ io__write_list(MethodUnivConstraints, ", ",
+ mercury_output_constraint(TVarSet, AppendVarnums)),
+ io__nl,
+ io__write_string("method exist constraints: "),
+ io__write_list(MethodExistConstraints, ", ",
+ mercury_output_constraint(TVarSet, AppendVarnums)),
+ io__nl
+
+ ;
+ []
)
;
[]
@@ -1491,7 +1523,7 @@
io__write_string(Follow)
).
-hlds_out__write_goal_2(generic_call(GenericCall, ArgVars, _, _),
+hlds_out__write_goal_2(generic_call(GenericCall, ArgVars, Modes, _),
ModuleInfo, VarSet, AppendVarnums, Indent, Follow, _) -->
% XXX we should print more info here
(
@@ -1549,6 +1581,32 @@
mercury_output_term(Term, VarSet, AppendVarnums),
io__write_string(Follow)
;
+ { GenericCall = unsafe_cast },
+ globals__io_lookup_string_option(dump_hlds_options, Verbose),
+ hlds_out__write_indent(Indent),
+ ( { string__contains_char(Verbose, 'l') } ->
+ io__write_string("% unsafe_cast\n"),
+ hlds_out__write_indent(Indent)
+ ;
+ []
+ ),
+ ( { string__contains_char(Verbose, 'i') } ->
+ hlds_out__write_indent(Indent),
+ io__write_string("% modes: "),
+ { varset__init(InstVarSet) },
+ mercury_output_mode_list(Modes, InstVarSet),
+ io__nl,
+ hlds_out__write_indent(Indent)
+ ;
+ []
+ ),
+ { Functor = term__atom("unsafe_cast") },
+ { term__var_list_to_term_list(ArgVars, ArgTerms) },
+ { term__context_init(Context) },
+ { Term = term__functor(Functor, ArgTerms, Context) },
+ mercury_output_term(Term, VarSet, AppendVarnums),
+ io__write_string(Follow)
+ ;
{ GenericCall = aditi_builtin(AditiBuiltin, CallId) },
hlds_out__write_aditi_builtin(ModuleInfo, AditiBuiltin, CallId,
ArgVars, VarSet, AppendVarnums, Indent, Follow)
@@ -1995,21 +2053,6 @@
:- mode hlds_out__write_aditi_builtin(in, in, in, in, in, in, in, in,
di, uo) is det.
-hlds_out__write_aditi_builtin(ModuleInfo,
- aditi_call(PredProcId, _NumInputs, _InputTypes, _NumOutputs),
- _CallId, ArgVars, VarSet, AppendVarnums,
- Indent, Follow) -->
- hlds_out__write_indent(Indent),
- io__write_string("aditi_call "),
- % XXX should avoid dependency on rl.m here
- { rl__get_entry_proc_name(ModuleInfo, PredProcId, ProcName) },
- io__write(ProcName),
- io__write_string("("),
- mercury_output_vars(ArgVars, VarSet, AppendVarnums),
- io__write_string(")"),
- io__write_string(Follow),
- io__nl.
-
hlds_out__write_aditi_builtin(_ModuleInfo,
aditi_tuple_insert_delete(InsertDelete, PredId), CallId,
ArgVars, VarSet, AppendVarnums, Indent, Follow) -->
@@ -2076,7 +2119,6 @@
io__write_int(PredInt),
io__write_string(".\n").
-hlds_out__aditi_builtin_name(aditi_call(_, _, _, _), "aditi_call").
hlds_out__aditi_builtin_name(aditi_tuple_insert_delete(_, _), "aditi_insert").
hlds_out__aditi_builtin_name(aditi_insert_delete_modify(InsertDelMod, _, _),
Name) :-
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.118
diff -u -u -r1.118 hlds_pred.m
--- compiler/hlds_pred.m 28 Feb 2003 06:40:41 -0000 1.118
+++ compiler/hlds_pred.m 28 Feb 2003 15:50:51 -0000
@@ -96,6 +96,7 @@
:- type generic_call_id
---> higher_order(purity, pred_or_func, arity)
; class_method(class_id, simple_call_id)
+ ; unsafe_cast
; aditi_builtin(aditi_builtin, simple_call_id)
.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.133
diff -u -u -r1.133 intermod.m
--- compiler/intermod.m 28 Feb 2003 06:40:41 -0000 1.133
+++ compiler/intermod.m 1 Mar 2003 08:23:24 -0000
@@ -488,8 +488,13 @@
%
intermod__add_proc(PredId, DoWrite).
-intermod__traverse_goal(generic_call(A,B,C,D) - Info,
- generic_call(A,B,C,D) - Info, yes) --> [].
+intermod__traverse_goal(generic_call(CallType, B,C,D) - Info,
+ generic_call(CallType, B,C,D) - Info, DoWrite) -->
+ { CallType = higher_order(_, _, _, _), DoWrite = yes
+ ; CallType = class_method(_, _, _, _), DoWrite = no
+ ; CallType = unsafe_cast, DoWrite = no
+ ; CallType = aditi_builtin(_, _), DoWrite = yes
+ }.
intermod__traverse_goal(switch(A, B, Cases0) - Info,
switch(A, B, Cases) - Info, DoWrite) -->
Index: compiler/livemap.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.53
diff -u -u -r1.53 livemap.m
--- compiler/livemap.m 7 May 2002 11:02:49 -0000 1.53
+++ compiler/livemap.m 20 Dec 2002 05:05:30 -0000
@@ -466,14 +466,6 @@
livemap__special_code_addr(do_fail, no).
livemap__special_code_addr(do_call_closure, no).
livemap__special_code_addr(do_call_class_method, no).
-livemap__special_code_addr(do_det_aditi_call, no).
-livemap__special_code_addr(do_semidet_aditi_call, no).
-livemap__special_code_addr(do_nondet_aditi_call, no).
-livemap__special_code_addr(do_aditi_insert, no).
-livemap__special_code_addr(do_aditi_delete, no).
-livemap__special_code_addr(do_aditi_bulk_insert, no).
-livemap__special_code_addr(do_aditi_bulk_delete, no).
-livemap__special_code_addr(do_aditi_bulk_modify, no).
livemap__special_code_addr(do_not_reached, no).
%-----------------------------------------------------------------------------%
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.288
diff -u -u -r1.288 llds.m
--- compiler/llds.m 30 Sep 2002 06:08:12 -0000 1.288
+++ compiler/llds.m 22 Dec 2002 02:21:37 -0000
@@ -946,14 +946,6 @@
% on entry to the given procedure.
; do_call_closure
; do_call_class_method
- ; do_det_aditi_call
- ; do_semidet_aditi_call
- ; do_nondet_aditi_call
- ; do_aditi_insert
- ; do_aditi_delete
- ; do_aditi_bulk_insert
- ; do_aditi_bulk_delete
- ; do_aditi_bulk_modify
; do_not_reached. % We should never jump to this address.
% A proc_label is a label used for the entry point to a procedure.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.204
diff -u -u -r1.204 llds_out.m
--- compiler/llds_out.m 26 Feb 2003 06:36:23 -0000 1.204
+++ compiler/llds_out.m 28 Feb 2003 15:50:53 -0000
@@ -217,12 +217,6 @@
:- pred llds_out__make_init_name(module_name, string).
:- mode llds_out__make_init_name(in, out) is det.
- % Returns the name of the Aditi-RL code constant
- % for a given module.
-
-:- pred llds_out__make_rl_data_name(module_name, string).
-:- mode llds_out__make_rl_data_name(in, out) is det.
-
% Print out the name of the tabling variable for the specified
% procedure.
@@ -425,7 +419,7 @@
{ decl_set_init(DeclSet0) },
output_c_module_init_list(ModuleName, Modules, Datas,
StackLayoutLabels, DeclSet0, _DeclSet),
- output_rl_file(ModuleName, MaybeRLFile),
+ c_util__output_rl_file(ModuleName, MaybeRLFile),
io__set_output_stream(OutputStream, _),
io__close_output(FileStream)
;
@@ -545,7 +539,7 @@
output_c_module_init_list(ModuleName, Modules, Datas,
StackLayoutLabels, DeclSet5, _DeclSet)
),
- output_rl_file(ModuleName, MaybeRLFile),
+ c_util__output_rl_file(ModuleName, MaybeRLFile),
io__set_output_stream(OutputStream, _),
io__close_output(FileStream)
;
@@ -855,7 +849,7 @@
io__write_string("init\n"),
globals__io_lookup_bool_option(aditi, Aditi),
( { Aditi = yes } ->
- { llds_out__make_rl_data_name(ModuleName, RLName) },
+ { c_util__make_rl_data_name(ModuleName, RLName) },
io__write_string("ADITI_DATA "),
io__write_string(RLName),
io__write_string("\n")
@@ -877,11 +871,6 @@
string__append_list(["mercury__", MangledModuleName, "__"],
InitName).
-llds_out__make_rl_data_name(ModuleName, RLDataConstName) :-
- llds_out__sym_name_mangle(ModuleName, MangledModuleName),
- string__append("mercury__aditi_rl_data__", MangledModuleName,
- RLDataConstName).
-
:- pred output_bunch_name(module_name, string, int, io__state, io__state).
:- mode output_bunch_name(in, in, in, di, uo) is det.
@@ -2955,14 +2944,6 @@
need_code_addr_decls(do_trace_redo_fail_deep, yes) --> [].
need_code_addr_decls(do_call_closure, yes) --> [].
need_code_addr_decls(do_call_class_method, yes) --> [].
-need_code_addr_decls(do_det_aditi_call, yes) --> [].
-need_code_addr_decls(do_semidet_aditi_call, yes) --> [].
-need_code_addr_decls(do_nondet_aditi_call, yes) --> [].
-need_code_addr_decls(do_aditi_insert, yes) --> [].
-need_code_addr_decls(do_aditi_delete, yes) --> [].
-need_code_addr_decls(do_aditi_bulk_insert, yes) --> [].
-need_code_addr_decls(do_aditi_bulk_delete, yes) --> [].
-need_code_addr_decls(do_aditi_bulk_modify, yes) --> [].
need_code_addr_decls(do_not_reached, yes) --> [].
:- pred output_code_addr_decls(code_addr, io__state, io__state).
@@ -3004,24 +2985,6 @@
io__write_string("MR_declare_entry(mercury__do_call_closure);\n").
output_code_addr_decls(do_call_class_method) -->
io__write_string("MR_declare_entry(mercury__do_call_class_method);\n").
-% XXX The do_*_aditi_call and do_aditi_* entry point names
-% should start with an `MADITI_' prefix.
-output_code_addr_decls(do_det_aditi_call) -->
- io__write_string("MR_declare_entry(do_det_aditi_call);\n").
-output_code_addr_decls(do_semidet_aditi_call) -->
- io__write_string("MR_declare_entry(do_semidet_aditi_call);\n").
-output_code_addr_decls(do_nondet_aditi_call) -->
- io__write_string("MR_declare_entry(do_nondet_aditi_call);\n").
-output_code_addr_decls(do_aditi_insert) -->
- io__write_string("MR_declare_entry(do_aditi_insert);\n").
-output_code_addr_decls(do_aditi_delete) -->
- io__write_string("MR_declare_entry(do_aditi_delete);\n").
-output_code_addr_decls(do_aditi_bulk_insert) -->
- io__write_string("MR_declare_entry(do_aditi_bulk_insert);\n").
-output_code_addr_decls(do_aditi_bulk_delete) -->
- io__write_string("MR_declare_entry(do_aditi_bulk_delete);\n").
-output_code_addr_decls(do_aditi_bulk_modify) -->
- io__write_string("MR_declare_entry(do_aditi_bulk_modify);\n").
output_code_addr_decls(do_not_reached) -->
io__write_string("MR_declare_entry(MR_do_not_reached);\n").
@@ -3278,40 +3241,6 @@
io__write_string(");\n\t\t"),
io__write_string(
"MR_noprof_tailcall(MR_ENTRY(mercury__do_call_class_method));\n").
-% XXX The do_*_aditi_call and do_aditi_* entry point names
-% should start with an `MADITI_' prefix.
-output_goto(do_det_aditi_call, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_det_aditi_call),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
-output_goto(do_semidet_aditi_call, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_semidet_aditi_call),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
-output_goto(do_nondet_aditi_call, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_nondet_aditi_call),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
-output_goto(do_aditi_insert, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_aditi_insert),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
-output_goto(do_aditi_delete, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_aditi_delete),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
-output_goto(do_aditi_bulk_insert, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_aditi_bulk_insert),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
-output_goto(do_aditi_bulk_delete, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_aditi_bulk_delete),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
-output_goto(do_aditi_bulk_modify, CallerLabel) -->
- io__write_string("MR_tailcall(MR_ENTRY(do_aditi_bulk_modify),\n\t\t"),
- output_label_as_code_addr(CallerLabel),
- io__write_string(");\n").
output_goto(do_not_reached, CallerLabel) -->
io__write_string("MR_tailcall(MR_ENTRY(MR_do_not_reached),\n\t\t"),
output_label_as_code_addr(CallerLabel),
@@ -3410,22 +3339,6 @@
io__write_string("MR_ENTRY(mercury__do_call_closure)").
output_code_addr(do_call_class_method) -->
io__write_string("MR_ENTRY(mercury__do_call_class_method)").
-output_code_addr(do_det_aditi_call) -->
- io__write_string("MR_ENTRY(do_det_aditi_call)").
-output_code_addr(do_semidet_aditi_call) -->
- io__write_string("MR_ENTRY(do_semidet_aditi_call)").
-output_code_addr(do_nondet_aditi_call) -->
- io__write_string("MR_ENTRY(do_nondet_aditi_call)").
-output_code_addr(do_aditi_insert) -->
- io__write_string("MR_ENTRY(do_aditi_insert)").
-output_code_addr(do_aditi_delete) -->
- io__write_string("MR_ENTRY(do_aditi_delete)").
-output_code_addr(do_aditi_bulk_insert) -->
- io__write_string("MR_ENTRY(do_aditi_bulk_insert)").
-output_code_addr(do_aditi_bulk_delete) -->
- io__write_string("MR_ENTRY(do_aditi_bulk_delete)").
-output_code_addr(do_aditi_bulk_modify) -->
- io__write_string("MR_ENTRY(do_aditi_bulk_modify)").
output_code_addr(do_not_reached) -->
io__write_string("MR_ENTRY(MR_do_not_reached)").
@@ -4519,52 +4432,5 @@
Labels1 = Labels0
),
gather_labels_from_instrs(Instrs, Labels1, Labels).
-
-%-----------------------------------------------------------------------------%
-
- % Currently the `.rlo' files are stored as static data in the
- % executable. It may be better to store them in separate files
- % in a known location and load them at runtime.
-:- pred output_rl_file(module_name, maybe(rl_file), io__state, io__state).
-:- mode output_rl_file(in, in, di, uo) is det.
-
-output_rl_file(ModuleName, MaybeRLFile) -->
- globals__io_lookup_bool_option(aditi, Aditi),
- ( { Aditi = no } ->
- []
- ;
- io__write_string("\n\n/* Aditi-RL code for this module. */\n"),
- { llds_out__make_rl_data_name(ModuleName, RLDataConstName) },
- io__write_string("const char "),
- io__write_string(RLDataConstName),
- io__write_string("[] = {"),
- (
- { MaybeRLFile = yes(RLFile) },
- rl_file__write_binary(output_rl_byte, RLFile, Length),
- io__write_string("0};\n")
- ;
- { MaybeRLFile = no },
- io__write_string("};\n"),
- { Length = 0 }
- ),
-
- % Store the length of the data in
- % mercury__aditi_rl_data__<module>__length.
-
- { string__append(RLDataConstName, "__length",
- RLDataConstLength) },
- io__write_string("const int "),
- io__write_string(RLDataConstLength),
- io__write_string(" = "),
- io__write_int(Length),
- io__write_string(";\n\n")
- ).
-
-:- pred output_rl_byte(int, io__state, io__state).
-:- mode output_rl_byte(in, di, uo) is det.
-
-output_rl_byte(Byte) -->
- io__write_int(Byte),
- io__write_string(", ").
%-----------------------------------------------------------------------------%
Index: compiler/magic.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic.m,v
retrieving revision 1.33
diff -u -u -r1.33 magic.m
--- compiler/magic.m 28 Feb 2003 00:21:37 -0000 1.33
+++ compiler/magic.m 28 Feb 2003 15:55:27 -0000
@@ -73,12 +73,12 @@
%
% % The aditi__state is not needed (it contains no information),
% % so it is not passed.
-% % aditi_call(PredName, Number of inputs, Input relation schema,
-% % Number of Outputs)
-% generic_call(
-% aditi_call("stayl/a/a__anc__c_interface_2_0/2", 1, "(:I)", 1),
-% TypeInfo_13, HeadVar__2,
-% TypeInfo_14, HeadVar__3).
+% % aditi_private_builtin__do_nondet_call(PredName,
+% % InputSchema, InputTuple, OutputTuple)
+% aditi_private_builtin__do_nondet_call(
+% TypeInfo_13, TypeInfo_14,
+% "stayl/a/a__anc__c_interface_2_0/2", "(:I)",
+% {HeadVar__2}, {HeadVar__3}).
%
% :- pred anc__c_interface(pred(int)::(pred(out) is nondet),
% int::out) is nondet.
@@ -180,6 +180,7 @@
:- import_module parse_tree__prog_out, hlds__goal_util, check_hlds__type_util.
:- import_module check_hlds__polymorphism, hlds__quantification.
:- import_module ll_backend__saved_vars, transform_hlds__dead_proc_elim.
+:- import_module aditi_backend__aditi_builtin_ops.
:- import_module int, list, map, require, set, std_util, string, term, varset.
:- import_module assoc_list, bool, check_hlds__simplify.
@@ -1011,14 +1012,15 @@
magic_info_set_module_info(ModuleInfo)
;
{ magic__create_input_join_proc(CPredProcId, AditiPredProcId,
- JoinPredProcId, ModuleInfo1, ModuleInfo) },
- magic_info_set_module_info(ModuleInfo),
+ _JoinPredProcId, ModuleInfo1, ModuleInfo2) },
%
- % Create a procedure which is just a synonym
- % for do_*_aditi_call.
+ % Change the goal for the original procedure to
+ % call the database procedure.
%
- magic__create_aditi_call_proc(CPredProcId, JoinPredProcId)
+ { aditi_builtin_ops__create_aditi_call_proc(CPredProcId,
+ ModuleInfo2, ModuleInfo) },
+ magic_info_set_module_info(ModuleInfo)
).
% Make a procedure which calls the Aditi predicate, then joins
@@ -1153,120 +1155,6 @@
predicate_table_insert(Preds0, JoinPredInfo1, JoinPredId, Preds),
JoinPredProcId = proc(JoinPredId, JoinProcId),
module_info_set_predicate_table(ModuleInfo0, Preds, ModuleInfo).
-
- % The new procedure consists of a `aditi_call' goal,
- % which call_gen.m generates as a call to do_*_aditi_call in
- % extras/aditi/aditi.m.
- % This procedure must use the `compact' argument convention.
- % The arguments are:
- % 1 -> RL procedure name
- % 2 -> number of input arguments
- % 3 -> input schema
- % 4 -> number of output arguments
- % type_infos for input arguments
- % input arguments
- % type_infos for output arguments
- % output arguments
-:- pred magic__create_aditi_call_proc(pred_proc_id::in, pred_proc_id::in,
- magic_info::in, magic_info::out) is det.
-
-magic__create_aditi_call_proc(CPredProcId, AditiPredProcId) -->
- magic_info_get_module_info(ModuleInfo0),
- { module_info_pred_proc_info(ModuleInfo0, CPredProcId,
- CPredInfo0, CProcInfo0) },
- { pred_info_arg_types(CPredInfo0, ArgTypes) },
- { proc_info_argmodes(CProcInfo0, ArgModes) },
- { proc_info_headvars(CProcInfo0, HeadVars) },
-
- % Base relations will have an empty vartypes field, so fill it in here.
- { map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes0) },
- { proc_info_set_vartypes(CProcInfo0, VarTypes0, CProcInfo1) },
-
- %
- % Build type-infos for the arguments so do_*_aditi_call
- % can do the required data conversions.
- %
-
- { type_util__remove_aditi_state(ArgTypes, ArgTypes, ArgTypes1) },
- { type_util__remove_aditi_state(ArgTypes, ArgModes, ArgModes1) },
- { type_util__remove_aditi_state(ArgTypes, HeadVars, HeadVars1) },
-
- magic__make_type_info_vars(ArgTypes1, TypeInfoVars, TypeInfoGoals,
- CPredInfo0, CPredInfo1, CProcInfo1, CProcInfo2),
-
- magic_info_get_module_info(ModuleInfo1),
-
- { partition_args(ModuleInfo1, ArgModes1, ArgTypes1,
- InputArgTypes, _OutputArgTypes) },
- { partition_args(ModuleInfo1, ArgModes1, ArgModes1,
- InputArgModes, OutputArgModes) },
- { partition_args(ModuleInfo1, ArgModes1, TypeInfoVars,
- InputTypeInfoVars, OutputTypeInfoVars) },
- { partition_args(ModuleInfo1, ArgModes1,
- HeadVars1, InputArgs, OutputArgs) },
-
- %
- % Build up some other information that do_*_aditi_call needs.
- %
-
- % Argument variables.
- { list__condense([InputTypeInfoVars, InputArgs,
- OutputTypeInfoVars, OutputArgs], DoCallAditiArgs) },
-
- % Argument modes.
- { in_mode(InMode) },
- { list__length(InputArgs, NumInputArgs) },
- { list__length(OutputArgs, NumOutputArgs) },
- { list__duplicate(NumInputArgs, InMode, InputTypeInfoModes) },
- { list__duplicate(NumOutputArgs, InMode, OutputTypeInfoModes) },
- { list__condense([InputTypeInfoModes, InputArgModes,
- OutputTypeInfoModes, OutputArgModes], DoCallAditiArgModes) },
-
- %
- % Build the `aditi_call' goal.
- %
- { set__list_to_set(DoCallAditiArgs, CallNonLocals) },
- { instmap_delta_from_mode_list(DoCallAditiArgs, DoCallAditiArgModes,
- ModuleInfo1, GoalDelta) },
- { proc_info_inferred_determinism(CProcInfo2, Detism) },
- { goal_info_init(CallNonLocals, GoalDelta,
- Detism, pure, CallGoalInfo) },
- { pred_info_get_is_pred_or_func(CPredInfo1, CPredOrFunc) },
- { pred_info_module(CPredInfo1, CPredModule) },
- { pred_info_name(CPredInfo1, CPredName) },
- { pred_info_arity(CPredInfo1, Arity) },
- { DoCallAditiGoal =
- generic_call(aditi_builtin(
- aditi_call(AditiPredProcId, NumInputArgs,
- InputArgTypes, NumOutputArgs),
- CPredOrFunc - qualified(CPredModule, CPredName)/Arity),
- DoCallAditiArgs, DoCallAditiArgModes, Detism) - CallGoalInfo },
- { list__append(TypeInfoGoals, [DoCallAditiGoal], Goals) },
- { set__list_to_set(HeadVars, GoalNonLocals) },
- { goal_list_determinism(Goals, GoalDetism) },
- { goal_info_init(GoalNonLocals, GoalDelta, GoalDetism,
- pure, GoalInfo) },
- { Goal = conj(Goals) - GoalInfo },
- { proc_info_set_goal(CProcInfo2, Goal, CProcInfo) },
-
- { module_info_set_pred_proc_info(ModuleInfo1, CPredProcId,
- CPredInfo1, CProcInfo, ModuleInfo) },
- magic_info_set_module_info(ModuleInfo).
-
-:- pred magic__make_type_info_vars(list(type)::in, list(prog_var)::out,
- list(hlds_goal)::out, pred_info::in, pred_info::out,
- proc_info::in, proc_info::out, magic_info::in, magic_info::out) is det.
-
-magic__make_type_info_vars(Types, TypeInfoVars, TypeInfoGoals,
- PredInfo0, PredInfo, ProcInfo0, ProcInfo) -->
- magic_info_get_module_info(ModuleInfo0),
- { create_poly_info(ModuleInfo0, PredInfo0, ProcInfo0, PolyInfo0) },
- { term__context_init(Context) },
- { polymorphism__make_type_info_vars(Types, Context,
- TypeInfoVars, TypeInfoGoals, PolyInfo0, PolyInfo) },
- { poly_info_extract(PolyInfo, PredInfo0, PredInfo,
- ProcInfo0, ProcInfo, ModuleInfo) },
- magic_info_set_module_info(ModuleInfo).
%-----------------------------------------------------------------------------%
Index: compiler/maybe_mlds_to_gcc.pp
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/maybe_mlds_to_gcc.pp,v
retrieving revision 1.5
diff -u -u -r1.5 maybe_mlds_to_gcc.pp
--- compiler/maybe_mlds_to_gcc.pp 20 Mar 2002 12:35:47 -0000 1.5
+++ compiler/maybe_mlds_to_gcc.pp 4 Mar 2003 05:20:37 -0000
@@ -17,7 +17,8 @@
:- module ml_backend__maybe_mlds_to_gcc.
:- interface.
-:- import_module ml_backend__mlds, bool.
+:- import_module ml_backend__mlds, aditi_backend__rl_file.
+:- import_module bool, std_util.
:- use_module io.
:- type frontend_callback(T) == pred(T, io__state, io__state).
@@ -35,9 +36,9 @@
% message, depending on whether the gcc back-end interface has
% been enabled. In the former case,
% the bool returned is `yes' iff the module contained C code.
-:- pred maybe_mlds_to_gcc__compile_to_asm(mlds__mlds, bool,
+:- pred maybe_mlds_to_gcc__compile_to_asm(mlds__mlds, maybe(rl_file), bool,
io__state, io__state).
-:- mode maybe_mlds_to_gcc__compile_to_asm(in, out, di, uo) is det.
+:- mode maybe_mlds_to_gcc__compile_to_asm(in, in, out, di, uo) is det.
%-----------------------------------------------------------------------------%
@@ -50,8 +51,8 @@
maybe_mlds_to_gcc__run_gcc_backend(ModuleName, CallBack, CallBackOutput) -->
mlds_to_gcc__run_gcc_backend(ModuleName, CallBack, CallBackOutput).
-maybe_mlds_to_gcc__compile_to_asm(MLDS, ContainsCCode) -->
- mlds_to_gcc__compile_to_asm(MLDS, ContainsCCode).
+maybe_mlds_to_gcc__compile_to_asm(MLDS, RLFile, ContainsCCode) -->
+ mlds_to_gcc__compile_to_asm(MLDS, RLFile, ContainsCCode).
#else
@@ -61,7 +62,7 @@
maybe_mlds_to_gcc__run_gcc_backend(_ModuleName, CallBack, CallBackOutput) -->
CallBack(CallBackOutput).
-maybe_mlds_to_gcc__compile_to_asm(_MLDS, no) -->
+maybe_mlds_to_gcc__compile_to_asm(_MLDS, _, no) -->
report_error(
"Sorry, `--target asm' not supported: this installation of the Mercury\n" ++
"compiler was built without support for the GCC back-end interface.").
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.278
diff -u -u -r1.278 mercury_compile.m
--- compiler/mercury_compile.m 1 Mar 2003 06:34:51 -0000 1.278
+++ compiler/mercury_compile.m 4 Mar 2003 13:04:21 -0000
@@ -58,6 +58,7 @@
:- import_module transform_hlds__inlining, transform_hlds__loop_inv.
:- import_module transform_hlds__deforest.
:- import_module aditi_backend__dnf, aditi_backend__magic.
+:- import_module aditi_backend__aditi_builtin_ops.
:- import_module transform_hlds__dead_proc_elim.
:- import_module transform_hlds__delay_construct, transform_hlds__unused_args.
:- import_module transform_hlds__unneeded_code, transform_hlds__lco.
@@ -1345,7 +1346,7 @@
{ HLDS = HLDS50 },
mercury_compile__mlds_backend(HLDS, MLDS),
mercury_compile__maybe_mlds_to_gcc(MLDS,
- ContainsCCode),
+ MaybeRLFile, ContainsCCode),
( { TargetCodeOnly = yes } ->
[]
;
@@ -1391,7 +1392,8 @@
; { HighLevelCode = yes } ->
{ HLDS = HLDS50 },
mercury_compile__mlds_backend(HLDS, MLDS),
- mercury_compile__mlds_to_high_level_c(MLDS),
+ mercury_compile__mlds_to_high_level_c(MLDS,
+ MaybeRLFile),
( { TargetCodeOnly = yes } ->
[]
;
@@ -2093,8 +2095,12 @@
mercury_compile__maybe_lco(HLDS41, Verbose, Stats, HLDS43),
mercury_compile__maybe_dump_hlds(HLDS43, "43", "lco"),
+ mercury_compile__maybe_transform_aditi_builtins(HLDS43,
+ Verbose, Stats, HLDS44),
+ mercury_compile__maybe_dump_hlds(HLDS43, "44", "aditi_builtins"),
+
% DNF transformations should be after inlining.
- mercury_compile__maybe_transform_dnf(HLDS41, Verbose, Stats, HLDS45),
+ mercury_compile__maybe_transform_dnf(HLDS44, Verbose, Stats, HLDS45),
mercury_compile__maybe_dump_hlds(HLDS45, "45", "dnf"),
% Magic sets should be the last thing done to Aditi procedures
@@ -3209,6 +3215,25 @@
{ HLDS0 = HLDS }
).
+:- pred mercury_compile__maybe_transform_aditi_builtins(module_info,
+ bool, bool, module_info, io__state, io__state).
+:- mode mercury_compile__maybe_transform_aditi_builtins(in, in, in, out,
+ di, uo) is det.
+
+mercury_compile__maybe_transform_aditi_builtins(HLDS0,
+ Verbose, Stats, HLDS) -->
+ { module_info_get_do_aditi_compilation(HLDS0, Aditi) },
+ ( { Aditi = do_aditi_compilation } ->
+ maybe_write_string(Verbose,
+ "% Transforming away RL builtins...\n"),
+ maybe_flush_output(Verbose),
+ transform_aditi_builtins(HLDS0, HLDS),
+ maybe_write_string(Verbose, "% done.\n"),
+ maybe_report_stats(Stats)
+ ;
+ { HLDS0 = HLDS }
+ ).
+
%-----------------------------------------------------------------------------%
% The backend passes
@@ -3839,15 +3864,16 @@
% The `--high-level-C' MLDS output pass
-:- pred mercury_compile__mlds_to_high_level_c(mlds, io__state, io__state).
-:- mode mercury_compile__mlds_to_high_level_c(in, di, uo) is det.
+:- pred mercury_compile__mlds_to_high_level_c(mlds, maybe(rl_file),
+ io__state, io__state).
+:- mode mercury_compile__mlds_to_high_level_c(in, in, di, uo) is det.
-mercury_compile__mlds_to_high_level_c(MLDS) -->
+mercury_compile__mlds_to_high_level_c(MLDS, MaybeRLFile) -->
globals__io_lookup_bool_option(verbose, Verbose),
globals__io_lookup_bool_option(statistics, Stats),
maybe_write_string(Verbose, "% Converting MLDS to C...\n"),
- mlds_to_c__output_mlds(MLDS, ""),
+ mlds_to_c__output_mlds(MLDS, MaybeRLFile, ""),
maybe_write_string(Verbose, "% Finished converting MLDS to C.\n"),
maybe_report_stats(Stats).
@@ -3863,16 +3889,17 @@
maybe_write_string(Verbose, "% Finished converting MLDS to Java.\n"),
maybe_report_stats(Stats).
-:- pred mercury_compile__maybe_mlds_to_gcc(mlds, bool, io__state, io__state).
-:- mode mercury_compile__maybe_mlds_to_gcc(in, out, di, uo) is det.
+:- pred mercury_compile__maybe_mlds_to_gcc(mlds, maybe(rl_file),
+ bool, io__state, io__state).
+:- mode mercury_compile__maybe_mlds_to_gcc(in, in, out, di, uo) is det.
-mercury_compile__maybe_mlds_to_gcc(MLDS, ContainsCCode) -->
+mercury_compile__maybe_mlds_to_gcc(MLDS, MaybeRLFile, ContainsCCode) -->
globals__io_lookup_bool_option(verbose, Verbose),
globals__io_lookup_bool_option(statistics, Stats),
maybe_write_string(Verbose,
"% Passing MLDS to GCC and compiling to assembler...\n"),
- maybe_mlds_to_gcc__compile_to_asm(MLDS, ContainsCCode),
+ maybe_mlds_to_gcc__compile_to_asm(MLDS, MaybeRLFile, ContainsCCode),
maybe_write_string(Verbose, "% Finished compiling to assembler.\n"),
maybe_report_stats(Stats).
@@ -3963,7 +3990,7 @@
maybe_flush_output(Verbose),
{ string__append_list(["_dump.", StageNum, "-", StageName],
DumpSuffix) },
- mlds_to_c__output_mlds(MLDS, DumpSuffix),
+ mlds_to_c__output_mlds(MLDS, no, DumpSuffix),
maybe_write_string(Verbose, "% done.\n")
;
[]
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.38
diff -u -u -r1.38 ml_call_gen.m
--- compiler/ml_call_gen.m 14 Feb 2003 09:59:21 -0000 1.38
+++ compiler/ml_call_gen.m 1 Mar 2003 06:52:07 -0000
@@ -58,6 +58,14 @@
:- mode ml_gen_builtin(in, in, in, in, in, out, out, in, out) is det.
%
+ % Generate MLDS code for a cast. The list of argument variables
+ % must have only two elements, the input and the output.
+ %
+:- pred ml_gen_cast(prog_context, list(prog_var),
+ mlds__defns, mlds__statements, ml_gen_info, ml_gen_info).
+:- mode ml_gen_cast(in, in, out, out, in, out) is det.
+
+ %
% Generate an rval containing the address of the specified procedure.
%
:- pred ml_gen_proc_addr_rval(pred_id, proc_id, mlds__rval,
@@ -134,7 +142,26 @@
% XXX For typeclass method calls, we do some unnecessary
% boxing/unboxing of the arguments.
%
-ml_gen_generic_call(GenericCall, ArgVars, ArgModes, Determinism, Context,
+ml_gen_generic_call(higher_order(_, _, _, _) @ GenericCall, ArgVars, ArgModes,
+ Determinism, Context, MLDS_Decls, MLDS_Statements) -->
+ ml_gen_generic_call_2(GenericCall, ArgVars, ArgModes, Determinism,
+ Context, MLDS_Decls, MLDS_Statements).
+ml_gen_generic_call(class_method(_, _, _, _) @ GenericCall, ArgVars, ArgModes,
+ Determinism, Context, MLDS_Decls, MLDS_Statements) -->
+ ml_gen_generic_call_2(GenericCall, ArgVars, ArgModes, Determinism,
+ Context, MLDS_Decls, MLDS_Statements).
+ml_gen_generic_call(unsafe_cast, ArgVars, _ArgModes, _Determinism, Context,
+ MLDS_Decls, MLDS_Statements) -->
+ ml_gen_cast(Context, ArgVars, MLDS_Decls, MLDS_Statements).
+ml_gen_generic_call(aditi_builtin(_, _), _, _, _, _, _, _) -->
+ { error("ml_gen_generic_call: aditi_builtin") }.
+
+:- pred ml_gen_generic_call_2(generic_call, list(prog_var), list(mode),
+ determinism, prog_context, mlds__defns, mlds__statements,
+ ml_gen_info, ml_gen_info).
+:- mode ml_gen_generic_call_2(in, in, in, in, in, out, out, in, out) is det.
+
+ml_gen_generic_call_2(GenericCall, ArgVars, ArgModes, Determinism, Context,
MLDS_Decls, MLDS_Statements) -->
%
% allocate some fresh type variables to use as the Mercury types
@@ -216,8 +243,11 @@
{ FuncType = mlds__func_type(Params) },
{ FuncRval = unop(unbox(FuncType), lval(FuncLval)) }
;
+ { GenericCall = unsafe_cast },
+ { error("ml_gen_generic_call_2: unsafe_cast") }
+ ;
{ GenericCall = aditi_builtin(_, _) },
- { sorry(this_file, "Aditi builtins") }
+ { error("ml_gen_generic_call_2: aditi_builtin") }
),
%
@@ -296,6 +326,29 @@
),
{ MLDS_Decls = [FuncVarDecl | MLDS_Decls0] },
{ MLDS_Statements = [AssignFuncVar | MLDS_Statements0] }.
+
+ml_gen_cast(Context, ArgVars, MLDS_Decls, MLDS_Statements) -->
+ ml_gen_var_list(ArgVars, ArgLvals),
+ ml_variable_types(ArgVars, ArgTypes),
+ (
+ { ArgLvals = [SrcLval, DestLval] },
+ { ArgTypes = [SrcType, DestType] }
+ ->
+ ( { type_util__is_dummy_argument_type(DestType) } ->
+ { MLDS_Statements = [] }
+ ;
+ ml_gen_box_or_unbox_rval(SrcType, DestType,
+ lval(SrcLval), CastRval),
+ { Assign = ml_gen_assign(DestLval, CastRval,
+ Context) },
+ { MLDS_Statements = [Assign] }
+ ),
+ { MLDS_Decls = [] }
+ ;
+ { error("ml_gen_cast: wrong number of args for cast") }
+ ).
+
+%-----------------------------------------------------------------------------%
%
% Generate code for the various parts that are needed for
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.126
diff -u -u -r1.126 ml_code_gen.m
--- compiler/ml_code_gen.m 14 Feb 2003 09:59:21 -0000 1.126
+++ compiler/ml_code_gen.m 3 Mar 2003 14:24:47 -0000
@@ -699,7 +699,6 @@
% - support genuine parallel conjunction
% - support fact tables
% - support --split-c-files
-% - support aditi
% - support accurate GC
%
% POTENTIAL EFFICIENCY IMPROVEMENTS:
@@ -792,6 +791,7 @@
:- import_module backend_libs__c_util.
:- import_module hlds__passes_aux, parse_tree__modules.
:- import_module libs__globals, libs__options.
+:- import_module parse_tree__prog_util.
:- import_module assoc_list, bool, string, list.
:- import_module int, set, term, require, std_util.
@@ -962,7 +962,11 @@
->
{ map__lookup(PredTable, PredId, PredInfo) },
{ pred_info_import_status(PredInfo, ImportStatus) },
- ( { ImportStatus = imported(_) } ->
+ (
+ { ImportStatus = imported(_)
+ ; pred_info_is_aditi_relation(PredInfo)
+ }
+ ->
{ MLDS_Defns1 = MLDS_Defns0 }
;
ml_gen_pred(ModuleInfo, PredId, PredInfo, ImportStatus,
@@ -2077,7 +2081,7 @@
ml_gen_generic_call(GenericCall, Vars, Modes, Detism, Context,
MLDS_Decls, MLDS_Statements).
-ml_gen_goal_expr(call(PredId, ProcId, ArgVars, BuiltinState, _, PredName),
+ml_gen_goal_expr(call(PredId, ProcId, ArgVars, BuiltinState, _, _),
CodeModel, Context, MLDS_Decls, MLDS_Statements) -->
(
{ BuiltinState = not_builtin }
@@ -2089,34 +2093,6 @@
ml_variable_types(ArgVars, ActualArgTypes),
ml_gen_call(PredId, ProcId, ArgNames, ArgLvals, ActualArgTypes,
CodeModel, Context, no, MLDS_Decls, MLDS_Statements)
- ;
- % For the MLDS back-end, we can't treat
- % private_builtin:unsafe_type_cast as an
- % ordinary builtin, since the code that
- % builtin_ops__translate_builtin generates
- % for it is not type-correct. Instead,
- % we handle it separately here.
- { PredName = qualified(_, "unsafe_type_cast") }
- ->
- ml_gen_var_list(ArgVars, ArgLvals),
- ml_variable_types(ArgVars, ArgTypes),
- (
- { ArgLvals = [SrcLval, DestLval] },
- { ArgTypes = [SrcType, DestType] }
- ->
- ( { type_util__is_dummy_argument_type(DestType) } ->
- { MLDS_Statements = [] }
- ;
- ml_gen_box_or_unbox_rval(SrcType, DestType,
- lval(SrcLval), CastRval),
- { Assign = ml_gen_assign(DestLval, CastRval,
- Context) },
- { MLDS_Statements = [Assign] }
- ),
- { MLDS_Decls = [] }
- ;
- { error("wrong number of args for unsafe_type_cast") }
- )
;
ml_gen_builtin(PredId, ProcId, ArgVars, CodeModel, Context,
MLDS_Decls, MLDS_Statements)
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.143
diff -u -u -r1.143 mlds_to_c.m
--- compiler/mlds_to_c.m 26 Feb 2003 06:36:24 -0000 1.143
+++ compiler/mlds_to_c.m 28 Feb 2003 15:50:55 -0000
@@ -23,18 +23,19 @@
:- module ml_backend__mlds_to_c.
:- interface.
-:- import_module ml_backend__mlds.
-:- import_module io.
+:- import_module ml_backend__mlds, aditi_backend__rl_file.
+:- import_module io, std_util.
- % output_mlds(MLDS, Suffix):
+ % output_mlds(MLDS, MaybeRLFile, Suffix):
% Output C code the the appropriate C file and
% C declarations to the appropriate header file.
% The file names are determined by the module name,
% with the specified Suffix appended at the end.
% (The suffix is used for debugging dumps. For normal
% output, the suffix should be the empty string.)
-:- pred mlds_to_c__output_mlds(mlds, string, io__state, io__state).
-:- mode mlds_to_c__output_mlds(in, in, di, uo) is det.
+:- pred mlds_to_c__output_mlds(mlds, maybe(rl_file),
+ string, io__state, io__state).
+:- mode mlds_to_c__output_mlds(in, in, in, di, uo) is det.
% output_header_file(MLDS, Suffix):
% Output C declarations for the procedures (etc.) in the
@@ -43,12 +44,13 @@
:- pred mlds_to_c__output_header_file(mlds, string, io__state, io__state).
:- mode mlds_to_c__output_header_file(in, in, di, uo) is det.
- % output_c_file(MLDS, Suffix):
+ % output_c_file(MLDS, MaybeRLFile, Suffix):
% Output C code for the specified MLDS module to the
% appropriate C file.
% See output_mlds for the meaning of Suffix.
-:- pred mlds_to_c__output_c_file(mlds, string, io__state, io__state).
-:- mode mlds_to_c__output_c_file(in, in, di, uo) is det.
+:- pred mlds_to_c__output_c_file(mlds, maybe(rl_file),
+ string, io__state, io__state).
+:- mode mlds_to_c__output_c_file(in, in, in, di, uo) is det.
% output an MLDS context in C #line format.
% this is useful for other foreign language interfaces such as
@@ -92,7 +94,7 @@
%-----------------------------------------------------------------------------%
-mlds_to_c__output_mlds(MLDS, Suffix) -->
+mlds_to_c__output_mlds(MLDS, MaybeRLFile, Suffix) -->
% We output the source file before outputting the header,
% since the Mmake dependencies say the header file depends
% on the source file, and so if we wrote them out in the
@@ -102,14 +104,15 @@
% XXX at some point we should also handle output of any non-C
% foreign code (Ada, Fortran, etc.) to appropriate files.
%
- output_c_file(MLDS, Suffix),
+ output_c_file(MLDS, MaybeRLFile, Suffix),
output_header_file(MLDS, Suffix).
-mlds_to_c__output_c_file(MLDS, Suffix) -->
+mlds_to_c__output_c_file(MLDS, MaybeRLFile, Suffix) -->
{ ModuleName = mlds__get_module_name(MLDS) },
module_name_to_file_name(ModuleName, ".c" ++ Suffix, yes, SourceFile),
{ Indent = 0 },
- output_to_file(SourceFile, mlds_output_src_file(Indent, MLDS)).
+ output_to_file(SourceFile,
+ mlds_output_src_file(Indent, MLDS, MaybeRLFile)).
%
% Generate the header file
@@ -224,10 +227,11 @@
% but there's no obvious alternative term to use which
% also has a clear and concise abbreviation, so never mind...)
%
-:- pred mlds_output_src_file(indent, mlds, io__state, io__state).
-:- mode mlds_output_src_file(in, in, di, uo) is det.
+:- pred mlds_output_src_file(indent, mlds, maybe(rl_file),
+ io__state, io__state).
+:- mode mlds_output_src_file(in, in, in, di, uo) is det.
-mlds_output_src_file(Indent, MLDS) -->
+mlds_output_src_file(Indent, MLDS, MaybeRLFile) -->
{ MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns) },
% Get the foreign code for C
{ ForeignCode = mlds_get_c_foreign_code(AllForeignCode) },
@@ -270,6 +274,7 @@
mlds_output_defns(Indent, MLDS_ModuleName, NonTypeDefns), io__nl,
mlds_output_init_fn_defns(MLDS_ModuleName, FuncDefns,
TypeCtorInfoDefns), io__nl,
+ c_util__output_rl_file(ModuleName, MaybeRLFile), io__nl,
mlds_output_grade_var, io__nl,
mlds_output_src_end(Indent, ModuleName).
@@ -2345,7 +2350,7 @@
) },
list__foldl2(OutputLabel, Labels, 0, _FinalCount),
mlds_indent(Context, Indent + 1),
- io__write_string("default: /*NOTREACHED*/ assert(0);\n"),
+ io__write_string("default: /*NOTREACHED*/ MR_assert(0);\n"),
mlds_indent(Context, Indent),
io__write_string("}\n").
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.80
diff -u -u -r1.80 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 26 Feb 2003 06:36:24 -0000 1.80
+++ compiler/mlds_to_gcc.m 3 Mar 2003 16:06:41 -0000
@@ -92,7 +92,9 @@
:- interface.
:- import_module ml_backend.
-:- import_module ml_backend__mlds, ml_backend__maybe_mlds_to_gcc, bool.
+:- import_module ml_backend__mlds, ml_backend__maybe_mlds_to_gcc.
+:- import_module aditi_backend, aditi_backend__rl_file.
+:- import_module bool.
:- use_module io.
% run_gcc_backend(ModuleName, CallBack, CallBackOutput):
@@ -134,8 +136,9 @@
% which foreign language compilers it needs to invoke,
% and which object files to link into the executable.
-:- pred mlds_to_gcc__compile_to_asm(mlds__mlds, bool, io__state, io__state).
-:- mode mlds_to_gcc__compile_to_asm(in, out, di, uo) is det.
+:- pred mlds_to_gcc__compile_to_asm(mlds__mlds, maybe(rl_file), bool,
+ io__state, io__state).
+:- mode mlds_to_gcc__compile_to_asm(in, in, out, di, uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -224,7 +227,7 @@
maybe_write_string(Verbose, "% GCC back-end done.\n")
).
-mlds_to_gcc__compile_to_asm(MLDS, ContainsCCode) -->
+mlds_to_gcc__compile_to_asm(MLDS, MaybeRLFile, ContainsCCode) -->
{ MLDS = mlds(ModuleName, AllForeignCode, Imports, Defns0) },
%
@@ -262,7 +265,8 @@
% file if there are foreign_decls that were defined in the
% module that we're compiling.
{ ForeignCode = mlds__foreign_code(_Decls, _Imports, [], []) },
- { ForeignDefns = [] }
+ { ForeignDefns = [] },
+ { MaybeRLFile = no }
->
{ ContainsCCode = no },
{ NeedInitFn = yes }
@@ -278,7 +282,7 @@
% to create the .mih file, and if necessary the .c file.
{ ForeignMLDS = mlds(ModuleName, AllForeignCode, Imports,
list__map(make_public, ForeignDefns)) },
- mlds_to_c__output_c_file(ForeignMLDS, "")
+ mlds_to_c__output_c_file(ForeignMLDS, MaybeRLFile, "")
),
%
% Generate the .mih C header file for this module.
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.148
diff -u -u -r1.148 mode_util.m
--- compiler/mode_util.m 27 Jan 2003 09:20:48 -0000 1.148
+++ compiler/mode_util.m 28 Feb 2003 15:50:56 -0000
@@ -212,9 +212,16 @@
% Construct a mode corresponding to the standard `in',
% `out', `uo' or `unused' mode.
:- pred in_mode((mode)::out) is det.
+:- func in_mode = (mode).
:- pred out_mode((mode)::out) is det.
+:- func out_mode = (mode).
:- pred uo_mode((mode)::out) is det.
+:- func uo_mode = (mode).
:- pred unused_mode((mode)::out) is det.
+:- func unused_mode = (mode).
+
+:- func ground_inst = (inst).
+:- func free_inst = (inst).
% Construct the modes used for `aditi__state' arguments.
% XXX These should be unique, but are not yet because that
@@ -1871,23 +1878,29 @@
%-----------------------------------------------------------------------------%
-in_mode(Mode) :- make_std_mode("in", [], Mode).
-
-out_mode(Mode) :- make_std_mode("out", [], Mode).
-
-uo_mode(Mode) :- make_std_mode("uo", [], Mode).
-
-unused_mode(Mode) :- make_std_mode("unused", [], Mode).
+in_mode(in_mode).
+out_mode(out_mode).
+uo_mode(uo_mode).
+unused_mode(unused_mode).
+
+in_mode = make_std_mode("in", []).
+out_mode = make_std_mode("out", []).
+uo_mode = make_std_mode("uo", []).
+unused_mode = make_std_mode("unused", []).
aditi_mui_mode = Mode :- in_mode(Mode).
-
aditi_di_mode = Mode :- in_mode(Mode).
-
aditi_uo_mode = Mode :- out_mode(Mode).
-:- pred make_std_mode(string::in, list(inst)::in, (mode)::out) is det.
+ground_inst = ground(shared, none).
+free_inst = free.
+
+:- pred make_std_mode(string, list(inst), mode).
+:- mode make_std_mode(in, in, out) is det.
+make_std_mode(Name, Args, make_std_mode(Name, Args)).
-make_std_mode(Name, Args, Mode) :-
+:- func make_std_mode(string, list(inst)) = (mode).
+make_std_mode(Name, Args) = Mode :-
mercury_public_builtin_module(MercuryBuiltin),
QualifiedName = qualified(MercuryBuiltin, Name),
Mode = user_defined_mode(QualifiedName, Args).
Index: compiler/modecheck_call.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_call.m,v
retrieving revision 1.41
diff -u -u -r1.41 modecheck_call.m
--- compiler/modecheck_call.m 27 Jan 2003 09:20:49 -0000 1.41
+++ compiler/modecheck_call.m 28 Feb 2003 15:50:57 -0000
@@ -44,6 +44,11 @@
:- mode modecheck_aditi_builtin(in, in, in, in, out, out, out,
mode_info_di, mode_info_uo) is det.
+:- pred modecheck_builtin_cast(list(prog_var), list(mode), determinism,
+ list(prog_var), extra_goals, mode_info, mode_info).
+:- mode modecheck_builtin_cast(in, in, out, out, out,
+ mode_info_di, mode_info_uo) is det.
+
%
% Given two modes of a predicate, figure out whether
% they are indistinguishable; that is, whether any valid call to
@@ -135,32 +140,26 @@
ExtraGoals = no_extra_goals
).
-modecheck_aditi_builtin(AditiBuiltin, CallId,
- Args0, Modes, Det, Args, ExtraGoals) -->
+modecheck_aditi_builtin(AditiBuiltin, _, Args0, Modes, Det,
+ Args, ExtraGoals) -->
{ aditi_builtin_determinism(AditiBuiltin, Det) },
- % `aditi_insert' and `aditi_delete' goals have type_info
- % arguments for each of the arguments of the tuple to
- % insert added to the start of the argument list by polymorphism.m.
- ( { AditiBuiltin = aditi_tuple_insert_delete(_, _) } ->
- { CallId = _ - _/Arity },
- { ArgOffset = -Arity }
- ;
- { ArgOffset = 0 }
- ),
-
% The argument modes are set by post_typecheck.m, so all
% that needs to be done here is to check that they match.
+ { ArgOffset = 0 },
modecheck_arg_list(ArgOffset, Modes, ExtraGoals, Args0, Args).
:- pred aditi_builtin_determinism(aditi_builtin, determinism).
:- mode aditi_builtin_determinism(in, out) is det.
-aditi_builtin_determinism(aditi_call(_, _, _, _), _) :-
- error(
- "modecheck_call__aditi_builtin_determinism: unexpected Aditi call").
aditi_builtin_determinism(aditi_tuple_insert_delete(_, _), det).
aditi_builtin_determinism(aditi_insert_delete_modify(_, _, _), det).
+
+modecheck_builtin_cast(Args0, Modes, Det, Args, ExtraGoals) -->
+ { Det = det },
+ % These should always be mode correct.
+ { ArgOffset = 0 },
+ modecheck_arg_list(ArgOffset, Modes, ExtraGoals, Args0, Args).
:- pred modecheck_arg_list(int, list(mode), extra_goals,
list(prog_var), list(prog_var), mode_info, mode_info).
Index: compiler/modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modes.m,v
retrieving revision 1.265
diff -u -u -r1.265 modes.m
--- compiler/modes.m 28 Feb 2003 06:40:42 -0000 1.265
+++ compiler/modes.m 2 Mar 2003 09:54:46 -0000
@@ -1172,6 +1172,12 @@
{ GenericCall = class_method(_, _, _, _) },
{ error("modecheck_goal_expr: class_method_call") }
;
+ { GenericCall = unsafe_cast },
+ modecheck_builtin_cast(Args0, Modes0, Det, Args, ExtraGoals),
+ { Modes = Modes0 },
+ { AllArgs0 = Args0 },
+ { AllArgs = Args }
+ ;
{ GenericCall = aditi_builtin(AditiBuiltin, UpdatedCallId) },
modecheck_aditi_builtin(AditiBuiltin, UpdatedCallId,
Args0, Modes0, Det, Args, ExtraGoals),
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.267
diff -u -u -r1.267 modules.m
--- compiler/modules.m 19 Feb 2003 05:54:37 -0000 1.267
+++ compiler/modules.m 3 Mar 2003 15:58:53 -0000
@@ -743,6 +743,7 @@
:- import_module parse_tree__prog_io_util, libs__options, libs__handle_options.
:- import_module parse_tree__source_file_map.
:- import_module parse_tree__module_qual, backend_libs__foreign.
+:- import_module backend_libs__c_util.
:- import_module recompilation__version.
:- import_module make. % XXX undesirable dependency
@@ -1988,6 +1989,7 @@
mercury_private_builtin_module(MercuryPrivateBuiltin),
mercury_table_builtin_module(MercuryTableBuiltin),
mercury_profiling_builtin_module(MercuryProfilingBuiltin),
+ aditi_private_builtin_module(AditiPrivateBuiltin),
ImportDeps = [MercuryPublicBuiltin | ImportDeps0],
UseDeps1 = [MercuryPrivateBuiltin | UseDeps0],
(
@@ -2006,12 +2008,16 @@
UseDeps2 = UseDeps1
),
( globals__lookup_bool_option(Globals, profile_deep, yes) ->
- UseDeps = [MercuryProfilingBuiltin|UseDeps2]
+ UseDeps3 = [MercuryProfilingBuiltin | UseDeps2]
;
- UseDeps = UseDeps2
+ UseDeps3 = UseDeps2
+ ),
+ ( globals__lookup_bool_option(Globals, aditi, yes) ->
+ UseDeps = [AditiPrivateBuiltin | UseDeps3]
+ ;
+ UseDeps = UseDeps3
).
-
:- pred contains_tabling_pragma(item_list::in) is semidet.
contains_tabling_pragma([Item|Items]) :-
@@ -4728,7 +4734,7 @@
append_to_init_list(DepStream, InitFileName, Module) -->
{ llds_out__make_init_name(Module, InitFuncName0) },
{ string__append(InitFuncName0, "init", InitFuncName) },
- { llds_out__make_rl_data_name(Module, RLName) },
+ { c_util__make_rl_data_name(Module, RLName) },
io__write_strings(DepStream, [
"\techo ""INIT ", InitFuncName, """ >> ", InitFileName, "\n"
]),
@@ -4859,7 +4865,10 @@
Info = module_foreign_info(LangSet0, LangMap,
ForeignImports, ContainsPragmaExport),
ForeignProcLangs = map__values(LangMap),
- LangSet = set__insert_list(LangSet0, ForeignProcLangs).
+ LangSet1 = set__insert_list(LangSet0, ForeignProcLangs),
+ globals__lookup_bool_option(Globals, aditi, Aditi),
+ % We generate a C constant containing the Aditi-RL code.
+ LangSet = ( Aditi = yes -> set__insert(LangSet1, c) ; LangSet1 ).
:- pred get_item_foreign_code(globals::in, item_and_context::in,
module_foreign_info::in, module_foreign_info::out) is det.
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_debug.m,v
retrieving revision 1.124
diff -u -u -r1.124 opt_debug.m
--- compiler/opt_debug.m 15 Nov 2002 04:50:28 -0000 1.124
+++ compiler/opt_debug.m 20 Dec 2002 05:05:30 -0000
@@ -556,14 +556,6 @@
opt_debug__dump_code_addr(do_trace_redo_fail_deep, "do_trace_redo_fail_deep").
opt_debug__dump_code_addr(do_call_closure, "do_nondet_closure").
opt_debug__dump_code_addr(do_call_class_method, "do_nondet_class_method").
-opt_debug__dump_code_addr(do_det_aditi_call, "do_det_aditi_call").
-opt_debug__dump_code_addr(do_semidet_aditi_call, "do_semidet_aditi_call").
-opt_debug__dump_code_addr(do_nondet_aditi_call, "do_nondet_aditi_call").
-opt_debug__dump_code_addr(do_aditi_insert, "do_aditi_insert").
-opt_debug__dump_code_addr(do_aditi_delete, "do_aditi_delete").
-opt_debug__dump_code_addr(do_aditi_bulk_insert, "do_aditi_bulk_insert").
-opt_debug__dump_code_addr(do_aditi_bulk_delete, "do_aditi_bulk_delete").
-opt_debug__dump_code_addr(do_aditi_bulk_modify, "do_aditi_bulk_modify").
opt_debug__dump_code_addr(do_not_reached, "do_not_reached").
opt_debug__dump_code_addrs([], "").
Index: compiler/opt_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.115
diff -u -u -r1.115 opt_util.m
--- compiler/opt_util.m 7 May 2002 11:03:09 -0000 1.115
+++ compiler/opt_util.m 20 Dec 2002 05:05:30 -0000
@@ -1388,14 +1388,6 @@
opt_util__livevals_addr(do_trace_redo_fail_deep, no).
opt_util__livevals_addr(do_call_closure, yes).
opt_util__livevals_addr(do_call_class_method, yes).
-opt_util__livevals_addr(do_det_aditi_call, yes).
-opt_util__livevals_addr(do_semidet_aditi_call, yes).
-opt_util__livevals_addr(do_nondet_aditi_call, yes).
-opt_util__livevals_addr(do_aditi_insert, yes).
-opt_util__livevals_addr(do_aditi_delete, yes).
-opt_util__livevals_addr(do_aditi_bulk_insert, yes).
-opt_util__livevals_addr(do_aditi_bulk_delete, yes).
-opt_util__livevals_addr(do_aditi_bulk_modify, yes).
opt_util__livevals_addr(do_not_reached, no).
opt_util__count_temps_instr_list([], R, R, F, F).
@@ -2065,19 +2057,6 @@
opt_util__replace_labels_code_addr(do_call_closure, _, do_call_closure).
opt_util__replace_labels_code_addr(do_call_class_method, _,
do_call_class_method).
-opt_util__replace_labels_code_addr(do_det_aditi_call, _, do_det_aditi_call).
-opt_util__replace_labels_code_addr(do_semidet_aditi_call, _,
- do_semidet_aditi_call).
-opt_util__replace_labels_code_addr(do_nondet_aditi_call, _,
- do_nondet_aditi_call).
-opt_util__replace_labels_code_addr(do_aditi_insert, _, do_aditi_insert).
-opt_util__replace_labels_code_addr(do_aditi_delete, _, do_aditi_delete).
-opt_util__replace_labels_code_addr(do_aditi_bulk_insert, _,
- do_aditi_bulk_insert).
-opt_util__replace_labels_code_addr(do_aditi_bulk_delete, _,
- do_aditi_bulk_delete).
-opt_util__replace_labels_code_addr(do_aditi_bulk_modify, _,
- do_aditi_bulk_modify).
opt_util__replace_labels_code_addr(do_not_reached, _, do_not_reached).
:- pred opt_util__replace_labels_label_list(list(label)::in,
Index: compiler/pd_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pd_util.m,v
retrieving revision 1.22
diff -u -u -r1.22 pd_util.m
--- compiler/pd_util.m 6 Feb 2003 00:36:38 -0000 1.22
+++ compiler/pd_util.m 28 Feb 2003 15:50:58 -0000
@@ -1128,8 +1128,6 @@
:- pred match_aditi_builtin(aditi_builtin::in, aditi_builtin::in) is semidet.
% The other fields are all implied by the pred_proc_id.
-match_aditi_builtin(aditi_call(PredProcId, _, _, _),
- aditi_call(PredProcId, _, _, _)).
match_aditi_builtin(aditi_tuple_insert_delete(InsertDelete, PredId),
aditi_tuple_insert_delete(InsertDelete, PredId)).
% The syntax used does not change the result of the call.
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.233
diff -u -u -r1.233 polymorphism.m
--- compiler/polymorphism.m 28 Feb 2003 00:21:38 -0000 1.233
+++ compiler/polymorphism.m 28 Feb 2003 15:50:59 -0000
@@ -998,47 +998,8 @@
% We don't need to add type-infos for higher-order calls,
% since the type-infos are added when the closures are
% constructed, not when they are called.
-polymorphism__process_goal_expr(GoalExpr0, GoalInfo0, Goal) -->
- { GoalExpr0 = generic_call(GenericCall, Args0, Modes0, Det) },
-
- %
- % For `aditi_insert' and `aditi_delete' calls, we need to add
- % type-infos for the tuple to insert.
- %
- (
- { GenericCall = aditi_builtin(
- aditi_tuple_insert_delete(_, _), _) }
- ->
- % Aditi base relations must be monomorphic.
- { term__context_init(Context) },
-
- =(PolyInfo),
- { poly_info_get_var_types(PolyInfo, VarTypes) },
-
- { get_state_args_det(Args0, TupleArgs, _, _) },
- { map__apply_to_list(TupleArgs, VarTypes, TupleTypes) },
-
- polymorphism__make_type_info_vars(TupleTypes,
- Context, TypeInfoVars, TypeInfoGoals),
-
- { list__append(TypeInfoVars, Args0, Args) },
-
- { in_mode(InMode) },
- { list__length(TypeInfoVars, NumTypeInfos) },
- { list__duplicate(NumTypeInfos, InMode, TypeInfoModes) },
- { list__append(TypeInfoModes, Modes0, Modes) },
-
- { goal_info_get_nonlocals(GoalInfo0, NonLocals0) },
- { set__insert_list(NonLocals0, TypeInfoVars, NonLocals) },
- { goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo) },
-
- { Call = generic_call(GenericCall, Args, Modes, Det)
- - GoalInfo },
- { list__append(TypeInfoGoals, [Call], Goals) },
- { conj_list_to_goal(Goals, GoalInfo0, Goal) }
- ;
- { Goal = GoalExpr0 - GoalInfo0 }
- ).
+polymorphism__process_goal_expr(GoalExpr, GoalInfo, GoalExpr - GoalInfo) -->
+ { GoalExpr = generic_call(_, _, _, _) }.
polymorphism__process_goal_expr(Goal0, GoalInfo, Goal) -->
{ Goal0 = call(PredId, ProcId, ArgVars0, Builtin,
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.46
diff -u -u -r1.46 post_typecheck.m
--- compiler/post_typecheck.m 28 Feb 2003 06:40:42 -0000 1.46
+++ compiler/post_typecheck.m 28 Feb 2003 15:50:59 -0000
@@ -474,11 +474,6 @@
%-----------------------------------------------------------------------------%
-post_typecheck__finish_aditi_builtin(_, _, _, _, aditi_call(_, _, _, _),
- _, _, _, _, _) :-
- % These are only added by magic.m.
- error("post_typecheck__finish_aditi_builtin: aditi_call").
-
post_typecheck__finish_aditi_builtin(ModuleInfo, CallerPredInfo, Args, Context,
aditi_tuple_insert_delete(InsertDelete, PredId0), Builtin,
PredOrFunc - SymName0/Arity, InsertCallId,
Index: compiler/prog_rep.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_rep.m,v
retrieving revision 1.15
diff -u -u -r1.15 prog_rep.m
--- compiler/prog_rep.m 27 Jan 2003 09:20:50 -0000 1.15
+++ compiler/prog_rep.m 2 Mar 2003 10:41:06 -0000
@@ -29,7 +29,7 @@
:- implementation.
-:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_out, parse_tree__prog_util.
:- import_module hlds__hlds_data.
:- import_module string, set, std_util, require, term.
@@ -199,6 +199,12 @@
GenericCall = class_method(Var, MethodNum, _, _),
term__var_to_int(Var, VarRep),
AtomicGoalRep = method_call_rep(VarRep, MethodNum, ArgsRep)
+ ;
+ GenericCall = unsafe_cast,
+ mercury_private_builtin_module(ModuleSymName),
+ prog_out__sym_name_to_string(ModuleSymName, ModuleName),
+ AtomicGoalRep = plain_call_rep(ModuleName,
+ "unsafe_type_cast", ArgsRep)
;
GenericCall = aditi_builtin(_, _),
error("Sorry, not yet implemented\n\
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.60
diff -u -u -r1.60 prog_util.m
--- compiler/prog_util.m 22 Feb 2003 13:18:28 -0000 1.60
+++ compiler/prog_util.m 1 Mar 2003 06:38:45 -0000
@@ -50,7 +50,23 @@
:- pred mercury_profiling_builtin_module(sym_name::out) is det.
:- func mercury_profiling_builtin_module = sym_name.
- % Succeeds iff the specified module is one of the three
+ % Returns the name of the module containing the public builtins
+ % used by the Aditi transaction interface, currently "aditi".
+ % This module is not automatically imported (XXX should it be?).
+
+:- pred aditi_public_builtin_module(sym_name::out) is det.
+:- func aditi_public_builtin_module = sym_name.
+
+ % Returns the name of the module containing the private builtins
+ % used by the Aditi transaction interface, currently
+ % "aditi_private_builtin".
+ % This module is automatically imported iff the Aditi interface
+ % is enabled.
+
+:- pred aditi_private_builtin_module(sym_name::out) is det.
+:- func aditi_private_builtin_module = sym_name.
+
+ % Succeeds iff the specified module is one of the
% builtin modules listed above which are automatically imported.
:- pred any_mercury_builtin_module(sym_name).
@@ -218,12 +234,17 @@
mercury_table_builtin_module(mercury_table_builtin_module).
mercury_profiling_builtin_module = unqualified("profiling_builtin").
mercury_profiling_builtin_module(mercury_profiling_builtin_module).
+aditi_public_builtin_module = unqualified("aditi").
+aditi_public_builtin_module(aditi_public_builtin_module).
+aditi_private_builtin_module = unqualified("aditi_private_builtin").
+aditi_private_builtin_module(aditi_private_builtin_module).
any_mercury_builtin_module(Module) :-
( mercury_public_builtin_module(Module)
; mercury_private_builtin_module(Module)
; mercury_table_builtin_module(Module)
; mercury_profiling_builtin_module(Module)
+ ; aditi_private_builtin_module(Module)
).
unqualify_name(unqualified(PredName), PredName).
Index: compiler/purity.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/purity.m,v
retrieving revision 1.54
diff -u -u -r1.54 purity.m
--- compiler/purity.m 28 Feb 2003 06:40:42 -0000 1.54
+++ compiler/purity.m 2 Mar 2003 09:56:25 -0000
@@ -182,7 +182,7 @@
:- import_module hlds__hlds_data, hlds__hlds_goal, parse_tree__prog_io_util.
:- import_module check_hlds__type_util, check_hlds__mode_util.
-:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_data, parse_tree__prog_util.
:- import_module check_hlds__unify_proc.
:- import_module libs__globals, libs__options, parse_tree__mercury_to_mercury.
:- import_module hlds__hlds_out.
@@ -513,20 +513,35 @@
compute_expr_purity(par_conj(Goals0), par_conj(Goals), _,
Purity) -->
compute_goals_purity(Goals0, Goals, pure, Purity).
-compute_expr_purity(call(PredId0,ProcId,Vars,BIState,UContext,Name0),
- call(PredId,ProcId,Vars,BIState,UContext,Name),
- GoalInfo, ActualPurity) -->
+compute_expr_purity(
+ Goal0 @ call(PredId0, ProcId, Vars, BIState, UContext, Name0),
+ Goal, GoalInfo, ActualPurity) -->
RunPostTypecheck =^ run_post_typecheck,
PredInfo =^ pred_info,
ModuleInfo =^ module_info,
{
RunPostTypecheck = yes,
post_typecheck__resolve_pred_overloading(PredId0,
- Vars, PredInfo, ModuleInfo, Name0, Name, PredId)
+ Vars, PredInfo, ModuleInfo, Name0, Name, PredId),
+ (
+ % Convert any calls to private_builtin.unsafe_type_cast
+ % into unsafe_cast goals.
+ Name = qualified(
+ mercury_private_builtin_module,
+ "unsafe_type_cast"),
+ Vars = [InputArg, OutputArg]
+ ->
+ Goal = generic_call(unsafe_cast,
+ [InputArg, OutputArg],
+ [in_mode, out_mode], det)
+ ;
+ Goal = call(PredId, ProcId, Vars,
+ BIState, UContext, Name)
+ )
;
RunPostTypecheck = no,
PredId = PredId0,
- Name = Name0
+ Goal = Goal0
},
{ infer_goal_info_purity(GoalInfo, DeclaredPurity) },
{ goal_info_get_context(GoalInfo, CallContext) },
@@ -542,6 +557,10 @@
;
{ GenericCall0 = class_method(_, _, _, _) },
{ Purity = pure }, % XXX this is wrong!
+ { GoalExpr = generic_call(GenericCall0, Args, Modes0, Det) }
+ ;
+ { GenericCall0 = unsafe_cast },
+ { Purity = pure },
{ GoalExpr = generic_call(GenericCall0, Args, Modes0, Det) }
;
{ GenericCall0 = aditi_builtin(Builtin0, CallId0) },
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.5
diff -u -u -r1.5 stack_opt.m
--- compiler/stack_opt.m 14 Jan 2003 16:42:29 -0000 1.5
+++ compiler/stack_opt.m 1 Mar 2003 13:34:41 -0000
@@ -430,22 +430,27 @@
optimize_live_sets_in_goal(Goal - GoalInfo) -->
OptParams =^ opt_params,
- { Goal = generic_call(GenericCall, ArgVars0, ArgModes0, Detism) },
+ { Goal = generic_call(GenericCall, ArgVars, ArgModes, Detism) },
{ goal_info_get_maybe_need_across_call(GoalInfo, MaybeNeedAcrossCall) },
{ VarTypes = OptParams ^ var_types },
- { list__map(map__lookup(VarTypes), ArgVars0, ArgTypes0) },
- { call_gen__maybe_remove_aditi_state_args(GenericCall,
- ArgVars0, ArgTypes0, ArgModes0,
- ArgVars, ArgTypes, ArgModes) },
+ { list__map(map__lookup(VarTypes), ArgVars, ArgTypes) },
{ ModuleInfo = OptParams ^ module_info },
{ arg_info__compute_in_and_out_vars(ModuleInfo, ArgVars,
ArgModes, ArgTypes, InputArgs, _OutputArgs) },
{ determinism_to_code_model(Detism, CodeModel) },
- { call_gen__generic_call_info(CodeModel, GenericCall, _,
- GenericVarsArgInfos, _) },
- { assoc_list__keys(GenericVarsArgInfos, GenericVars) },
- { list__append(GenericVars, InputArgs, Inputs) },
- optimize_live_sets_at_call(Inputs, MaybeNeedAcrossCall, GoalInfo).
+
+ % unsafe_casts are generated inline.
+ ( { GenericCall = unsafe_cast } ->
+ require_in_regs(InputArgs),
+ require_access(InputArgs)
+ ;
+ { call_gen__generic_call_info(CodeModel, GenericCall, _,
+ GenericVarsArgInfos, _) },
+ { assoc_list__keys(GenericVarsArgInfos, GenericVars) },
+ { list__append(GenericVars, InputArgs, Inputs) },
+ optimize_live_sets_at_call(Inputs,
+ MaybeNeedAcrossCall, GoalInfo)
+ ).
optimize_live_sets_in_goal(Goal - GoalInfo) -->
{ Goal = call(PredId, ProcId, ArgVars, Builtin, _, _) },
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.331
diff -u -u -r1.331 typecheck.m
--- compiler/typecheck.m 28 Feb 2003 06:40:43 -0000 1.331
+++ compiler/typecheck.m 28 Feb 2003 15:51:02 -0000
@@ -1383,6 +1383,11 @@
{ GenericCall0 = class_method(_, _, _, _) },
{ error("typecheck_goal_2: unexpected class method call") }
;
+ { GenericCall0 = unsafe_cast },
+ % A cast imposes no restrictions on its argument types,
+ % so nothing needs to be done here.
+ { GenericCall = GenericCall0 }
+ ;
{ GenericCall0 = aditi_builtin(AditiBuiltin0, PredCallId) },
checkpoint("aditi builtin"),
typecheck_aditi_builtin(PredCallId, Args,
@@ -1545,9 +1550,6 @@
:- mode typecheck_aditi_builtin_2(in, in, in, out,
typecheck_info_di, typecheck_info_uo) is det.
-typecheck_aditi_builtin_2(_, _, aditi_call(_, _, _, _), _) -->
- % There are only added by magic.m.
- { error("typecheck_aditi_builtin: unexpected aditi_call") }.
typecheck_aditi_builtin_2(CallId, Args,
aditi_tuple_insert_delete(InsertDelete, _),
aditi_tuple_insert_delete(InsertDelete, PredId)) -->
@@ -1639,8 +1641,6 @@
% `aditi__state' DCG argument.
:- func aditi_builtin_first_state_arg(aditi_builtin, simple_call_id) = int.
-aditi_builtin_first_state_arg(aditi_call(_, _, _, _), _) = _ :-
- error("aditi_builtin_first_state_arg: unexpected_aditi_call").
aditi_builtin_first_state_arg(aditi_tuple_insert_delete(_, _),
_ - _/Arity) = Arity + 1.
% XXX removing the space between the 2 and the `.' will possibly
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.116
diff -u -u -r1.116 unify_proc.m
--- compiler/unify_proc.m 28 Feb 2003 00:21:38 -0000 1.116
+++ compiler/unify_proc.m 28 Feb 2003 15:51:02 -0000
@@ -814,10 +814,8 @@
"Cast_HeadVar", 1, CastVar1),
unify_proc__make_fresh_named_var_from_type(EqvType,
"Cast_HeadVar", 2, CastVar2),
- unify_proc__build_call("unsafe_type_cast", [H1, CastVar1],
- Context, Cast1Goal),
- unify_proc__build_call("unsafe_type_cast", [H2, CastVar2],
- Context, Cast2Goal),
+ unify_proc__build_cast(H1, CastVar1, Context, Cast1Goal),
+ unify_proc__build_cast(H2, CastVar2, Context, Cast2Goal),
{ create_atomic_unification(CastVar1, var(CastVar2), Context,
explicit, [], UnifyGoal) },
@@ -906,10 +904,10 @@
"Cast_HeadVar", 1, CastVar1),
unify_proc__make_fresh_named_var_from_type(IntType,
"Cast_HeadVar", 2, CastVar2),
- unify_proc__build_call("unsafe_type_cast",
- [H1, CastVar1], Context, Cast1Goal),
- unify_proc__build_call("unsafe_type_cast",
- [H2, CastVar2], Context, Cast2Goal),
+ unify_proc__build_cast(H1, CastVar1, Context,
+ Cast1Goal),
+ unify_proc__build_cast(H2, CastVar2, Context,
+ Cast2Goal),
unify_proc__build_call("builtin_compare_int",
[Res, CastVar1, CastVar2], Context,
CompareGoal),
@@ -988,10 +986,8 @@
"Cast_HeadVar", 1, CastVar1),
unify_proc__make_fresh_named_var_from_type(EqvType,
"Cast_HeadVar", 2, CastVar2),
- unify_proc__build_call("unsafe_type_cast", [H1, CastVar1],
- Context, Cast1Goal),
- unify_proc__build_call("unsafe_type_cast", [H2, CastVar2],
- Context, Cast2Goal),
+ unify_proc__build_cast(H1, CastVar1, Context, Cast1Goal),
+ unify_proc__build_cast(H2, CastVar2, Context, Cast2Goal),
unify_proc__build_call("compare", [Res, CastVar1, CastVar2],
Context, CompareGoal),
@@ -1535,6 +1531,15 @@
).
%-----------------------------------------------------------------------------%
+
+:- pred unify_proc__build_cast(prog_var, prog_var, prog_context, hlds_goal,
+ unify_proc_info, unify_proc_info).
+:- mode unify_proc__build_cast(in, in, in, out, in, out) is det.
+
+unify_proc__build_cast(InArg, OutArg, Context, Goal) -->
+ { goal_info_init(Context, GoalInfo) },
+ { Goal = generic_call(unsafe_cast, [InArg, OutArg],
+ [in_mode, out_mode], det) - GoalInfo }.
:- pred unify_proc__build_call(string, list(prog_var), prog_context, hlds_goal,
unify_proc_info, unify_proc_info).
Index: compiler/unique_modes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unique_modes.m,v
retrieving revision 1.75
diff -u -u -r1.75 unique_modes.m
--- compiler/unique_modes.m 27 Jan 2003 09:20:53 -0000 1.75
+++ compiler/unique_modes.m 28 Feb 2003 15:51:02 -0000
@@ -452,18 +452,13 @@
GenericCall = class_method(_, _, _, _),
ArgOffset = 0
;
- % `aditi_insert' and `aditi_delete' goals have type_info
- % arguments for each of the arguments of the tuple to insert
- % added to the start of the argument list by polymorphism.m.
- GenericCall = aditi_builtin(Builtin, UpdatedCallId),
- (
- Builtin = aditi_tuple_insert_delete(_, _),
- UpdatedCallId = _ - _/Arity
- ->
- ArgOffset = -Arity
- ;
- ArgOffset = 0
- )
+ % Casts are introduced by the compiler
+ % and should be mode correct.
+ GenericCall = unsafe_cast,
+ ArgOffset = 0
+ ;
+ GenericCall = aditi_builtin(_, _),
+ ArgOffset = 0
},
unique_modes__check_call_modes(Args, Modes, ArgOffset,
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.82
diff -u -u -r1.82 compiler_design.html
--- compiler/notes/compiler_design.html 22 Feb 2003 13:54:43 -0000 1.82
+++ compiler/notes/compiler_design.html 28 Feb 2003 15:51:03 -0000
@@ -665,6 +665,9 @@
The supplementary magic sets and context transformations are only defined
for predicates in DNF.
+<li> transformation of Aditi builtins into normal calls to predicates
+ in extras/aditi/aditi_private_builtin.m (aditi_builtin_ops.m).
+
<li> supplementary magic sets or supplementary context transformation of
Aditi procedures (magic.m, magic_util.m, context.m).
The magic sets or context transformations must be applied to convert the
Index: extras/aditi/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/aditi/Mmakefile,v
retrieving revision 1.7
diff -u -u -r1.7 Mmakefile
--- extras/aditi/Mmakefile 19 Dec 2001 15:08:27 -0000 1.7
+++ extras/aditi/Mmakefile 4 Mar 2003 13:26:24 -0000
@@ -16,24 +16,23 @@
include $(MAKEFILE_ADITI)
# The Aditi interface only works with conservative garbage collection.
-# It doesn't yet work with the new high level C code grade.
# This is equivalent to
# LIBGRADES-aditi = $(filter %.gc%,$(LIBGRADES))
# but gmake patterns can't include multiple wildcards.
LIBGRADES-aditi = \
- $(shell echo $(LIBGRADES) | tr ' ' '\n' | grep '.gc' | grep -v 'hl')
+ $(shell echo $(LIBGRADES) | tr ' ' '\n' | grep '.gc')
#----------------------------------------------------------------------------#
# The --Wno-strict-prototypes is to shut up warnings about prototypes
# without argument types in a header file generated by rpcgen.
-# To get more debugging messages, add "-DDEBUG_ON" to CFLAGS.
+# To get more debugging messages, add "-DMR_DEBUG_ON" to CFLAGS.
CFLAGS = $(ADITI_API_EXTRA_CFLAGS) -Wno-strict-prototypes
# The RPC headers on Linux don't like it when `-ansi' is passed to gcc.
MGNUCFLAGS = --no-ansi
-MLFLAGS = --aditi --use-thread-libs $(ADITI_API_EXTRA_LDFLAGS)
+MLFLAGS = $(ADITI_API_EXTRA_LDFLAGS) --aditi
MLLIBS = $(ADITI_API_EXTRA_LIBS)
MCFLAGS = --no-infer-all --aditi --aditi-user guest
@@ -54,11 +53,12 @@
realclean:
cd tests && $(MMAKE) realclean
-.PHONY: check
-check: tests
-
.PHONY: tests
tests:
+ cd tests && $(MMAKE)
+
+.PHONY: check
+check:
cd tests && $(MMAKE)
.PHONY: install
Index: extras/aditi/aditi_private_builtin.m - rewritten
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1998-2000,2003 University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------%
% File: aditi.m
% Main author: stayl
%
% This module provides an interface to the Aditi deductive database
% system developed at the University of Melbourne. See the
% "Aditi deductive database interface" section of the Mercury
% Language Reference Manual (listed under "Implementation defined pragmas"
% in the "Pragmas" chapter) for details on how to compile database queries.
%
% For information on how to build programs which use this interface,
% see the example Mmakefile in $ADITI_HOME/demos/transactions.
%
%
% Compilation grade notes (see the section "Compilation model options"
% in the Mercury User's Guide for more information):
%
% This module requires a compilation grade with conservative garbage
% collection. Any grade containing `.gc' in its name, such as
% `asm_fast.gc' or `asm_fast.gc.tr', will do.
%
% When trailing is not being used (the compilation grade does not
% contain `.tr'), resources will sometimes not be cleaned up until
% the end of a transaction.
% If there is a commit across a nondet database call, or an exception
% is thrown, or a database call is retried in the debugger, the output
% relation from the call and its cursor will not be cleaned up until the
% transaction ends.
% It is up to the programmer to decide whether imposing the overhead
% of trailing on the rest of the program is worthwhile.
%
% Compilation of this module in a high level C code grade (e.g. `hlc.gc')
% is not yet supported.
%
%
% The transaction interface used here is described in
% Kemp, Conway, Harris, Henderson, Ramamohanarao and Somogyi,
% "Database transactions in a purely declarative
% logic programming language",
% In Proceedings of the Fifth International Conference on Database
% Systems for Advanced Applications, pp. 283-292.
% Melbourne, Australia, 1-4 April, 1997.
%
% This paper is also available as
% Technical Report 96/45, Department of Computer Science,
% University of Melbourne, December 1996,
% <http://www.cs.mu.OZ.AU/publications/tr_db/mu_96_45_cover.ps.gz>
% and <http://www.cs.mu.OZ.AU/publications/tr_db/mu_96_45.ps.gz>.
%
%-----------------------------------------------------------------------------%
:- module aditi.
:- interface.
:- import_module io.
:- type aditi__state.
:- inst aditi_unique = ground.
:- mode aditi_di :: in(aditi_unique).
:- mode aditi_uo :: out(aditi_unique).
:- mode aditi_mui :: in(aditi_unique).
:- type aditi__result(T)
---> ok(T)
; error(aditi__error, string).
:- type aditi__result
---> ok
; error(aditi__error, string).
:- type aditi__error
---> error_creating_client
; invalid_passwd
; too_many_connections
; invalid_ticket
; general_failure
; already_logged_in
; not_logged_in
; not_connected
; not_implemented
; abort
; bad_value
; bad_rl_code
; error_opening_relation
; security_violation
; unique_key_violation
; relation_or_cursor_not_open
; timeout
; determinism_error % The number of solutions returned
% for a procedure did not match
% its determinism declaration.
; parse_error_in_tuple % Aditi returned a tuple
% which the Mercury interface
% code could not understand.
.
:- type aditi__exception
---> aditi__exception(aditi__error, string).
:- type aditi__connection.
% aditi__connect(Host, User, Passwd, Result).
%
% Only one connection is allowed per process.
:- pred aditi__connect(string, string, string,
aditi__result(aditi__connection), io__state, io__state).
:- mode aditi__connect(in, in, in, out, di, uo) is det.
:- pred aditi__disconnect(aditi__connection, aditi__result,
io__state, io__state).
:- mode aditi__disconnect(in, out, di, uo) is det.
:- type aditi__transaction(T) == pred(T, aditi__state, aditi__state).
:- inst aditi__transaction = (pred(out, aditi_di, aditi_uo) is det).
% aditi__transaction(Connection, Transaction, Result).
%
% Start a transaction with the Aditi database referred to by
% Connection, call Transaction, returning ok(Result) if the
% transaction is not aborted, or error(Error, Msg) if
% the transaction fails.
%
% If Transaction throws an exception, the transaction will
% be aborted and the exception will be rethrown to the caller.
%
% Predicates with `:- pragma aditi' or `:- pragma base_relation'
% markers can only be called from within a transaction -- there
% is no other way to get an `aditi__state' to pass to them.
:- pred aditi__transaction(aditi__connection, aditi__transaction(T),
aditi__result(T), io__state, io__state).
:- mode aditi__transaction(in, in(aditi__transaction), out, di, uo) is det.
% As above, except that it throws an exception if the
% transaction is aborted.
:- pred aditi__transaction_exception(aditi__connection, aditi__transaction(T),
T, io__state, io__state).
:- mode aditi__transaction_exception(in, in(aditi__transaction),
out, di, uo) is det.
% aditi__aggregate_compute_initial(Closure, UpdateAcc,
% ComputeInitial, Results)
%
% When called, the query Closure returns the relation to be
% aggregated over. This relation must have two attributes,
% the first being the attribute to group by. The closure
% ComputeInitial computes an initial accumulator for each
% group given the first tuple in the group. The closure
% UpdateAcc is called for each tuple in each group to
% update the accumulator. The outputs are the group-by element
% and final accumulator for each group.
%
% For example, to compute a sum over relation `p/3' where
% the first non-aditi__state attribute of `p' is the group-by
% attribute:
% aditi__aggregate_compute_initial(p(DB),
% (pred(_::in, Attr::in, Acc0::in, Acc::out) is det :-
% Acc = Acc0 + Attr),
% (pred(_::in, _::in, 0::out) is det :- true),
% GrpBy, Sum).
:- pred aditi__aggregate_compute_initial(pred(GrpBy, NonGrpBy),
pred(GrpBy, NonGrpBy, Acc, Acc),
pred(GrpBy, NonGrpBy, Acc), GrpBy, Acc).
:- mode aditi__aggregate_compute_initial(pred(out, out) is nondet,
pred(in, in, in, out) is det,
pred(in, in, out) is det, out, out) is nondet.
:- mode aditi__aggregate_compute_initial(pred(out, out) is multi,
pred(in, in, in, out) is det,
pred(in, in, out) is det, out, out) is multi.
/*
This should be translated into the equivalent
aggregate_compute_initial , but that hasn't been
done yet. The main problem is collecting the initial
value - it may not be constant.
Also, it would be nice to provide versions of aditi__aggregate
which work over one attribute relations, as in std_util__aggregate.
% aditi_aggregate_given_initial(Closure, UpdateAcc,
% InitialAcc, Results)
%
% Same as aditi__aggregate_compute_initial except the initial
% accumulator is supplied, rather than computed from the first
% element.
:- pred aditi__aggregate_given_initial(pred(GrpBy, NonGrpBy),
pred(GrpBy, NonGrpBy, Acc, Acc), Acc, GrpBy, Acc).
:- mode aditi__aggregate_given_initial(pred(out, out) is nondet,
pred(in, in, in, out) is det,
in, out, out) is nondet.
*/
%-----------------------------------------------------------------------------%
:- implementation.
:- type aditi__state ---> aditi__state(c_pointer).
:- type aditi__connection ---> aditi_connection(c_pointer).
:- import_module bool, char, exception, list, require, std_util, string.
:- import_module aditi_private_builtin.
% These are handled by the RL code generator.
:- external(aditi__aggregate_compute_initial/5).
%:- external(aditi__aggregate_given_initial/5).
%-----------------------------------------------------------------------------%
aditi__connect(Host, User, Passwd, Result) -->
aditi_private_builtin__connect(Host,
User, Passwd, Status, Connection),
{ Status = 0 ->
Result = ok(Connection)
;
aditi_private_builtin__error_code(Status, Error, String),
Result = error(Error, String)
}.
%-----------------------------------------------------------------------------%
aditi__disconnect(Connection, Result) -->
aditi_private_builtin__disconnect(Connection, Status),
{ Status = 0 ->
Result = ok
;
aditi_private_builtin__error_code(Status, Error, Msg),
Result = error(Error, Msg)
}.
%-----------------------------------------------------------------------------%
aditi__transaction(Connection, Transaction, TransResult, IO0, IO) :-
%
% aditi__transaction_2 is cc_multi because of the call to
% try_io, but if an Aditi exception occurs, it really
% doesn't matter which one we get.
%
RunTransaction =
(pred(ResultAndIO0::out) is cc_multi :-
unsafe_promise_unique(IO0, IO1),
aditi__transaction_2(Connection, Transaction,
Result, IO1, IO2),
ResultAndIO0 = Result - IO2
),
ResultAndIO = promise_only_solution(RunTransaction),
ResultAndIO = TransResult - IO3,
unsafe_promise_unique(IO3, IO).
:- pred aditi__transaction_2(aditi__connection, aditi__transaction(T),
aditi__result(T), io__state, io__state).
:- mode aditi__transaction_2(in, in(aditi__transaction),
out, di, uo) is cc_multi.
aditi__transaction_2(Connection, Transaction, TransResult) -->
aditi_private_builtin__start_transaction(Connection, StartResult),
(
{ StartResult = ok(DB0) },
try_io((pred(Result::out, di, uo) is det -->
{ Transaction(Result, DB0, DB) },
aditi_private_builtin__commit_transaction(DB)
), TransExceptionResult),
(
{ TransExceptionResult = succeeded(Results) },
{ TransResult = ok(Results) }
;
{ TransExceptionResult = exception(Exception) },
aditi_private_builtin__abort_transaction(DB0),
( { univ_to_type(Exception, AditiException) } ->
{ AditiException =
aditi__exception(ErrorCode, String) },
{ TransResult = error(ErrorCode, String) }
;
{ rethrow(TransExceptionResult) }
)
)
;
{ StartResult = error(StartErrorCode, StartMsg) },
{ TransResult = error(StartErrorCode, StartMsg) }
).
aditi__transaction_exception(Connection, Transaction, Result) -->
aditi__transaction(Connection, Transaction, TransResult),
{
TransResult = ok(Result)
;
TransResult = error(ErrorCode, String),
throw(aditi__exception(ErrorCode, String))
}.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: extras/aditi/aditi_private_builtin.m
===================================================================
RCS file: extras/aditi/aditi_private_builtin.m
diff -N extras/aditi/aditi_private_builtin.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ extras/aditi/aditi_private_builtin.m 4 Mar 2003 12:22:39 -0000
@@ -0,0 +1,1186 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2003 University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+% File: aditi_private_builtin.m
+% Author: stayl
+%
+% Internals of the Mercury->Aditi interface.
+%
+% This module is automatically imported when `--aditi' is passed to
+% the compiler.
+%
+% Calls to some of these predicates are generated by the compiler,
+% and some are called from aditi.m.
+%
+% None of these predicates should appear in user programs.
+%
+%-----------------------------------------------------------------------------%
+:- module aditi_private_builtin.
+
+:- interface.
+
+:- import_module io.
+:- import_module aditi.
+
+:- pred connect(string, string, string, int, aditi__connection,
+ io__state, io__state).
+:- mode connect(in, in, in, out, out, di, uo) is det.
+
+:- pred disconnect(aditi__connection, int, io__state, io__state).
+:- mode disconnect(in, out, di, uo) is det.
+
+:- pred start_transaction(aditi__connection, aditi__result(aditi__state),
+ io__state, io__state).
+:- mode start_transaction(in, out, di, uo) is det.
+
+:- pred commit_transaction(aditi__state, io__state, io__state).
+:- mode commit_transaction(in, di, uo) is det.
+
+:- pred abort_transaction(aditi__state, io__state, io__state).
+:- mode abort_transaction(in, di, uo) is det.
+
+:- type relation_ticket == c_pointer.
+
+ % do_call_returning_relation(ProcName, InputSchema, InputTuple,
+ % OutputRel).
+ %
+ % Call an Aditi procedure, returning a reference to the output
+ % relation. InputTuple is a tuple containing the
+ % input arguments. InputSchema is an Aditi schema string
+ % describing the tuple of input arguments.
+:- impure pred do_call_returning_relation(string, string,
+ T, relation_ticket).
+:- mode do_call_returning_relation(in, in, in, out) is det.
+
+ % Find the single solution for a deterministic database call.
+ % Abort the transaction if the call does not succeed at
+ % least once.
+ % InputTuple and OutputTuple must have type '{}/N' (the arity
+ % depends on the relation being called).
+:- impure pred do_det_call(string, string, InputTuple, OutputTuple).
+:- mode do_det_call(in, in, in, out) is det.
+
+:- impure pred do_semidet_call(string, string, InputTuple, OutputTuple).
+:- mode do_semidet_call(in, in, in, out) is semidet.
+
+:- impure pred do_nondet_call(string, string, InputTuple, OutputTuple).
+:- mode do_nondet_call(in, in, in, out) is nondet.
+
+:- impure pred do_multi_call(string, string, InputTuple, OutputTuple).
+:- mode do_multi_call(in, in, in, out) is multi.
+
+ % XXX I'm not sure whether it makes sense to have
+ % committed choice Aditi predicates.
+:- impure pred do_cc_nondet_call(string, string, InputTuple, OutputTuple).
+:- mode do_cc_nondet_call(in, in, in, out) is cc_nondet.
+
+:- impure pred do_cc_multi_call(string, string, InputTuple, OutputTuple).
+:- mode do_cc_multi_call(in, in, in, out) is cc_multi.
+
+:- impure pred do_erroneous_call(string, string, InputTuple, OutputTuple).
+:- mode do_erroneous_call(in, in, in, out) is erroneous.
+
+:- impure pred do_failure_call(string, string, InputTuple, OutputTuple).
+:- mode do_failure_call(in, in, in, out) is failure.
+
+ % do_insert_tuple(BaseRelationName, Tuple).
+ %
+ % TypeInfos is an array containing the type-infos for
+ % the tuple to insert. TupleArgs contains the attribute
+ % values of the tuple to insert.
+:- pred do_insert_tuple(string, InputTuple, aditi__state, aditi__state).
+:- mode do_insert_tuple(in, in, aditi_di, aditi_uo) is det.
+
+ % do_delete_tuple(BaseRelationName, DeleteProcName,
+ % DeleteProcInputSchema, Tuple).
+:- pred do_delete_tuple(string, string, string, Tuple,
+ aditi__state, aditi__state).
+:- mode do_delete_tuple(in, in, in, in, aditi_di, aditi_uo) is det.
+
+:- type update_closure == pred(relation_ticket).
+:- inst update_closure == (pred(out) is det).
+
+ % do_bulk_insert(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_insert(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_insert(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
+ % do_bulk_delete(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_delete(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_delete(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
+ % do_bulk_modify(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_modify(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_modify(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
+ % Try to classify an error code returned by Aditi.
+:- pred error_code(int, aditi__error, string).
+:- mode error_code(in, out, out) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+:- implementation.
+
+:- import_module bool, char, exception, int, list, require, std_util, string.
+
+:- type cursor == c_pointer.
+
+:- pragma c_header_code("
+
+#include ""mercury_wrapper.h""
+#include ""mercury_string.h""
+
+/* aditi_api_config.h must be included before aditi_clnt.h */
+#include ""aditi_api_config.h""
+#include ""aditi_clnt.h""
+
+ /*
+ ** MADITI_check can only be used within functions which return
+ ** an Aditi error code.
+ */
+#define MADITI_check(status) \\
+ do { int MADITI_line_xxx = __LINE__; \\
+ int MADITI_check_status_xxx; \\
+ MADITI_check_status_xxx = status; \\
+ MADITI_do_debug_status(MADITI_check_status_xxx, \\
+ MADITI_line_xxx); \\
+ if (MADITI_check_status_xxx != ADITI_OK) { \\
+ MADITI_status = MADITI_check_status_xxx; \\
+ return MADITI_check_status_xxx; \\
+ } \\
+ } while(0)
+
+#define MADITI_debug_status(status) \\
+ do { int MADITI_line_xxx_2 = __LINE__; \\
+ int MADITI_check_status_xxx_2; \\
+ MADITI_check_status_xxx_2 = status; \\
+ MADITI_do_debug_status(MADITI_check_status_xxx_2, \\
+ MADITI_line_xxx_2); \\
+ } while(0)
+
+#define MADITI_do_debug_status(status, line) \\
+ do { int MADITI_do_debug_status_xxx; \\
+ MADITI_do_debug_status_xxx = status; \\
+ if (MADITI_do_debug_status_xxx != ADITI_OK) { \\
+ MR_DEBUG(fprintf(stderr, ""\\naditi_private_builtin.m:%d: API call failed, returned %d\\n"", \\
+ line, MADITI_do_debug_status_xxx)); \\
+ } \\
+ } while(0)
+
+/*
+** Maximum time allowed for a query (in seconds)
+*/
+#define MADITI_QUERY_TIMEOUT 600
+
+typedef enum { MADITI_INSERT_TUPLE, MADITI_DELETE_TUPLE } MADITI_insert_delete;
+typedef enum { MADITI_INSERT, MADITI_DELETE, MADITI_MODIFY } MADITI_bulk_op;
+
+/*
+** Information used to clean up a call result if there is a commit
+** or an exception across a database call.
+*/
+typedef struct {
+ ticket *output_rel;
+ ticket *output_cursor;
+ bool cleaned_up;
+} MADITI_output_info;
+
+static ticket MADITI_ticket; /* Current connection ticket. */
+static int MADITI_status; /* Return code of the last
+ ** Aditi API call.
+ */
+
+static int MADITI_run_procedure(MR_String proc_name,
+ MR_String input_schema, String input_tuple, ticket **result);
+static int MADITI_create_cursor(ticket *output_ticket,
+ MADITI_output_info **result);
+static int MADITI_do_insert_delete_tuple(MADITI_insert_delete operation,
+ MR_String relation_name, MR_String update_proc,
+ MR_String update_schema, MR_String tuple);
+static int MADITI_do_bulk_operation(MADITI_bulk_op operation,
+ MR_String relation_name, MR_String update_proc,
+ ticket *closure_result);
+static int MADITI_cleanup_call_output(MADITI_output_info *);
+
+#ifdef MR_USE_TRAIL
+static void MADITI_trail_cleanup_call_output(void *cleanup_data,
+ MR_untrail_reason reason);
+#endif
+
+static int MADITI_list_rel(ticket* rel);
+").
+
+:- pragma c_code("
+
+ /*
+ ** No effort is made to ensure that MR_hp is valid where
+ ** memory is allocated. Given that it is likely that a better
+ ** way of allocating memory from C code is will be implemented
+ ** when the accurate garbage collector is finished, I don't
+ ** see much point in cluttering the code here with
+ ** save_transient_registers()/restore_transient_registers() calls.
+ */
+#ifndef CONSERVATIVE_GC
+#error ""The Aditi interface requires conservative garbage collection. \\
+ Use a compilation grade containing .gc.""
+#endif
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ %
+ % Code to handle connections.
+ %
+:- pragma c_code(
+ connect(Host::in, User::in, Passwd::in,
+ Stat::out, Connection::out, IO0::di, IO::uo),
+ will_not_call_mercury,
+"
+{
+ /* connect */
+ if ((Stat = init_aditi_clnt()) == ADITI_OK
+ && (Stat = ADITI_NAME(recon)(Host)) == ADITI_OK) {
+
+ MR_DEBUG(fprintf(stderr, ""connected\\n""));
+
+ /*
+ ** Login and upload all the RL code for the program to
+ ** the database.
+ */
+ if ((Stat = ADITI_NAME(login)(User, Passwd)) == ADITI_OK) {
+
+ MR_DEBUG(ADITI_NAME(set_debug)());
+
+ MR_DEBUG(fprintf(stderr, ""logged in\\n""));
+ if ((Stat = MR_load_aditi_rl_code())
+ == ADITI_OK) {
+ MR_DEBUG(fprintf(stderr, ""code loaded\\n""));
+ } else {
+ ADITI_NAME(discon)(FORCE_LOGOUT);
+ }
+ } else {
+ ADITI_NAME(discon)(FORCE_LOGOUT);
+ }
+ }
+ MADITI_debug_status(Stat);
+ Connection = 1;
+ IO = IO0;
+}
+").
+
+:- pragma c_code(
+ disconnect(_Connection::in, Stat::out, IO0::di, IO::uo),
+ will_not_call_mercury,
+"
+{
+ Stat = ADITI_NAME(discon)(FORCE_LOGOUT);
+ MADITI_debug_status(Stat);
+ if (Stat == ADITI_OK) {
+ Stat = fin_aditi_clnt();
+ MADITI_debug_status(Stat);
+ }
+ IO = IO0;
+}
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ %
+ % This section handles starting, committing and aborting transactions.
+ %
+
+start_transaction(_, Result) -->
+ start_transaction_2(Status, State),
+ { Status = 0 ->
+ Result = ok(State)
+ ;
+ error_code(Status, Error, String),
+ Result = error(Error, String)
+ }.
+
+:- pred start_transaction_2(int, aditi__state, io__state, io__state).
+:- mode start_transaction_2(out, out, di, uo) is det.
+
+:- pragma c_code(start_transaction_2(Stat::out, DB::out, IO0::di, IO::uo),
+ will_not_call_mercury,
+"{
+ IO = IO0;
+ MR_DEBUG(fprintf(stderr, ""starting transaction...""));
+ Stat = ADITI_NAME(trans_begin)(&MADITI_ticket);
+ MADITI_debug_status(Stat);
+ MADITI_status = Stat;
+ MR_DEBUG(fprintf(stderr, ""done\\n""));
+ DB = (MR_Word) 0;
+
+}").
+
+:- pragma c_code(abort_transaction(DB::in, IO0::di, IO::uo),
+ will_not_call_mercury,
+"{
+ /*
+ ** Ignore the return code -- we're more interested
+ ** in the error which caused the abort.
+ */
+ ADITI_NAME(trans_abort)(&MADITI_ticket);
+ DB = 0;
+ IO = IO0;
+}").
+
+:- pragma promise_pure(commit_transaction/3).
+commit_transaction(DB) -->
+ { semipure check_for_old_error },
+ commit_transaction_2(DB, Status),
+ { semipure maybe_throw_aditi_exception(Status) }.
+
+:- pred commit_transaction_2(aditi__state, int, io__state, io__state).
+:- mode commit_transaction_2(in, out, di, uo) is det.
+
+:- pragma c_code(commit_transaction_2(DB::in, Stat::out, IO0::di, IO::uo),
+ will_not_call_mercury,
+"{
+ Stat = ADITI_NAME(trans_commit)(&MADITI_ticket);
+ MADITI_debug_status(Stat);
+ DB = 0;
+ IO = IO0;
+}").
+
+ % Throw an exception to abort the transaction if the status
+ % is not ADITI_OK.
+ % This needs to be impure to stop it being reordered with
+ % other calls.
+:- semipure pred maybe_throw_aditi_exception(int).
+:- mode maybe_throw_aditi_exception(in) is det.
+
+maybe_throw_aditi_exception(Status) :-
+ ( Status = 0 ->
+ true
+ ;
+ error_code(Status, Error, String),
+ throw(aditi__exception(Error, String))
+ ).
+
+:- pred maybe_throw_aditi_exception(int, aditi__state, aditi__state).
+:- mode maybe_throw_aditi_exception(in, aditi_di, aditi_uo) is det.
+:- pragma promise_pure(maybe_throw_aditi_exception/3).
+
+maybe_throw_aditi_exception(Status) -->
+ { semipure maybe_throw_aditi_exception(Status) }.
+
+ % If a call result is cleaned up by untrailing, any errors
+ % will not result in the transaction being aborted immediately
+ % because there is no way to throw an exception from a trail
+ % function. Instead, a global variable is set to indicate that
+ % an error has occurred, and the next database call will
+ % check for the error and abort the transaction.
+ % This needs to be semipure to stop it being reordered with
+ % other calls.
+:- semipure pred check_for_old_error is det.
+
+check_for_old_error :-
+ semipure get_aditi_status(Status),
+ semipure maybe_throw_aditi_exception(Status).
+
+:- pred check_for_old_error(aditi__state, aditi__state).
+:- mode check_for_old_error(aditi_di, aditi_uo) is det.
+:- pragma promise_pure(check_for_old_error/2).
+
+check_for_old_error -->
+ { semipure check_for_old_error }.
+
+:- semipure pred get_aditi_status(int).
+:- mode get_aditi_status(out) is det.
+
+:- pragma c_code(get_aditi_status(Stat::out), will_not_call_mercury,
+ "Stat = MADITI_status;").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ %
+ % This section handles calls to Aditi predicates and functions.
+ %
+
+do_det_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ impure do_call_returning_relation(ProcName,
+ InputSchema, InputTuple, OutputRel),
+ impure create_cursor(OutputRel, CursorStatus, Cursor0),
+ semipure maybe_throw_aditi_exception(CursorStatus),
+ ( get_next_tuple(OutputTuple0, Cursor0, Cursor) ->
+ OutputTuple = OutputTuple0,
+ impure destroy_cursor(Cursor, DestroyStatus),
+ semipure maybe_throw_aditi_exception(DestroyStatus)
+ ;
+ impure destroy_cursor(Cursor0, DestroyStatus),
+ semipure maybe_throw_aditi_exception(DestroyStatus),
+ determinism_error("no solution", "det", ProcName)
+ ).
+
+do_semidet_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ impure do_call_returning_relation(ProcName,
+ InputSchema, InputTuple, OutputRel),
+ impure create_cursor(OutputRel, CursorStatus, Cursor0),
+ semipure maybe_throw_aditi_exception(CursorStatus),
+ ( get_next_tuple(OutputTuple0, Cursor0, Cursor) ->
+ %
+ % Assume that if a call succeeds multiple times,
+ % the other solutions are just duplicates.
+ %
+ OutputTuple = OutputTuple0,
+ impure destroy_cursor(Cursor, DestroyStatus),
+ semipure maybe_throw_aditi_exception(DestroyStatus)
+ ;
+ impure destroy_cursor(Cursor0, DestroyStatus),
+ semipure maybe_throw_aditi_exception(DestroyStatus),
+ fail
+ ).
+
+do_nondet_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ impure do_call_returning_relation(ProcName, InputSchema,
+ InputTuple, OutputRel),
+ impure create_cursor(OutputRel, CursorStatus, Cursor),
+ semipure maybe_throw_aditi_exception(CursorStatus),
+ impure collect_nondet_output_tuples(Cursor, OutputTuple).
+
+do_multi_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ (
+ impure do_nondet_call(ProcName, InputSchema,
+ InputTuple, OutputTuple0)
+ ->
+ OutputTuple = OutputTuple0
+ ;
+ determinism_error("no solution", "multi", ProcName)
+ ).
+
+do_cc_nondet_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ impure do_nondet_call(ProcName, InputSchema, InputTuple, OutputTuple).
+
+do_cc_multi_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ impure do_multi_call(ProcName, InputSchema, InputTuple, OutputTuple).
+
+do_erroneous_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ impure do_det_call(ProcName, InputSchema, InputTuple, OutputTuple),
+ determinism_error("solution", "erroneous", ProcName).
+
+do_failure_call(ProcName, InputSchema, InputTuple, OutputTuple) :-
+ (
+ impure do_semidet_call(ProcName, InputSchema,
+ InputTuple, OutputTuple0)
+ ->
+ OutputTuple = OutputTuple0,
+ determinism_error("solution", "failure", ProcName)
+ ;
+ fail
+ ).
+
+:- pred determinism_error(string, string, string).
+:- mode determinism_error(in, in, in) is erroneous.
+
+determinism_error(Solution, Det, ProcName) :-
+ string__format(
+ "Error in Aditi call: %s for procedure with determinism %s\n",
+ [s(Solution), s(Det), s(ProcName)], Msg),
+ throw(aditi__exception(determinism_error, Msg)).
+
+:- impure pred collect_nondet_output_tuples(cursor, T).
+:- mode collect_nondet_output_tuples(in, out) is nondet.
+
+collect_nondet_output_tuples(Cursor0, OutputTuple) :-
+ semipure check_for_old_error,
+ (
+ get_next_tuple(OutputTuple0, Cursor0, Cursor)
+ ->
+ (
+ OutputTuple = OutputTuple0
+ ;
+ impure collect_nondet_output_tuples(Cursor,
+ OutputTuple)
+ )
+ ;
+ impure destroy_cursor(Cursor0, DestroyStatus),
+ semipure maybe_throw_aditi_exception(DestroyStatus),
+ fail
+ ).
+
+do_call_returning_relation(ProcName, InputSchema, InputTuple, OutputRel) :-
+ construct_input_tuple(InputTuple, InputTupleStr),
+ impure do_call_returning_relation_2(ProcName, InputSchema,
+ InputTupleStr, Status, OutputRel),
+ semipure maybe_throw_aditi_exception(Status).
+
+:- impure pred do_call_returning_relation_2(string, string,
+ string, int, relation_ticket).
+:- mode do_call_returning_relation_2(in, in, in, out, out) is det.
+
+:- pragma c_code(do_call_returning_relation_2(ProcName::in, InputSchema::in,
+ InputTuple::in, Stat::out, OutputRel::out),
+ will_not_call_mercury,
+"{
+ ticket *output_rel;
+ Stat = (MR_Word) MADITI_run_procedure(ProcName,
+ InputSchema, InputTuple, &output_rel);
+ OutputRel = (MR_Word) output_rel;
+}").
+
+ % Create a cursor, adding an entry to the trail if possible
+ % to make sure that it is cleaned up.
+:- impure pred create_cursor(relation_ticket, int, cursor).
+:- mode create_cursor(in, out, out) is det.
+
+:- pragma c_code(create_cursor(Relation::in, Stat::out, Cursor::out),
+ will_not_call_mercury,
+"{
+ MADITI_output_info *output_info;
+ Stat = MADITI_create_cursor((ticket *)Relation, &output_info);
+ Cursor = (MR_Word) output_info;
+}").
+
+:- impure pred destroy_cursor(cursor, int).
+:- mode destroy_cursor(in, out) is det.
+
+:- pragma c_code(destroy_cursor(Cursor::in, Stat::out),
+ will_not_call_mercury,
+"
+ Stat = MADITI_cleanup_call_output((MADITI_output_info *) Cursor);
+").
+
+:- pred get_next_tuple(T, cursor, cursor).
+:- mode get_next_tuple(out, in, out) is semidet.
+
+get_next_tuple(OutputTuple, Cursor0, Cursor) :-
+ cursor_next(TupleStr, Cursor0, Cursor),
+ ArgTypeDescs = type_args(type_of(OutputTuple)),
+ Posn0 = posn(1, 0, 0),
+ string__length(TupleStr, TupleLength),
+ parse_output_tuple(ArgTypeDescs, TupleStr, TupleLength, Posn0,
+ OutputArgUnivs),
+ OutputTuple0 = univ_value(construct_tuple(OutputArgUnivs)),
+ OutputTuple = cast(OutputTuple0).
+
+ % The arguments of the output tuple were constructed using
+ % the argument types passed in -- we don't need to check
+ % that they match again.
+:- func cast(T) = U.
+:- pragma c_code(cast(T::in) = (U::out), will_not_call_mercury, "U = T;").
+
+:- pred cursor_next(string, cursor, cursor).
+:- mode cursor_next(out, in, out) is semidet.
+
+:- pragma c_code(cursor_next(Tuple::out, Cursor0::in, Cursor::out),
+ will_not_call_mercury,
+"
+{
+ int rc;
+ char *tuple_str;
+ int tuple_str_len;
+ MADITI_output_info *output_info;
+
+ Cursor = Cursor0;
+ output_info = (MADITI_output_info *) Cursor;
+ rc = ADITI_NAME(cursor_next)(output_info->output_cursor,
+ &tuple_str_len, &tuple_str);
+
+ /*
+ ** XXX This check should be more specific, but there is no
+ ** Aditi return code for no more tuples.
+ */
+ if (rc == ADITI_OK) {
+ MR_DEBUG(fprintf(stderr, ""received tuple: %s\\n"", tuple_str));
+ MR_make_aligned_string_copy(Tuple, tuple_str);
+ free(tuple_str);
+ SUCCESS_INDICATOR = TRUE;
+ } else {
+ SUCCESS_INDICATOR = FALSE;
+ }
+}
+").
+
+:- pred parse_output_tuple(list(type_desc), string, int,
+ io__posn, list(univ)).
+:- mode parse_output_tuple(in, in, in, in, out) is det.
+
+parse_output_tuple([], _, _, _, []).
+parse_output_tuple([TypeDesc | TypeDescs], Tuple, TupleLength, Posn0,
+ [Arg | Args]) :-
+ has_read_result_type(Result, TypeDesc),
+ io__read_from_string_with_int_instead_of_char("Aditi result tuple",
+ Tuple, TupleLength, Result, Posn0, Posn),
+ (
+ Result = ok(Field),
+ Arg = univ(Field)
+ ;
+ Result = eof,
+ string__format("Aditi: unexpected end of tuple: %s",
+ [s(Tuple)], ErrorMsg),
+ throw(aditi__exception(parse_error_in_tuple, ErrorMsg))
+ ;
+ Result = error(Msg, _),
+ string__format("Aditi: invalid tuple returned: %s",
+ [s(Msg)], ErrorMsg),
+ throw(aditi__exception(parse_error_in_tuple, ErrorMsg))
+ ),
+ parse_output_tuple(TypeDescs, Tuple, TupleLength, Posn, Args).
+
+ % Use existential types to set up the type of the output argument
+ % using the type-info passed for the output tuple.
+:- some [T] pred has_read_result_type(io__read_result(T), type_desc).
+:- mode has_read_result_type(unused, in) is det.
+
+has_read_result_type(Result, TypeDesc) :-
+ has_type(Var, TypeDesc),
+ read_result_type(Var, Result).
+
+:- pred read_result_type(T, io__read_result(T)).
+:- mode read_result_type(unused, unused) is det.
+
+read_result_type(_, _).
+
+:- pragma c_code("
+
+/*
+** Given an RL procedure name, the schema of the input relation and a tuple
+** to insert into the input relation, run the procedure, returning a ticket
+** for the output relation.
+*/
+static int
+MADITI_run_procedure(MR_String proc_name, MR_String input_schema,
+ MR_String input_tuple, ticket **output_ticket_ptr)
+{
+
+ ticket input_ticket; /* Ticket identifying the input relation. */
+ ticket *output_ticket; /* Ticket identifying the input relation. */
+
+
+ /*
+ ** Create a temporary relation to hold the input tuple.
+ */
+ MR_DEBUG(fprintf(stderr, ""creating input temporary (schema %s)..."",
+ input_schema));
+ MADITI_check(ADITI_NAME(tmp_create)(&MADITI_ticket,
+ input_schema, &input_ticket));
+ MR_DEBUG(fprintf(stderr, ""done\\n""));
+
+ /*
+ ** Insert the input tuple into the relation.
+ */
+ MR_DEBUG(fprintf(stderr, ""adding input tuple...%s"", input_tuple));
+ MADITI_check(ADITI_NAME(tmp_addtup)(&input_ticket, input_tuple));
+ MR_DEBUG(fprintf(stderr, ""done\\n""));
+
+ /*
+ ** Run the procedure.
+ */
+ MR_DEBUG(fprintf(stderr, ""running procedure... ""));
+ output_ticket = (ticket *) MR_GC_NEW(ticket);
+ MADITI_check(ADITI_NAME(run2_s)(proc_name, MADITI_QUERY_TIMEOUT,
+ &MADITI_ticket, &input_ticket, output_ticket));
+ MR_DEBUG(fprintf(stderr, ""done\\n""));
+
+ /*
+ ** Drop the input relation.
+ */
+ MR_DEBUG(fprintf(stderr, ""dropping input temporary...""));
+ MADITI_check(ADITI_NAME(tmp_destroy)(&input_ticket));
+ MR_DEBUG(fprintf(stderr, ""done\\n""));
+
+ MR_DEBUG(fprintf(stderr, ""output tuples\n""));
+ MR_DEBUG(MADITI_check(MADITI_list_rel(output_ticket)));
+ MR_DEBUG(fprintf(stderr, ""\\n\\n""));
+
+ *output_ticket_ptr = output_ticket;
+ return ADITI_OK;
+}
+
+static int
+MADITI_create_cursor(ticket *relation, MADITI_output_info **output_info_ptr)
+{
+ ticket *cursor;
+ MADITI_output_info *output_info;
+
+ /* create cursor on the output relation */
+ MR_DEBUG(fprintf(stderr, ""opening output cursor...""));
+ cursor = (ticket *) MR_GC_NEW(ticket);
+ MADITI_check(ADITI_NAME(rel_cursor_create)(relation, cursor));
+ MADITI_check(ADITI_NAME(cursor_open)(cursor, CUR_FORWARD));
+ MR_DEBUG(fprintf(stderr, ""done\\n""));
+
+ output_info = MR_GC_NEW(MADITI_output_info);
+ output_info->output_rel = relation;
+ output_info->output_cursor = cursor;
+ output_info->cleaned_up = FALSE;
+#ifdef MR_USE_TRAIL
+ MR_trail_function(MADITI_trail_cleanup_call_output,
+ (void *) output_info);
+#endif
+ *output_info_ptr = output_info;
+ return ADITI_OK;
+}
+
+static int
+MADITI_list_rel(ticket* rel)
+{
+ size_t len;
+ char* ptr;
+ ticket cur;
+
+ MADITI_check(ADITI_NAME(tmp_cursor_create)(rel,&cur));
+ MADITI_check(ADITI_NAME(cursor_open)(&cur,CUR_FORWARD));
+ len = 0;
+ ptr = NULL;
+ fflush(stdout);
+ while (ADITI_NAME(cursor_next)(&cur,&len,&ptr) == ADITI_OK) {
+ fprintf(stderr, ""tuple: [%.*s]\n"",(int)len,ptr);
+ free(ptr);
+ len = 0;
+ ptr = NULL;
+ }
+ MADITI_check(ADITI_NAME(cursor_close)(&cur));
+ MADITI_check(ADITI_NAME(cursor_destroy)(&cur));
+ return ADITI_OK;
+}
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** Free all resources used by a database call.
+*/
+
+#ifdef MR_USE_TRAIL
+static void
+MADITI_trail_cleanup_call_output(void *data, MR_untrail_reason reason)
+{
+ switch (reason) {
+ case MR_commit:
+ case MR_exception:
+ case MR_retry:
+ /*
+ ** Clean up the output relation. If the transaction
+ ** status is not ADITI_OK, the transaction is about
+ ** to be aborted, so it's best not to try to clean up.
+ ** The database will do any cleaning up that is required.
+ */
+ if (MADITI_status == ADITI_OK) {
+ MR_DEBUG(fprintf(stderr,
+ ""MADITI_trail_cleanup_call_output: cleaning up %d\\n"",
+ reason));
+ /*
+ ** We shouldn't throw exceptions during an untrail operation,
+ ** so we just set the status so that the next Aditi operation
+ ** called will abort the transaction if there were any errors.
+ */
+ MADITI_status = MADITI_cleanup_call_output(
+ (MADITI_output_info *)data);
+ }
+ break;
+ case MR_solve:
+ case MR_undo:
+ /*
+ ** Undo on backtracking will be handled by
+ ** do_*_call, so that the cleanup will happen
+ ** even if trailing is not being used.
+ */
+ break;
+
+ case MR_gc:
+ default:
+ MR_fatal_error(""MADITI_trail_cleanup_call_output"");
+ }
+}
+#endif /* MR_USE_TRAIL */
+
+static int
+MADITI_cleanup_call_output(MADITI_output_info *output_info)
+{
+ if (output_info->cleaned_up) {
+
+ /*
+ ** This can happen if there is a commit followed
+ ** by an exception -- the commit will not reset
+ ** the trail.
+ */
+ MR_DEBUG(fprintf(stderr,
+ ""MADITI_cleanup_call_output: already cleaned up\n""
+ ));
+
+ } else {
+
+ MR_DEBUG(fprintf(stderr,
+ ""MADITI_cleanup_call_output: cleaning up\n""
+ ));
+
+ /* close cursor */
+ MR_DEBUG(fprintf(stderr, ""closing cursor\\n""));
+ MADITI_check(
+ ADITI_NAME(cursor_close)(output_info->output_cursor)
+ );
+
+ /* destroy cursor */
+ MR_DEBUG(fprintf(stderr, ""destroying cursor\\n""));
+ MADITI_check(
+ ADITI_NAME(cursor_destroy)(output_info->output_cursor)
+ );
+ MR_GC_free(output_info->output_cursor);
+
+ /* close output temporary */
+ MR_DEBUG(fprintf(stderr,
+ ""closing output temporary relation\\n""));
+ MADITI_check(ADITI_NAME(rel_close)(output_info->output_rel));
+ MR_GC_free(output_info->output_rel);
+
+ /* Make sure we don't do this again. */
+ output_info->cleaned_up = TRUE;
+ }
+
+ return ADITI_OK;
+}
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ %
+ % This section handles updates.
+ %
+
+do_insert_tuple(RelationName, Args) -->
+ % There are no compiler-generated procedures for inserting
+ % a single tuple into a relation.
+ { UpdateProc = "" },
+ { UpdateSchema = "" },
+
+ do_insert_delete_tuple(insert_tuple, RelationName,
+ UpdateProc, UpdateSchema, Args).
+
+do_delete_tuple(RelationName, DeleteProc, DeleteProcInputSchema, Args) -->
+ do_insert_delete_tuple(delete_tuple, RelationName,
+ DeleteProc, DeleteProcInputSchema, Args).
+
+:- pred do_insert_delete_tuple(int, string, string, string,
+ T, aditi__state, aditi__state).
+:- mode do_insert_delete_tuple(in, in, in, in, in, aditi_di, aditi_uo) is det.
+
+do_insert_delete_tuple(InsertDelete, RelationName,
+ UpdateProc, UpdateSchema, Args) -->
+ check_for_old_error,
+ { construct_input_tuple(Args, Tuple) },
+ do_insert_delete_tuple_2(InsertDelete, RelationName,
+ UpdateProc, UpdateSchema, Tuple, Status),
+ maybe_throw_aditi_exception(Status).
+
+:- pred do_insert_delete_tuple_2(int, string, string, string, string, int,
+ aditi__state, aditi__state).
+:- mode do_insert_delete_tuple_2(in, in, in, in, in, out,
+ aditi_di, aditi_uo) is det.
+
+:- pragma c_code(do_insert_delete_tuple_2(InsertDelete::in, RelationName::in,
+ UpdateProc::in, UpdateSchema::in, Tuple::in, Stat::out,
+ DB0::aditi_di, DB::aditi_uo), will_not_call_mercury,
+"{
+ Stat = MADITI_do_insert_delete_tuple(
+ (MADITI_insert_delete) InsertDelete,
+ RelationName, UpdateProc, UpdateSchema, Tuple);
+ DB = DB0;
+}").
+
+:- func insert_tuple = int.
+:- pragma c_code(insert_tuple = (InsertTuple::out),
+ [will_not_call_mercury, thread_safe],
+ "InsertTuple = MADITI_INSERT_TUPLE;").
+:- func delete_tuple = int.
+:- pragma c_code(delete_tuple = (DeleteTuple::out),
+ [will_not_call_mercury, thread_safe],
+ "DeleteTuple = MADITI_DELETE_TUPLE;").
+
+do_bulk_insert(RelationName, InsertProcName, Closure) -->
+ do_bulk_operation(bulk_insert, RelationName, InsertProcName, Closure).
+
+do_bulk_delete(RelationName, DeleteProcName, Closure) -->
+ do_bulk_operation(bulk_delete, RelationName, DeleteProcName, Closure).
+
+do_bulk_modify(RelationName, ModifyProcName, Closure) -->
+ do_bulk_operation(bulk_delete, RelationName, ModifyProcName, Closure).
+
+:- pred do_bulk_operation(int, string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_operation(in, in, in, in(update_closure),
+ aditi_di, aditi_uo) is det.
+
+do_bulk_operation(Op, RelationName, UpdateProc, Closure) -->
+ check_for_old_error,
+ { Closure(ResultRelation) },
+ do_bulk_operation_2(Op, RelationName, UpdateProc,
+ ResultRelation, Status),
+ maybe_throw_aditi_exception(Status).
+
+:- pred do_bulk_operation_2(int, string, string, relation_ticket, int,
+ aditi__state, aditi__state).
+:- mode do_bulk_operation_2(in, in, in, in, out,
+ aditi_di, aditi_uo) is det.
+
+:- pragma c_code(do_bulk_operation_2(Op::in, RelationName::in, UpdateProc::in,
+ ResultRelation::in, Stat::out, DB0::aditi_di, DB::aditi_uo),
+ will_not_call_mercury,
+"{
+ Stat = MADITI_do_bulk_operation((MADITI_bulk_op) Op,
+ RelationName, UpdateProc, (ticket *) ResultRelation);
+ DB = DB0;
+}").
+
+:- func bulk_insert = int.
+:- pragma c_code(bulk_insert = (Insert::out),
+ [will_not_call_mercury, thread_safe],
+ "Insert = MADITI_INSERT;").
+
+:- func bulk_delete = int.
+:- pragma c_code(bulk_delete = (Delete::out),
+ [will_not_call_mercury, thread_safe],
+ "Delete = MADITI_DELETE;").
+
+:- func bulk_modify = int.
+:- pragma c_code(bulk_modify = (Modify::out),
+ [will_not_call_mercury, thread_safe],
+ "Modify = MADITI_MODIFY;").
+
+%-----------------------------------------------------------------------------%
+
+:- pragma c_code("
+
+static int
+MADITI_do_insert_delete_tuple(MADITI_insert_delete operation,
+ MR_String relation_name, MR_String update_proc,
+ MR_String update_schema, MR_String tuple)
+{
+ ticket *delete_output_rel;
+
+ switch (operation) {
+ case MADITI_INSERT_TUPLE:
+ MR_DEBUG(fprintf(stderr,
+ ""inserting tuple %s into relation %s\\n"",
+ tuple, relation_name));
+ MADITI_check(ADITI_NAME(addtup)(relation_name, tuple));
+ MR_DEBUG(fprintf(stderr, ""finished insertion\\n""));
+ break;
+
+ case MADITI_DELETE_TUPLE:
+ MR_DEBUG(fprintf(stderr,
+ ""deleting tuple %s from relation %s\\n"",
+ tuple , relation_name));
+ MADITI_check(MADITI_run_procedure(update_proc,
+ update_schema, tuple,
+ &delete_output_rel));
+ MADITI_check(
+ ADITI_NAME(rel_close)(delete_output_rel));
+ MR_DEBUG(fprintf(stderr, ""finished deletion\\n""));
+ break;
+ }
+ return ADITI_OK;
+}
+
+static int
+MADITI_do_bulk_operation(MADITI_bulk_op operation, MR_String relation_name,
+ MR_String update_proc, ticket *closure_result)
+{
+ ticket dummy_output_ticket;
+
+ MR_DEBUG(
+ switch (operation) {
+ case MADITI_INSERT:
+ fprintf(stderr,
+ ""aditi_bulk_insert(%s)\\n"", relation_name);
+ break;
+ case MADITI_DELETE:
+ fprintf(stderr,
+ ""aditi_bulk_delete(%s)\\n"", relation_name);
+ break;
+ case MADITI_MODIFY:
+ fprintf(stderr,
+ ""aditi_bulk_delete(%s)\\n"", relation_name);
+ break;
+ }
+ )
+
+ /*
+ ** Call the procedure generated by the compiler to apply the update.
+ */
+ MR_DEBUG(fprintf(stderr, ""Calling update procedure %s\\n"",
+ update_proc));
+ MADITI_check(ADITI_NAME(run2_s)(update_proc, MADITI_QUERY_TIMEOUT,
+ &MADITI_ticket, closure_result, &dummy_output_ticket)
+ );
+
+ /*
+ ** Clean up.
+ */
+ MADITI_check(ADITI_NAME(rel_close)(&dummy_output_ticket));
+ MADITI_check(ADITI_NAME(rel_close)((ticket *)closure_result));
+ MR_GC_free((ticket *)closure_result);
+
+ return ADITI_OK;
+}
+
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+ %
+ % Data conversion.
+ %
+
+:- pred construct_input_tuple(T, string).
+:- mode construct_input_tuple(in, out) is det.
+
+construct_input_tuple(Tuple, TupleStr) :-
+ NumArgs = type_ctor_arity(type_ctor(type_of(Tuple))),
+ construct_input_tuple_2(0, NumArgs, Tuple, ["("], RevStrings),
+
+ % XXX deforest this to reduce memory usage.
+ list__reverse([")\n" | RevStrings], Strings),
+ string__append_list(Strings, TupleStr).
+
+:- pred construct_input_tuple_2(int, int, T, list(string), list(string)).
+:- mode construct_input_tuple_2(in, in, in, in, out) is det.
+
+construct_input_tuple_2(Index, NumArgs, Tuple, Strings0, Strings) :-
+ ( Index < NumArgs ->
+ univ_to_string(det_argument(Tuple, Index), String),
+ ( Index = 0 ->
+ Strings1 = [String | Strings0]
+ ;
+ Strings1 = [String, ", " | Strings0]
+ ),
+ construct_input_tuple_2(Index + 1, NumArgs, Tuple,
+ Strings1, Strings)
+ ;
+ Strings = Strings0
+ ).
+
+ % This is very similar to io__write except
+ % a) it writes to a string
+ % b) everything is written in prefix form.
+ % c) arrays, c_pointers, type_infos and univs result in an abort.
+:- pred univ_to_string(univ, string).
+:- mode univ_to_string(in, out) is det.
+
+univ_to_string(Univ, String) :-
+ %
+ % we need to special-case the builtin types:
+ % int, char, float, string
+ % type_info, univ, c_pointer, array
+ %
+ ( univ_to_type(Univ, String1) ->
+ string__append_list(["\"", String1, "\""], String)
+ ; univ_to_type(Univ, Char) ->
+ char__to_int(Char, CharInt),
+ string__int_to_string(CharInt, String)
+ ; univ_to_type(Univ, Int) ->
+ string__int_to_string(Int, String)
+ ; univ_to_type(Univ, Float) ->
+ string__float_to_string(Float, String)
+ ;
+ ordinary_term_to_string(Univ, String)
+ ).
+
+:- pred ordinary_term_to_string(univ, string).
+:- mode ordinary_term_to_string(in, out) is det.
+
+ordinary_term_to_string(Term, String) :-
+ deconstruct(univ_value(Term), Functor, _Arity, Args),
+ quote_atom(Functor, FunctorStr),
+ term_args_to_strings(yes, Args, ["(" | FunctorStr],
+ Strings0),
+ list__reverse([")" | Strings0], Strings),
+ string__append_list(Strings, String).
+
+:- pred term_args_to_strings(bool, list(univ),
+ list(string), list(string)).
+:- mode term_args_to_strings(in, in, in, out) is det.
+
+term_args_to_strings(_, [], Strings, Strings).
+term_args_to_strings(IsFirst, [X | Xs], Strings0, Strings) :-
+ univ_to_string(X, XStr),
+ ( IsFirst = yes ->
+ Comma = ""
+ ;
+ Comma = ", "
+ ),
+ term_args_to_strings(no, Xs, [XStr, Comma | Strings0], Strings).
+
+:- pred quote_atom(string::in, list(string)::out) is det.
+
+quote_atom(String0, Quoted) :-
+ ( string__is_alnum_or_underscore(String0) ->
+ Quoted = [String0]
+ ;
+ Quoted = ["'", String0, "'"]
+ ).
+
+%-----------------------------------------------------------------------------%
+ %
+ % Attempt to make sense of the Aditi return code.
+ % XXX Aditi needs some way to return more descriptive
+ % error messages.
+ %
+
+error_code(Status, Error, String) :-
+ ( error_code_2(Status, Error0) ->
+ Error = Error0,
+ error_message(Status, String)
+ ;
+ Error = general_failure,
+ string__format("invalid Aditi error code %i",
+ [i(Status)], String)
+ ).
+
+:- pred error_code_2(int::in, aditi__error::out) is semidet.
+
+error_code_2(-1, invalid_passwd).
+error_code_2(-2, invalid_passwd).
+error_code_2(-3, general_failure).
+error_code_2(-4, general_failure).
+error_code_2(-5, too_many_connections).
+error_code_2(-6, general_failure).
+error_code_2(-7, general_failure).
+error_code_2(-8, already_logged_in).
+error_code_2(-9, not_logged_in).
+error_code_2(-10, general_failure).
+error_code_2(-11, general_failure).
+error_code_2(-12, general_failure).
+error_code_2(-13, general_failure).
+error_code_2(-14, error_creating_client).
+error_code_2(-15, general_failure).
+error_code_2(-16, not_implemented).
+error_code_2(-17, abort).
+error_code_2(-18, general_failure).
+error_code_2(-19, general_failure).
+error_code_2(-20, general_failure).
+error_code_2(-21, bad_value).
+error_code_2(-22, not_connected).
+error_code_2(-23, bad_rl_code).
+error_code_2(-24, bad_rl_code).
+error_code_2(-25, bad_rl_code).
+error_code_2(-26, error_opening_relation).
+error_code_2(-27, bad_rl_code).
+error_code_2(-28, bad_rl_code).
+error_code_2(-29, security_violation).
+error_code_2(-30, bad_rl_code).
+error_code_2(-31, bad_rl_code).
+error_code_2(-32, bad_rl_code).
+error_code_2(-33, unique_key_violation).
+error_code_2(-34, relation_or_cursor_not_open).
+error_code_2(-35, general_failure).
+error_code_2(-36, bad_value).
+error_code_2(-37, timeout).
+
+:- pred error_message(int::in, string::out) is det.
+
+:- pragma c_code(error_message(Stat::in, Msg::out),
+ will_not_call_mercury,
+"
+ Msg = aditi_strerror((int) Stat);
+").
+
Index: tests/invalid/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mercury.options,v
retrieving revision 1.3
diff -u -u -r1.3 Mercury.options
--- tests/invalid/Mercury.options 7 Nov 2002 16:17:08 -0000 1.3
+++ tests/invalid/Mercury.options 4 Mar 2003 11:46:49 -0000
@@ -4,6 +4,7 @@
MCFLAGS-aditi_errors = --aditi --no-intermodule-optimization \
--no-automatic-intermodule-optimization
+MCFLAGS-aditi_private_builtin = --allow-stubs
MCFLAGS-aditi_state_errors = --aditi --no-intermodule-optimization \
--no-automatic-intermodule-optimization
MCFLAGS-aditi_update_derived_relation = --aditi --no-intermodule-optimization \
Index: tests/invalid/aditi_private_builtin.m
===================================================================
RCS file: tests/invalid/aditi_private_builtin.m
diff -N tests/invalid/aditi_private_builtin.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/aditi_private_builtin.m 4 Mar 2003 11:45:40 -0000
@@ -0,0 +1,83 @@
+:- module aditi_private_builtin.
+
+:- interface.
+
+:- import_module io.
+:- import_module aditi.
+
+:- type relation_ticket == c_pointer.
+
+ % do_call_returning_relation(ProcName, InputSchema, InputTuple,
+ % OutputRel).
+ %
+ % Call an Aditi procedure, returning a reference to the output
+ % relation. InputTuple is a tuple containing the
+ % input arguments. InputSchema is an Aditi schema string
+ % describing the tuple of input arguments.
+:- impure pred do_call_returning_relation(string, string,
+ T, relation_ticket).
+:- mode do_call_returning_relation(in, in, in, out) is det.
+
+ % Find the single solution for a deterministic database call.
+ % Abort the transaction if the call does not succeed at
+ % least once.
+ % InputTuple and OutputTuple must have type '{}/N' (the arity
+ % depends on the relation being called).
+:- impure pred do_det_call(string, string, InputTuple, OutputTuple).
+:- mode do_det_call(in, in, in, out) is det.
+
+:- impure pred do_semidet_call(string, string, InputTuple, OutputTuple).
+:- mode do_semidet_call(in, in, in, out) is semidet.
+
+:- impure pred do_nondet_call(string, string, InputTuple, OutputTuple).
+:- mode do_nondet_call(in, in, in, out) is nondet.
+
+:- impure pred do_multi_call(string, string, InputTuple, OutputTuple).
+:- mode do_multi_call(in, in, in, out) is multi.
+
+ % XXX I'm not sure whether it makes sense to have
+ % committed choice Aditi predicates.
+:- impure pred do_cc_nondet_call(string, string, InputTuple, OutputTuple).
+:- mode do_cc_nondet_call(in, in, in, out) is cc_nondet.
+
+:- impure pred do_cc_multi_call(string, string, InputTuple, OutputTuple).
+:- mode do_cc_multi_call(in, in, in, out) is cc_multi.
+
+:- impure pred do_erroneous_call(string, string, InputTuple, OutputTuple).
+:- mode do_erroneous_call(in, in, in, out) is erroneous.
+
+:- impure pred do_failure_call(string, string, InputTuple, OutputTuple).
+:- mode do_failure_call(in, in, in, out) is failure.
+
+ % do_insert_tuple(BaseRelationName, Tuple).
+ %
+ % TypeInfos is an array containing the type-infos for
+ % the tuple to insert. TupleArgs contains the attribute
+ % values of the tuple to insert.
+:- pred do_insert_tuple(string, InputTuple, aditi__state, aditi__state).
+:- mode do_insert_tuple(in, in, aditi_di, aditi_uo) is det.
+
+ % do_delete_tuple(BaseRelationName, DeleteProcName,
+ % DeleteProcInputSchema, Tuple).
+:- pred do_delete_tuple(string, string, string, Tuple,
+ aditi__state, aditi__state).
+:- mode do_delete_tuple(in, in, in, in, aditi_di, aditi_uo) is det.
+
+:- type update_closure == pred(relation_ticket).
+:- inst update_closure == (pred(out) is det).
+
+ % do_bulk_insert(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_insert(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_insert(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
+ % do_bulk_delete(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_delete(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_delete(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
+ % do_bulk_modify(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_modify(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_modify(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
Index: tests/valid/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mercury.options,v
retrieving revision 1.6
diff -u -u -r1.6 Mercury.options
--- tests/valid/Mercury.options 22 Feb 2003 13:18:33 -0000 1.6
+++ tests/valid/Mercury.options 4 Mar 2003 10:45:06 -0000
@@ -25,6 +25,7 @@
MCFLAGS-aditi_error_bug = --aditi
MCFLAGS-aditi_error_bug2 = --aditi
MCFLAGS-aditi_error_bug3 = --aditi
+MCFLAGS-aditi_private_builtin = --allow-stubs
MCFLAGS-aditi_query = --aditi-only
MCFLAGS-aditi_update = --aditi
MCFLAGS-base_relation = --aditi
Index: tests/valid/aditi_private_builtin.m
===================================================================
RCS file: tests/valid/aditi_private_builtin.m
diff -N tests/valid/aditi_private_builtin.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/aditi_private_builtin.m 4 Mar 2003 11:45:12 -0000
@@ -0,0 +1,83 @@
+:- module aditi_private_builtin.
+
+:- interface.
+
+:- import_module io.
+:- import_module aditi.
+
+:- type relation_ticket == c_pointer.
+
+ % do_call_returning_relation(ProcName, InputSchema, InputTuple,
+ % OutputRel).
+ %
+ % Call an Aditi procedure, returning a reference to the output
+ % relation. InputTuple is a tuple containing the
+ % input arguments. InputSchema is an Aditi schema string
+ % describing the tuple of input arguments.
+:- impure pred do_call_returning_relation(string, string,
+ T, relation_ticket).
+:- mode do_call_returning_relation(in, in, in, out) is det.
+
+ % Find the single solution for a deterministic database call.
+ % Abort the transaction if the call does not succeed at
+ % least once.
+ % InputTuple and OutputTuple must have type '{}/N' (the arity
+ % depends on the relation being called).
+:- impure pred do_det_call(string, string, InputTuple, OutputTuple).
+:- mode do_det_call(in, in, in, out) is det.
+
+:- impure pred do_semidet_call(string, string, InputTuple, OutputTuple).
+:- mode do_semidet_call(in, in, in, out) is semidet.
+
+:- impure pred do_nondet_call(string, string, InputTuple, OutputTuple).
+:- mode do_nondet_call(in, in, in, out) is nondet.
+
+:- impure pred do_multi_call(string, string, InputTuple, OutputTuple).
+:- mode do_multi_call(in, in, in, out) is multi.
+
+ % XXX I'm not sure whether it makes sense to have
+ % committed choice Aditi predicates.
+:- impure pred do_cc_nondet_call(string, string, InputTuple, OutputTuple).
+:- mode do_cc_nondet_call(in, in, in, out) is cc_nondet.
+
+:- impure pred do_cc_multi_call(string, string, InputTuple, OutputTuple).
+:- mode do_cc_multi_call(in, in, in, out) is cc_multi.
+
+:- impure pred do_erroneous_call(string, string, InputTuple, OutputTuple).
+:- mode do_erroneous_call(in, in, in, out) is erroneous.
+
+:- impure pred do_failure_call(string, string, InputTuple, OutputTuple).
+:- mode do_failure_call(in, in, in, out) is failure.
+
+ % do_insert_tuple(BaseRelationName, Tuple).
+ %
+ % TypeInfos is an array containing the type-infos for
+ % the tuple to insert. TupleArgs contains the attribute
+ % values of the tuple to insert.
+:- pred do_insert_tuple(string, InputTuple, aditi__state, aditi__state).
+:- mode do_insert_tuple(in, in, aditi_di, aditi_uo) is det.
+
+ % do_delete_tuple(BaseRelationName, DeleteProcName,
+ % DeleteProcInputSchema, Tuple).
+:- pred do_delete_tuple(string, string, string, Tuple,
+ aditi__state, aditi__state).
+:- mode do_delete_tuple(in, in, in, in, aditi_di, aditi_uo) is det.
+
+:- type update_closure == pred(relation_ticket).
+:- inst update_closure == (pred(out) is det).
+
+ % do_bulk_insert(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_insert(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_insert(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
+ % do_bulk_delete(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_delete(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_delete(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
+ % do_bulk_modify(BaseRelationName, UpdateProcName, Closure).
+:- pred do_bulk_modify(string, string, update_closure,
+ aditi__state, aditi__state).
+:- mode do_bulk_modify(in, in, in(update_closure), aditi_di, aditi_uo) is det.
+
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list