mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-15 13:55:07 +00:00
Estimated hours taken: 2 hlds_goal: Change the definition of is_builtin to use less space. bytecode_gen, code_aux, code_gen, code_util, dependency_graph, follow_code, higher_order, inlining, live_vars, make_hlds, modecheck_unify, modes, polymorphism, stratify, unused_args: Fixes to accommodate the change to is_builtin.
1394 lines
45 KiB
Mathematica
1394 lines
45 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1995 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.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% unify_proc.m:
|
|
%
|
|
% This module encapsulates access to the unify_requests table,
|
|
% and constructs the clauses for out-of-line complicated
|
|
% unification procedures.
|
|
% It also generates the code for other compiler-generated type-specific
|
|
% predicates such as compare/3.
|
|
%
|
|
% During mode analysis, we notice each different complicated unification
|
|
% that occurs. For each one we add a new mode to the out-of-line
|
|
% unification predicate for that type, and we record in the `unify_requests'
|
|
% table that we need to eventually modecheck that mode of the unification
|
|
% procedure.
|
|
%
|
|
% After we've done mode analysis for all the ordinary predicates, we then
|
|
% do mode analysis for the out-of-line unification procedures. Note that
|
|
% unification procedures may call other unification procedures which have
|
|
% not yet been encountered, causing new entries to be added to the
|
|
% unify_requests table. We store the entries in a queue and continue the
|
|
% process until the queue is empty.
|
|
%
|
|
% Currently if the same complicated unification procedure is called by
|
|
% different modules, each module will end up with a copy of the code for
|
|
% that procedure. In the long run it would be desireable to either delay
|
|
% generation of complicated unification procedures until link time (like
|
|
% Cfront does with C++ templates) or to have a smart linker which could
|
|
% merge duplicate definitions (like Borland C++). However the amount of
|
|
% code duplication involved is probably very small, so it's definitely not
|
|
% worth worrying about right now.
|
|
|
|
% XXX What about complicated unification of an abstract type in a partially
|
|
% instantiated mode? Currently we don't implement it correctly. Probably
|
|
% it should be disallowed, but we should issue a proper error message.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module unify_proc.
|
|
|
|
:- interface.
|
|
:- import_module hlds_module, hlds_pred, hlds_goal, hlds_data.
|
|
:- import_module llds, modes, prog_data, special_pred.
|
|
:- import_module bool, std_util, io, list.
|
|
|
|
:- type unify_requests.
|
|
|
|
:- type unify_proc_id == pair(type_id, uni_mode).
|
|
|
|
% Initialize the unify_requests table.
|
|
|
|
:- pred unify_proc__init_requests(unify_requests).
|
|
:- mode unify_proc__init_requests(out) is det.
|
|
|
|
% Add a new request to the unify_requests table.
|
|
|
|
:- pred unify_proc__request_unify(unify_proc_id, determinism,
|
|
module_info, module_info).
|
|
:- mode unify_proc__request_unify(in, in, in, out) is det.
|
|
|
|
% Modecheck the unification procedures which have been
|
|
% requested. If the first argument is `unique_mode_check',
|
|
% then also go on and do full determinism analysis and unique mode
|
|
% checking on them as well.
|
|
|
|
:- pred modecheck_unify_procs(how_to_check_goal, module_info, module_info,
|
|
io__state, io__state).
|
|
:- mode modecheck_unify_procs(in, in, out, di, uo) is det.
|
|
|
|
% Given the type and mode of a unification, look up the
|
|
% mode number for the unification proc.
|
|
|
|
:- pred unify_proc__lookup_mode_num(module_info, type_id, uni_mode,
|
|
determinism, proc_id).
|
|
:- mode unify_proc__lookup_mode_num(in, in, in, in, out) is det.
|
|
|
|
% Generate the clauses for one of the compiler-generated
|
|
% special predicates (compare/3, index/3, unify, etc.)
|
|
|
|
:- pred unify_proc__generate_clause_info(special_pred_id, type,
|
|
hlds__type_body, module_info, clauses_info).
|
|
:- mode unify_proc__generate_clause_info(in, in, in, in, out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
:- import_module tree, map, queue, int, string, require.
|
|
:- import_module code_util, code_info, type_util, varset.
|
|
:- import_module mercury_to_mercury, hlds_out.
|
|
:- import_module make_hlds, term, prog_util.
|
|
:- import_module quantification, clause_to_proc.
|
|
:- import_module globals, options, mode_util.
|
|
:- import_module switch_detection, cse_detection, det_analysis, unique_modes.
|
|
|
|
% We keep track of all the complicated unification procs we need
|
|
% by storing them in the unify_requests structure.
|
|
% For each unify_proc_id (i.e. type & mode), we store the proc_id
|
|
% (mode number) of the unification procedure which corresponds to
|
|
% that mode.
|
|
|
|
:- type req_map == map(unify_proc_id, proc_id).
|
|
|
|
:- type req_queue == queue(unify_proc_id).
|
|
|
|
:- type unify_requests --->
|
|
unify_requests(
|
|
req_map, % the assignment of numbers
|
|
% to unify_proc_ids
|
|
req_queue % queue of procs we still need
|
|
% to generate code for
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
unify_proc__init_requests(Requests) :-
|
|
map__init(ReqMap),
|
|
queue__init(ReqQueue),
|
|
Requests = unify_requests(ReqMap, ReqQueue).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Boring access predicates
|
|
|
|
:- pred unify_proc__get_req_map(unify_requests, req_map).
|
|
:- mode unify_proc__get_req_map(in, out) is det.
|
|
|
|
:- pred unify_proc__get_req_queue(unify_requests, req_queue).
|
|
:- mode unify_proc__get_req_queue(in, out) is det.
|
|
|
|
:- pred unify_proc__set_req_map(unify_requests, req_map, unify_requests).
|
|
:- mode unify_proc__set_req_map(in, in, out) is det.
|
|
|
|
:- pred unify_proc__set_req_queue(unify_requests, req_queue, unify_requests).
|
|
:- mode unify_proc__set_req_queue(in, in, out) is det.
|
|
|
|
unify_proc__get_req_map(unify_requests(ReqMap, _), ReqMap).
|
|
|
|
unify_proc__get_req_queue(unify_requests(_, ReqQueue), ReqQueue).
|
|
|
|
unify_proc__set_req_map(unify_requests(_, B), ReqMap,
|
|
unify_requests(ReqMap, B)).
|
|
|
|
unify_proc__set_req_queue(unify_requests(A, _), ReqQueue,
|
|
unify_requests(A, ReqQueue)).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
unify_proc__lookup_mode_num(ModuleInfo, TypeId, UniMode, Det, Num) :-
|
|
( unify_proc__search_mode_num(ModuleInfo, TypeId, UniMode, Det, Num1) ->
|
|
Num = Num1
|
|
;
|
|
error("unify_proc.m: unify_proc__search_num failed")
|
|
).
|
|
|
|
:- pred unify_proc__search_mode_num(module_info, type_id, uni_mode, determinism,
|
|
proc_id).
|
|
:- mode unify_proc__search_mode_num(in, in, in, in, out) is semidet.
|
|
|
|
% Given the type, mode, and determinism of a unification, look up the
|
|
% mode number for the unification proc.
|
|
% We handle semidet unifications with mode (in, in) specially - they
|
|
% are always mode zero. For unreachable unifications,
|
|
% we also use mode zero.
|
|
|
|
unify_proc__search_mode_num(ModuleInfo, TypeId, UniMode, Determinism, ProcId) :-
|
|
UniMode = (XInitial - YInitial -> _Final),
|
|
(
|
|
Determinism = semidet,
|
|
inst_is_ground(ModuleInfo, XInitial),
|
|
inst_is_ground(ModuleInfo, YInitial)
|
|
->
|
|
ProcId = 0
|
|
;
|
|
XInitial = not_reached
|
|
->
|
|
ProcId = 0
|
|
;
|
|
YInitial = not_reached
|
|
->
|
|
ProcId = 0
|
|
;
|
|
module_info_get_unify_requests(ModuleInfo, Requests),
|
|
unify_proc__get_req_map(Requests, ReqMap),
|
|
map__search(ReqMap, TypeId - UniMode, ProcId)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
unify_proc__request_unify(UnifyId, Determinism, ModuleInfo0, ModuleInfo) :-
|
|
%
|
|
% check if this unification has already been requested
|
|
%
|
|
UnifyId = TypeId - UnifyMode,
|
|
(
|
|
unify_proc__search_mode_num(ModuleInfo0, TypeId, UnifyMode,
|
|
Determinism, _)
|
|
->
|
|
ModuleInfo = ModuleInfo0
|
|
;
|
|
%
|
|
% lookup the pred_id for the unification procedure
|
|
% that we are going to generate
|
|
%
|
|
module_info_get_special_pred_map(ModuleInfo0, SpecialPredMap),
|
|
map__lookup(SpecialPredMap, unify - TypeId, PredId),
|
|
|
|
%
|
|
% create a new proc_info for this procedure
|
|
%
|
|
module_info_preds(ModuleInfo0, Preds0),
|
|
map__lookup(Preds0, PredId, PredInfo0),
|
|
Arity = 2,
|
|
% convert from `uni_mode' to `list(mode)'
|
|
UnifyMode = ((X_Initial - Y_Initial) -> (X_Final - Y_Final)),
|
|
ArgModes = [(X_Initial -> X_Final), (Y_Initial -> Y_Final)],
|
|
MaybeDet = yes(Determinism),
|
|
term__context_init(Context),
|
|
ArgLives = no, % XXX ArgLives should be part of the UnifyId
|
|
add_new_proc(PredInfo0, Arity, ArgModes, ArgLives, MaybeDet,
|
|
Context, PredInfo1, ProcId),
|
|
|
|
%
|
|
% copy the clauses for the procedure from the pred_info to the
|
|
% proc_info, and mark the procedure as one that cannot
|
|
% be processed yet
|
|
%
|
|
pred_info_procedures(PredInfo1, Procs1),
|
|
pred_info_clauses_info(PredInfo1, ClausesInfo),
|
|
map__lookup(Procs1, ProcId, ProcInfo0),
|
|
proc_info_set_can_process(ProcInfo0, no, ProcInfo1),
|
|
|
|
copy_clauses_to_proc(ProcId, ClausesInfo, ProcInfo1, ProcInfo2),
|
|
map__set(Procs1, ProcId, ProcInfo2, Procs2),
|
|
pred_info_set_procedures(PredInfo1, Procs2, PredInfo2),
|
|
map__set(Preds0, PredId, PredInfo2, Preds2),
|
|
module_info_set_preds(ModuleInfo0, Preds2, ModuleInfo2),
|
|
|
|
%
|
|
% save the proc_id for this unify_proc_id,
|
|
% and insert the unify_proc_id into the request queue
|
|
%
|
|
module_info_get_unify_requests(ModuleInfo2, Requests0),
|
|
unify_proc__get_req_map(Requests0, ReqMap0),
|
|
map__set(ReqMap0, UnifyId, ProcId, ReqMap),
|
|
unify_proc__set_req_map(Requests0, ReqMap, Requests1),
|
|
|
|
unify_proc__get_req_queue(Requests1, ReqQueue1),
|
|
queue__put(ReqQueue1, UnifyId, ReqQueue),
|
|
unify_proc__set_req_queue(Requests1, ReqQueue, Requests),
|
|
|
|
module_info_set_unify_requests(ModuleInfo2, Requests,
|
|
ModuleInfo)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% XXX these belong in modes.m
|
|
|
|
modecheck_unify_procs(HowToCheckGoal, ModuleInfo0, ModuleInfo) -->
|
|
{ module_info_get_unify_requests(ModuleInfo0, Requests0) },
|
|
{ unify_proc__get_req_queue(Requests0, RequestQueue0) },
|
|
(
|
|
{ queue__get(RequestQueue0, UnifyProcId, RequestQueue1) }
|
|
->
|
|
{ unify_proc__set_req_queue(Requests0, RequestQueue1,
|
|
Requests1) },
|
|
{ module_info_set_unify_requests(ModuleInfo0, Requests1,
|
|
ModuleInfo1) },
|
|
globals__io_lookup_bool_option(very_verbose, VeryVerbose),
|
|
( { VeryVerbose = yes } ->
|
|
{ UnifyProcId = TypeId - UniMode },
|
|
( { HowToCheckGoal = check_unique_modes } ->
|
|
io__write_string(
|
|
"% Mode-checking, determinism-checking, and unique-mode-checking\n% ")
|
|
;
|
|
io__write_string("% Mode-checking ")
|
|
),
|
|
io__write_string("unification proc for type `"),
|
|
hlds_out__write_type_id(TypeId),
|
|
io__write_string("'\n"),
|
|
io__write_string("% with insts `"),
|
|
{ UniMode = ((InstA - InstB) -> _FinalInst) },
|
|
{ varset__init(InstVarSet) },
|
|
mercury_output_inst(InstA, InstVarSet),
|
|
io__write_string("', `"),
|
|
mercury_output_inst(InstB, InstVarSet),
|
|
io__write_string("'\n")
|
|
;
|
|
[]
|
|
),
|
|
modecheck_unification_proc(HowToCheckGoal, UnifyProcId,
|
|
ModuleInfo1, ModuleInfo2),
|
|
modecheck_unify_procs(HowToCheckGoal, ModuleInfo2, ModuleInfo)
|
|
;
|
|
{ ModuleInfo = ModuleInfo0 }
|
|
).
|
|
|
|
:- pred modecheck_unification_proc(how_to_check_goal, unify_proc_id,
|
|
module_info, module_info, io__state, io__state).
|
|
:- mode modecheck_unification_proc(in, in, in, out, di, uo) is det.
|
|
|
|
modecheck_unification_proc(HowToCheckGoal, UnifyProcId,
|
|
ModuleInfo0, ModuleInfo) -->
|
|
{
|
|
%
|
|
% lookup the pred_id for the unification procedure
|
|
% that we are going to generate
|
|
%
|
|
UnifyProcId = TypeId - _UnifyMode,
|
|
module_info_get_special_pred_map(ModuleInfo0, SpecialPredMap),
|
|
map__lookup(SpecialPredMap, unify - TypeId, PredId),
|
|
|
|
%
|
|
% lookup the proc_id
|
|
%
|
|
module_info_get_unify_requests(ModuleInfo0, Requests0),
|
|
unify_proc__get_req_map(Requests0, ReqMap),
|
|
map__lookup(ReqMap, UnifyProcId, ProcId),
|
|
|
|
%
|
|
% mark the procedure as ready to be processed
|
|
%
|
|
module_info_preds(ModuleInfo0, Preds0),
|
|
map__lookup(Preds0, PredId, PredInfo0),
|
|
pred_info_procedures(PredInfo0, Procs0),
|
|
map__lookup(Procs0, ProcId, ProcInfo0),
|
|
proc_info_set_can_process(ProcInfo0, yes, ProcInfo1),
|
|
map__set(Procs0, ProcId, ProcInfo1, Procs1),
|
|
pred_info_set_procedures(PredInfo0, Procs1, PredInfo1),
|
|
map__set(Preds0, PredId, PredInfo1, Preds1),
|
|
module_info_set_preds(ModuleInfo0, Preds1, ModuleInfo1)
|
|
},
|
|
|
|
%
|
|
% modecheck the procedure
|
|
%
|
|
modecheck_proc(ProcId, PredId, ModuleInfo1, ModuleInfo2, NumErrors),
|
|
{ NumErrors \= 0 ->
|
|
error("mode error in compiler-generated unification predicate")
|
|
;
|
|
true
|
|
},
|
|
( { HowToCheckGoal = check_unique_modes } ->
|
|
{ detect_switches_in_proc(ProcId, PredId,
|
|
ModuleInfo2, ModuleInfo3) },
|
|
detect_cse_in_proc(ProcId, PredId,
|
|
ModuleInfo3, ModuleInfo4),
|
|
determinism_check_proc(ProcId, PredId,
|
|
ModuleInfo4, ModuleInfo5),
|
|
unique_modes__check_proc(ProcId, PredId,
|
|
ModuleInfo5, ModuleInfo)
|
|
;
|
|
{ ModuleInfo = ModuleInfo2 }
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
unify_proc__generate_clause_info(SpecialPredId, Type, TypeBody, ModuleInfo,
|
|
ClauseInfo) :-
|
|
unify_proc__info_init(ModuleInfo, VarTypeInfo0),
|
|
( TypeBody = eqv_type(EqvType) ->
|
|
HeadVarType = EqvType
|
|
;
|
|
HeadVarType = Type
|
|
),
|
|
special_pred_info(SpecialPredId, HeadVarType,
|
|
_PredName, ArgTypes, _Modes, _Det),
|
|
unify_proc__make_fresh_vars_from_types(ArgTypes, Args,
|
|
VarTypeInfo0, VarTypeInfo1),
|
|
( SpecialPredId = unify, Args = [H1, H2] ->
|
|
unify_proc__generate_unify_clauses(TypeBody, H1, H2,
|
|
Clauses, VarTypeInfo1, VarTypeInfo)
|
|
; SpecialPredId = index, Args = [X, Index] ->
|
|
unify_proc__generate_index_clauses(TypeBody, X, Index,
|
|
Clauses, VarTypeInfo1, VarTypeInfo)
|
|
; SpecialPredId = compare, Args = [Res, X, Y] ->
|
|
unify_proc__generate_compare_clauses(TypeBody, Res, X, Y,
|
|
Clauses, VarTypeInfo1, VarTypeInfo)
|
|
; SpecialPredId = term_to_type, Args = [Term, X] ->
|
|
unify_proc__generate_term_to_type_clauses(TypeBody, Term, X,
|
|
Clauses, VarTypeInfo1, VarTypeInfo)
|
|
; SpecialPredId = type_to_term, Args = [X, Term] ->
|
|
unify_proc__generate_type_to_term_clauses(TypeBody, X, Term,
|
|
Clauses, VarTypeInfo1, VarTypeInfo)
|
|
;
|
|
error("unknown special pred")
|
|
),
|
|
unify_proc__info_extract(VarTypeInfo, VarSet, Types),
|
|
ClauseInfo = clauses_info(VarSet, Types, Types, Args, Clauses).
|
|
|
|
:- pred unify_proc__generate_unify_clauses(hlds__type_body, var, var,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_unify_clauses(in, in, in, out, in, out) is det.
|
|
|
|
unify_proc__generate_unify_clauses(TypeBody, H1, H2, Clauses) -->
|
|
( { TypeBody = du_type(Ctors, _, IsEnum), IsEnum = no } ->
|
|
unify_proc__generate_du_unify_clauses(Ctors, H1, H2, Clauses)
|
|
;
|
|
{ term__context_init(Context) },
|
|
{ create_atomic_unification(H1, var(H2), Context, explicit, [],
|
|
Goal) },
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body([H1, H2], Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ Clauses = [clause([], Body, Context)] }
|
|
).
|
|
|
|
:- pred unify_proc__generate_index_clauses(hlds__type_body, var, var,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_index_clauses(in, in, in, out, in, out) is det.
|
|
|
|
unify_proc__generate_index_clauses(TypeBody, X, Index, Clauses) -->
|
|
( { TypeBody = du_type(Ctors, _, IsEnum), IsEnum = no } ->
|
|
unify_proc__generate_du_index_clauses(Ctors, X, Index, 0,
|
|
Clauses)
|
|
;
|
|
{ ArgVars = [X, Index] },
|
|
unify_proc__build_call("index", ArgVars, Goal),
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body(ArgVars, Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ term__context_init(Context) },
|
|
{ Clauses = [clause([], Body, Context)] }
|
|
).
|
|
|
|
:- pred unify_proc__generate_compare_clauses(hlds__type_body, var, var, var,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_compare_clauses(in, in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_compare_clauses(TypeBody, Res, H1, H2, Clauses) -->
|
|
( { TypeBody = du_type(Ctors, _, IsEnum), IsEnum = no } ->
|
|
unify_proc__generate_du_compare_clauses(Ctors, Res, H1, H2,
|
|
Clauses)
|
|
;
|
|
{ ArgVars = [Res, H1, H2] },
|
|
unify_proc__build_call("compare", ArgVars, Goal),
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body(ArgVars, Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ term__context_init(Context) },
|
|
{ Clauses = [clause([], Body, Context)] }
|
|
).
|
|
|
|
:- pred unify_proc__generate_term_to_type_clauses(hlds__type_body, var, var,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_term_to_type_clauses(in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_term_to_type_clauses(TypeBody, Term, X, Clauses) -->
|
|
( {TypeBody = du_type(Ctors, _, IsEnum), IsEnum = no } ->
|
|
unify_proc__generate_du_term_to_type_clauses(Ctors, Term, X,
|
|
Clauses)
|
|
;
|
|
|
|
{ ArgVars = [Term, X] },
|
|
unify_proc__build_call("term_to_type", ArgVars, Goal),
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body(ArgVars, Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ term__context_init(Context) },
|
|
{ Clauses = [clause([], Body, Context)] }
|
|
).
|
|
|
|
:- pred unify_proc__generate_type_to_term_clauses(hlds__type_body, var, var,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_type_to_term_clauses(in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_type_to_term_clauses(TypeBody, X, Term, Clauses) -->
|
|
( { TypeBody = du_type(Ctors, _, IsEnum), IsEnum = no } ->
|
|
unify_proc__generate_du_type_to_term_clauses(Ctors, X, Term,
|
|
Clauses)
|
|
;
|
|
{ ArgVars = [X, Term] },
|
|
unify_proc__build_call("type_to_term", ArgVars, Goal),
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body(ArgVars, Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ term__context_init(Context) },
|
|
{ Clauses = [clause([], Body, Context)] }
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
/*
|
|
For a type such as
|
|
|
|
type t(X) ---> a ; b(int) ; c(X); d(int, X, t)
|
|
|
|
we want to generate code
|
|
|
|
eq(H1, H2) :-
|
|
(
|
|
H1 = a,
|
|
H2 = a
|
|
;
|
|
H1 = b(X1),
|
|
H2 = b(X2),
|
|
X1 = X2,
|
|
;
|
|
H1 = c(Y1),
|
|
H2 = c(Y2),
|
|
Y1 = Y2,
|
|
;
|
|
H1 = d(A1, B1, C1),
|
|
H2 = c(A2, B2, C2),
|
|
A1 = A2,
|
|
B1 = B2,
|
|
C1 = C2
|
|
).
|
|
*/
|
|
|
|
:- pred unify_proc__generate_du_unify_clauses(list(constructor), var, var,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_unify_clauses(in, in, in, out, in, out) is det.
|
|
|
|
unify_proc__generate_du_unify_clauses([], _H1, _H2, []) --> [].
|
|
unify_proc__generate_du_unify_clauses([Ctor | Ctors], H1, H2,
|
|
[Clause | Clauses]) -->
|
|
{ Ctor = FunctorName - ArgTypes },
|
|
{ list__length(ArgTypes, FunctorArity) },
|
|
{ FunctorConsId = cons(FunctorName, FunctorArity) },
|
|
{ term__context_init(Context) },
|
|
unify_proc__make_fresh_vars(ArgTypes, Vars1),
|
|
unify_proc__make_fresh_vars(ArgTypes, Vars2),
|
|
{ create_atomic_unification(
|
|
H1, functor(FunctorConsId, Vars1), Context, explicit, [],
|
|
UnifyH1_Goal) },
|
|
{ create_atomic_unification(
|
|
H2, functor(FunctorConsId, Vars2), Context, explicit, [],
|
|
UnifyH2_Goal) },
|
|
{ unify_proc__unify_var_lists(Vars1, Vars2, UnifyArgs_Goal) },
|
|
{ GoalList = [UnifyH1_Goal, UnifyH2_Goal | UnifyArgs_Goal] },
|
|
{ goal_info_init(GoalInfo) },
|
|
{ conj_list_to_goal(GoalList, GoalInfo, Goal) },
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body([H1, H2], Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ Clause = clause([], Body, Context) },
|
|
unify_proc__generate_du_unify_clauses(Ctors, H1, H2, Clauses).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
/*
|
|
For a type such as
|
|
|
|
:- type foo ---> f ; g(a, b, c) ; h(foo).
|
|
|
|
we want to generate code
|
|
|
|
index(X, Index) :-
|
|
(
|
|
X = f,
|
|
Index = 0
|
|
;
|
|
X = g(_, _, _),
|
|
Index = 1
|
|
;
|
|
X = h(_),
|
|
Index = 2
|
|
).
|
|
*/
|
|
|
|
:- pred unify_proc__generate_du_index_clauses(list(constructor), var, var, int,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_index_clauses(in, in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_du_index_clauses([], _X, _Index, _N, []) --> [].
|
|
unify_proc__generate_du_index_clauses([Ctor | Ctors], X, Index, N,
|
|
[Clause | Clauses]) -->
|
|
{ Ctor = FunctorName - ArgTypes },
|
|
{ list__length(ArgTypes, FunctorArity) },
|
|
{ FunctorConsId = cons(FunctorName, FunctorArity) },
|
|
{ term__context_init(Context) },
|
|
unify_proc__make_fresh_vars(ArgTypes, ArgVars),
|
|
{ create_atomic_unification(
|
|
X, functor(FunctorConsId, ArgVars), Context, explicit, [],
|
|
UnifyX_Goal) },
|
|
{ create_atomic_unification(
|
|
Index, functor(int_const(N), []), Context, explicit, [],
|
|
UnifyIndex_Goal) },
|
|
{ GoalList = [UnifyX_Goal, UnifyIndex_Goal] },
|
|
{ goal_info_init(GoalInfo) },
|
|
{ conj_list_to_goal(GoalList, GoalInfo, Goal) },
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body([X, Index], Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ Clause = clause([], Body, Context) },
|
|
{ N1 is N + 1 },
|
|
unify_proc__generate_du_index_clauses(Ctors, X, Index, N1, Clauses).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
/* For a type such as
|
|
|
|
:- type foo ---> f ; g(a) ; h(b, foo).
|
|
|
|
we want to generate code
|
|
|
|
compare(Res, X, Y) :-
|
|
index(X, X_Index), % Call_X_Index
|
|
index(Y, Y_Index), % Call_Y_Index
|
|
( X_Index < Y_Index -> % Call_Less_Than
|
|
Res = (<) % Return_Less_Than
|
|
; X_Index > Y_Index -> % Call_Greater_Than
|
|
Res = (>) % Return_Greater_Than
|
|
;
|
|
% This disjunction is generated by
|
|
% unify_proc__generate_compare_cases, below.
|
|
(
|
|
X = f, Y = f,
|
|
R = (=)
|
|
;
|
|
X = g(X1), Y = g(Y1),
|
|
compare(R, X1, Y1)
|
|
;
|
|
X = h(X1, X2), Y = h(Y1, Y2),
|
|
( compare(R1, X1, Y1), R1 \= (=) ->
|
|
R = R1
|
|
;
|
|
compare(R, X2, Y2)
|
|
)
|
|
)
|
|
->
|
|
Res = R % Return_R
|
|
;
|
|
compare_error % Abort
|
|
).
|
|
*/
|
|
|
|
:- pred unify_proc__generate_du_compare_clauses(
|
|
list(constructor), var, var, var,
|
|
list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_compare_clauses(in, in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_du_compare_clauses(Ctors, Res, X, Y, [Clause]) -->
|
|
( { Ctors = [SingleCtor] } ->
|
|
unify_proc__generate_compare_case(SingleCtor, Res, X, Y, Goal)
|
|
;
|
|
unify_proc__generate_du_compare_clauses_2(Ctors, Res, X, Y,
|
|
Goal)
|
|
),
|
|
{ ArgVars = [Res, X, Y] },
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body(ArgVars, Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ term__context_init(Context) },
|
|
{ Clause = clause([], Body, Context) }.
|
|
|
|
:- pred unify_proc__generate_du_compare_clauses_2(
|
|
list(constructor), var, var, var,
|
|
hlds__goal, unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_compare_clauses_2(in, in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_du_compare_clauses_2(Ctors, Res, X, Y, Goal) -->
|
|
{ term__context_init(Context) },
|
|
{ construct_type(unqualified("int") - 0, [], IntType) },
|
|
{ construct_type(qualified("mercury_builtin", "comparison_result") - 0,
|
|
[], ResType) },
|
|
unify_proc__info_new_var(IntType, X_Index),
|
|
unify_proc__info_new_var(IntType, Y_Index),
|
|
unify_proc__info_new_var(ResType, R),
|
|
|
|
{ goal_info_init(GoalInfo) },
|
|
|
|
unify_proc__build_call("index", [X, X_Index], Call_X_Index),
|
|
|
|
unify_proc__build_call("index", [Y, Y_Index], Call_Y_Index),
|
|
|
|
unify_proc__build_call("builtin_int_lt", [X_Index, Y_Index],
|
|
Call_Less_Than),
|
|
|
|
unify_proc__build_call("builtin_int_gt", [X_Index, Y_Index],
|
|
Call_Greater_Than),
|
|
|
|
{ create_atomic_unification(
|
|
Res, functor(cons(unqualified("<"), 0), []),
|
|
Context, explicit, [],
|
|
Return_Less_Than) },
|
|
|
|
{ create_atomic_unification(
|
|
Res, functor(cons(unqualified(">"), 0), []),
|
|
Context, explicit, [],
|
|
Return_Greater_Than) },
|
|
|
|
{ create_atomic_unification(Res, var(R), Context, explicit, [],
|
|
Return_R) },
|
|
|
|
unify_proc__generate_compare_cases(Ctors, R, X, Y, Cases),
|
|
{ map__init(Empty) },
|
|
{ CasesGoal = disj(Cases, Empty) - GoalInfo },
|
|
|
|
unify_proc__build_call("compare_error", [], Abort),
|
|
|
|
{ Goal = conj([
|
|
Call_X_Index,
|
|
Call_Y_Index,
|
|
if_then_else([], Call_Less_Than, Return_Less_Than,
|
|
if_then_else([], Call_Greater_Than, Return_Greater_Than,
|
|
if_then_else([], CasesGoal, Return_R, Abort, Empty
|
|
) - GoalInfo, Empty
|
|
) - GoalInfo, Empty
|
|
) - GoalInfo
|
|
]) - GoalInfo }.
|
|
|
|
/*
|
|
unify_proc__generate_compare_cases: for a type such as
|
|
|
|
:- type foo ---> f ; g(a) ; h(b, foo).
|
|
|
|
we want to generate code
|
|
(
|
|
X = f, % UnifyX_Goal
|
|
Y = f, % UnifyY_Goal
|
|
R = (=) % CompareArgs_Goal
|
|
;
|
|
X = g(X1),
|
|
Y = g(Y1),
|
|
compare(R, X1, Y1)
|
|
;
|
|
X = h(X1, X2),
|
|
Y = h(Y1, Y2),
|
|
( compare(R1, X1, Y1), R1 \= (=) ->
|
|
R = R1
|
|
;
|
|
compare(R, X2, Y2)
|
|
)
|
|
)
|
|
*/
|
|
|
|
:- pred unify_proc__generate_compare_cases(list(constructor), var, var, var,
|
|
list(hlds__goal), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_compare_cases(in, in, in, in, out, in, out) is det.
|
|
|
|
unify_proc__generate_compare_cases([], _R, _X, _Y, []) --> [].
|
|
unify_proc__generate_compare_cases([Ctor | Ctors], R, X, Y, [Case | Cases]) -->
|
|
unify_proc__generate_compare_case(Ctor, R, X, Y, Case),
|
|
unify_proc__generate_compare_cases(Ctors, R, X, Y, Cases).
|
|
|
|
:- pred unify_proc__generate_compare_case(constructor, var, var, var,
|
|
hlds__goal, unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_compare_case(in, in, in, in, out, in, out) is det.
|
|
|
|
unify_proc__generate_compare_case(Ctor, R, X, Y, Case) -->
|
|
{ Ctor = FunctorName - ArgTypes },
|
|
{ list__length(ArgTypes, FunctorArity) },
|
|
{ FunctorConsId = cons(FunctorName, FunctorArity) },
|
|
{ term__context_init(Context) },
|
|
unify_proc__make_fresh_vars(ArgTypes, Vars1),
|
|
unify_proc__make_fresh_vars(ArgTypes, Vars2),
|
|
{ create_atomic_unification(
|
|
X, functor(FunctorConsId, Vars1), Context, explicit, [],
|
|
UnifyX_Goal) },
|
|
{ create_atomic_unification(
|
|
Y, functor(FunctorConsId, Vars2), Context, explicit, [],
|
|
UnifyY_Goal) },
|
|
unify_proc__compare_args(Vars1, Vars2, R, CompareArgs_Goal),
|
|
{ GoalList = [UnifyX_Goal, UnifyY_Goal, CompareArgs_Goal] },
|
|
{ goal_info_init(GoalInfo) },
|
|
{ conj_list_to_goal(GoalList, GoalInfo, Case) }.
|
|
|
|
/* unify_proc__compare_args: for a constructor such as
|
|
|
|
h(list(int), foo, string)
|
|
|
|
we want to generate code
|
|
|
|
(
|
|
compare(R1, X1, Y1), % Do_Comparison
|
|
R1 \= (=) % Check_Not_Equal
|
|
->
|
|
R = R1 % Return_R1
|
|
;
|
|
compare(R2, X2, Y2),
|
|
R2 \= (=)
|
|
->
|
|
R = R2
|
|
;
|
|
compare(R, X3, Y3) % Return_Comparison
|
|
)
|
|
|
|
For a constructor with no arguments, we want to generate code
|
|
|
|
R = (=) % Return_Equal
|
|
|
|
*/
|
|
|
|
:- pred unify_proc__compare_args(list(var), list(var), var, hlds__goal,
|
|
unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__compare_args(in, in, in, out, in, out) is det.
|
|
|
|
unify_proc__compare_args([], [], R, Return_Equal) -->
|
|
{ term__context_init(Context) },
|
|
{ create_atomic_unification(
|
|
R, functor(cons(unqualified("="), 0), []),
|
|
Context, explicit, [],
|
|
Return_Equal) }.
|
|
unify_proc__compare_args([X|Xs], [Y|Ys], R, Goal) -->
|
|
{ goal_info_init(GoalInfo) },
|
|
( { Xs = [], Ys = [] } ->
|
|
unify_proc__build_call("compare", [R, X, Y], Goal)
|
|
;
|
|
{ term__context_init(Context) },
|
|
{ construct_type(
|
|
qualified("mercury_builtin", "comparison_result") - 0,
|
|
[], ResType) },
|
|
unify_proc__info_new_var(ResType, R1),
|
|
|
|
unify_proc__build_call("compare", [R1, X, Y], Do_Comparison),
|
|
|
|
{ create_atomic_unification(
|
|
R1, functor(cons(unqualified("="), 0), []),
|
|
Context, explicit, [],
|
|
Check_Equal) },
|
|
{ Check_Not_Equal = not(Check_Equal) - GoalInfo },
|
|
|
|
{ create_atomic_unification(
|
|
R, var(R1), Context, explicit, [], Return_R1) },
|
|
{ Condition = conj([Do_Comparison, Check_Not_Equal])
|
|
- GoalInfo },
|
|
{ map__init(Empty) },
|
|
{ Goal = if_then_else([], Condition, Return_R1, ElseCase, Empty)
|
|
- GoalInfo},
|
|
unify_proc__compare_args(Xs, Ys, R, ElseCase)
|
|
).
|
|
unify_proc__compare_args([], [_|_], _, _) -->
|
|
{ error("unify_proc__compare_args: length mismatch") }.
|
|
unify_proc__compare_args([_|_], [], _, _) -->
|
|
{ error("unify_proc__compare_args: length mismatch") }.
|
|
|
|
/*
|
|
For a type such as
|
|
type tree(T1, T2) --->
|
|
empty
|
|
; tree(T1, T2, tree(T1, T2), tree(T1, T2))
|
|
|
|
we want to generate code
|
|
|
|
term_to_type(Term, X) :-
|
|
(
|
|
Term = term__functor(term__atom("empty"), [], _),
|
|
X = empty.
|
|
;
|
|
Term = term__functor(term__atom("tree"),
|
|
[KeyTerm, ValTerm, LTreeTerm, RTreeTerm], _),
|
|
term_to_type(KeyTerm, Key),
|
|
term_to_type(ValTerm, Val),
|
|
term_to_type(LTreeTerm, L),
|
|
term_to_type(RTreeTerm, R),
|
|
X = tree(Key, Val, L, R)
|
|
).
|
|
|
|
The complex unification of Term to term__functor is achieved
|
|
by atomic unifications. The code that achieves this is a
|
|
specialized inline version of unravel_unification from
|
|
make_hlds.m. The actual code generated for the above type is:
|
|
|
|
term_to_type(Term, X) :-
|
|
Term = term__functor(V1, V2, V3),
|
|
V1 = term__atom(V4),
|
|
(
|
|
V4 = "empty",
|
|
V2 = [],
|
|
X = empty
|
|
;
|
|
V4 = "tree",
|
|
V2 = [KeyTerm | V5],
|
|
V5 = [ValTerm | V6],
|
|
V6 = [LTreeTerm | V7],
|
|
V7 = [RTreeTerm | V8],
|
|
V8 = [],
|
|
term_to_type(KeyTerm, Key),
|
|
term_to_type(ValTerm, Val),
|
|
term_to_type(LTreeTerm, L),
|
|
term_to_type(RTreeTerm, R),
|
|
X = tree(Key, Val, L, R)
|
|
).
|
|
*/
|
|
|
|
:- pred unify_proc__generate_du_term_to_type_clauses(list(constructor),
|
|
var, var, list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_term_to_type_clauses(in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_du_term_to_type_clauses([], _Term, _X, []) --> [].
|
|
unify_proc__generate_du_term_to_type_clauses([Ctor | Ctors], Term, X,
|
|
[Clause]) -->
|
|
{ term__context_init(Context) },
|
|
|
|
% Make V1, V2, V3, V4
|
|
unify_proc__info_new_var(ConstType, V1),
|
|
unify_proc__info_new_var(TermListType, V2),
|
|
unify_proc__info_new_var(ContextType, V3),
|
|
unify_proc__info_new_var(StringType, V4),
|
|
|
|
% Make Term = term__functor(V1, V2, V3)
|
|
{ create_atomic_unification(
|
|
Term,
|
|
functor(cons(unqualified("term__functor"), 3), [ V1, V2, V3 ]),
|
|
Context, explicit, [],
|
|
TermGoal) },
|
|
|
|
% Make V1 = term__atom(V4),
|
|
{ create_atomic_unification(
|
|
V1,
|
|
functor(cons(unqualified("term__atom"), 1), [ V4 ]),
|
|
Context, explicit, [],
|
|
AtomGoal) },
|
|
|
|
{ construct_type(qualified("mercury_builtin", "const") - 0,
|
|
[], ConstType) },
|
|
{ construct_type(qualified("mercury_builtin", "term") - 0,
|
|
[], TermType) },
|
|
{ construct_type(qualified("mercury_builtin", "list") - 1,
|
|
[TermType], TermListType) },
|
|
{ construct_type(qualified("mercury_builtin", "term__context") - 0,
|
|
[], ContextType) },
|
|
{ construct_type(unqualified("string") - 0, [], StringType) },
|
|
|
|
% Make disjunctions for the difference functors of the type
|
|
unify_proc__generate_du_term_to_type_disjunctions([Ctor | Ctors],
|
|
V2, V4, X,
|
|
ConstType, TermType, TermListType, ContextType, StringType,
|
|
ListDisjunctiveGoals),
|
|
|
|
% Combine goals into a clause
|
|
{ goal_info_init(GoalInfo) },
|
|
{ disj_list_to_goal(ListDisjunctiveGoals, GoalInfo, DisjunctiveGoal) },
|
|
{ conj_list_to_goal([TermGoal, AtomGoal, DisjunctiveGoal], GoalInfo,
|
|
Goal) },
|
|
unify_proc__info_get_varset(Varset0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body([Term, X], Goal,
|
|
Varset0, Types0, Body, Varset, Types, _Warnings) },
|
|
unify_proc__info_set_varset(Varset),
|
|
unify_proc__info_set_types(Types),
|
|
{ Clause = clause([], Body, Context) }.
|
|
|
|
:- pred unify_proc__generate_du_term_to_type_disjunctions(
|
|
list(constructor), var, var, var, term, term, term, term, term,
|
|
list(hlds__goal),
|
|
unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_term_to_type_disjunctions(
|
|
in, in, in, in, in, in, in, in, in, out, in, out) is det.
|
|
|
|
unify_proc__generate_du_term_to_type_disjunctions([],_,_,_,_,_,_,_,_,[]) --> [].
|
|
unify_proc__generate_du_term_to_type_disjunctions([Ctor | Ctors], V2, V4, X,
|
|
ConstType, TermType, TermListType, ContextType, StringType,
|
|
[Goal | Goals]) -->
|
|
|
|
{ Ctor = FunctorName - ArgTypes },
|
|
{ list__length(ArgTypes, FunctorArity) },
|
|
{ unqualify_name(FunctorName, UnqualifiedFunctorName) },
|
|
{ FunctorAtom = cons(FunctorName, FunctorArity) },
|
|
{ FunctorString = string_const(UnqualifiedFunctorName) },
|
|
{ term__context_init(Context) },
|
|
|
|
% Make V4 = ...
|
|
{ create_atomic_unification(
|
|
V4,
|
|
functor(FunctorString, []),
|
|
Context, explicit, [],
|
|
FunctorGoal) },
|
|
|
|
% Make Key, Val, L, R
|
|
unify_proc__make_fresh_vars(ArgTypes, ArgVars),
|
|
|
|
% Make Vx = [...] and term_to_type(..., ...) recursive goals
|
|
unify_proc__generate_du_term_to_type_recursive(
|
|
ArgVars, V2, Context, TermType, TermListType,
|
|
TermGoals, Term_To_TypeGoals),
|
|
|
|
% Make X = ....
|
|
{ create_atomic_unification(
|
|
X,
|
|
functor(FunctorAtom, ArgVars),
|
|
Context, explicit, [],
|
|
XGoal) },
|
|
|
|
{ list__append(TermGoals, Term_To_TypeGoals, RecursiveGoals) },
|
|
{ goal_info_init(GoalInfo) },
|
|
{conj_list_to_goal([FunctorGoal,XGoal|RecursiveGoals], GoalInfo, Goal)},
|
|
|
|
unify_proc__generate_du_term_to_type_disjunctions(Ctors, V2, V4, X,
|
|
ConstType, TermType, TermListType, ContextType, StringType,
|
|
Goals).
|
|
|
|
:- pred unify_proc__generate_du_term_to_type_recursive(
|
|
list(var), var, term__context, type, type,
|
|
list(hlds__goal), list(hlds__goal), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_term_to_type_recursive(
|
|
in, in, in, in, in,
|
|
out, out, in, out) is det.
|
|
|
|
unify_proc__generate_du_term_to_type_recursive(
|
|
[], Var, Context, _TermType, _TermListType,
|
|
[ Goal ], []) -->
|
|
{ create_atomic_unification(
|
|
Var,
|
|
functor(cons(unqualified("[]"), 0), []),
|
|
Context, explicit, [],
|
|
Goal) }.
|
|
|
|
unify_proc__generate_du_term_to_type_recursive(
|
|
[ ArgVar | ArgVars ], Var, Context, TermType, TermListType,
|
|
[ TermGoal | TermGoals], [TermToTypeGoal | Term_To_TypeGoals ]) -->
|
|
unify_proc__info_new_var(TermType, TermVar),
|
|
unify_proc__info_new_var(TermListType, TermListVar),
|
|
{ create_atomic_unification(
|
|
Var,
|
|
functor(cons(unqualified("."), 2), [ TermVar, TermListVar ]),
|
|
Context, explicit, [],
|
|
TermGoal) },
|
|
unify_proc__build_call("term_to_type",[TermVar, ArgVar],TermToTypeGoal),
|
|
unify_proc__generate_du_term_to_type_recursive(
|
|
ArgVars, TermListVar, Context, TermType, TermListType,
|
|
TermGoals, Term_To_TypeGoals).
|
|
|
|
/*
|
|
For a type such as
|
|
type tree(T1, T2) --->
|
|
empty
|
|
; tree(T1, T2, tree(T1, T2), tree(T1, T2))
|
|
|
|
we want to generate code
|
|
|
|
type_to_term(X, Term) :-
|
|
(
|
|
X = empty,
|
|
term__context_init(Context),
|
|
Term = term__functor(term__atom("empty"), [], Context)
|
|
;
|
|
X = tree(Key, Val, L, R),
|
|
type_to_term(Key, KeyTerm),
|
|
type_to_term(Val, VeyTerm),
|
|
type_to_term(L, LTreeTerm),
|
|
type_to_term(R, RTreeTerm),
|
|
term__context_init(Context),
|
|
Term = term__functor(term__atom("tree"),
|
|
[KeyTerm, ValTerm, LTreeTerm, RTreeTerm], Context)
|
|
).
|
|
|
|
The complex unification of Term to term__functor is achieved
|
|
by atomic unifications. The code that achieves this is a
|
|
specialized inline version of unravel_unification from
|
|
make_hlds.m. The actual code generated for the above type is:
|
|
|
|
type_to_term(X, Term) :-
|
|
(
|
|
X = empty,
|
|
V1 = term__atom(V4),
|
|
V4 = "empty",
|
|
V2 = [],
|
|
term__context_init(V3),
|
|
Term = term__functor(V1, V2, V3)
|
|
;
|
|
X = tree(Key, Val, L, R),
|
|
type_to_term(Key, KeyTerm),
|
|
type_to_term(Val, ValTerm),
|
|
type_to_term(L, LTreeTerm),
|
|
type_to_term(R, RTreeTerm),
|
|
V2 = [KeyTerm | V5],
|
|
V5 = [ValTerm | V6],
|
|
V6 = [LTreeTerm | V7],
|
|
V7 = [RTreeTerm | V8],
|
|
V8 = [],
|
|
V1 = term__atom(V4),
|
|
V4 = "tree",
|
|
term__context_init(V3),
|
|
Term = term__functor(V1, V2, V3).
|
|
).
|
|
*/
|
|
|
|
:- pred unify_proc__generate_du_type_to_term_clauses(list(constructor),
|
|
var, var, list(clause), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_type_to_term_clauses(in, in, in, out, in, out)
|
|
is det.
|
|
|
|
unify_proc__generate_du_type_to_term_clauses([], _X, _Term, []) --> [].
|
|
unify_proc__generate_du_type_to_term_clauses([Ctor | Ctors], X, Term,
|
|
[Clause | Clauses]) -->
|
|
{ Ctor = FunctorName - ArgTypes },
|
|
{ unqualify_name(FunctorName, UnqualifiedFunctorName) },
|
|
{ list__length(ArgTypes, FunctorArity) },
|
|
{ FunctorAtom = cons(FunctorName, FunctorArity) },
|
|
{ FunctorString = string_const(UnqualifiedFunctorName) },
|
|
{ term__context_init(Context) },
|
|
|
|
{ construct_type(qualified("mercury_builtin", "const") - 0,
|
|
[], ConstType) },
|
|
{ construct_type(qualified("mercury_builtin", "term") - 0,
|
|
[], TermType) },
|
|
{ construct_type(qualified("mercury_builtin", "list") - 0,
|
|
[TermType], TermListType) },
|
|
{ construct_type(qualified("mercury_builtin", "term__context") - 0,
|
|
[], ContextType) },
|
|
{ construct_type(unqualified("string") - 0, [], StringType) },
|
|
|
|
% Make Key, Val, L, R
|
|
unify_proc__make_fresh_vars(ArgTypes, ArgVars),
|
|
|
|
% Make X = ....
|
|
{ create_atomic_unification(
|
|
X,
|
|
functor(FunctorAtom, ArgVars),
|
|
Context, explicit, [],
|
|
XGoal) },
|
|
|
|
% Make V2
|
|
unify_proc__info_new_var(TermListType, V2),
|
|
|
|
% Make type_to_term(..., ...) and Vx = [...] recursive goals
|
|
unify_proc__generate_du_type_to_term_recursive_clauses(
|
|
ArgVars, V2, Context, TermType, TermListType,
|
|
RecursiveGoals),
|
|
|
|
% Make V1, V4
|
|
unify_proc__info_new_var(ConstType, V1),
|
|
unify_proc__info_new_var(StringType, V4),
|
|
|
|
% Make V1 = term__atom(V4),
|
|
{ create_atomic_unification(
|
|
V1,
|
|
functor(cons(unqualified("term__atom"), 1), [ V4 ]),
|
|
Context, explicit, [],
|
|
AtomGoal) },
|
|
|
|
% Make V4 = ...
|
|
{ create_atomic_unification(
|
|
V4,
|
|
functor(FunctorString, []),
|
|
Context, explicit, [],
|
|
FunctorGoal) },
|
|
|
|
% Make V3
|
|
unify_proc__info_new_var(ContextType, V3),
|
|
|
|
% Make term__context(V3)
|
|
% unify_proc__build_call("term__context_init", [V3], ContextGoal),
|
|
% --- From here ---
|
|
unify_proc__info_new_var(StringType, ContextString),
|
|
{ construct_type(unqualified("int") - 0, [], IntType) },
|
|
unify_proc__info_new_var(IntType, ContextInt),
|
|
{ create_atomic_unification(
|
|
V3,
|
|
functor(cons(unqualified("term__context"), 2),
|
|
[ContextString,ContextInt]),
|
|
Context, explicit, [],
|
|
ContextGoal) },
|
|
{ create_atomic_unification(
|
|
ContextString,
|
|
functor(string_const(""), []),
|
|
Context, explicit, [],
|
|
ContextGoalString) },
|
|
{ create_atomic_unification(
|
|
ContextInt,
|
|
functor(int_const(0), []),
|
|
Context, explicit, [],
|
|
ContextGoalInt) },
|
|
% --- To here ---
|
|
|
|
% Make Term = term__functor(V1, V2, V3)
|
|
{ create_atomic_unification(
|
|
Term,
|
|
functor(cons(unqualified("term__functor"), 3), [ V1, V2, V3 ]),
|
|
Context, explicit, [],
|
|
TermGoal) },
|
|
|
|
% Combine goals into a clause
|
|
{ goal_info_init(GoalInfo) },
|
|
{ conj_list_to_goal(
|
|
[ XGoal, AtomGoal, FunctorGoal, ContextGoal, TermGoal,
|
|
ContextGoalString, ContextGoalInt
|
|
|RecursiveGoals],
|
|
GoalInfo,
|
|
Goal) },
|
|
unify_proc__info_get_varset(VarSet0),
|
|
unify_proc__info_get_types(Types0),
|
|
{ implicitly_quantify_clause_body([Term, X], Goal, VarSet0, Types0,
|
|
Body, VarSet, Types, _Warnings) },
|
|
unify_proc__info_set_varset(VarSet),
|
|
unify_proc__info_set_types(Types),
|
|
{ Clause = clause([], Body, Context) },
|
|
|
|
% Make clauses for other functors of type
|
|
unify_proc__generate_du_type_to_term_clauses(Ctors, X, Term, Clauses).
|
|
|
|
:- pred unify_proc__generate_du_type_to_term_recursive_clauses(
|
|
list(var), var, term__context, type, type,
|
|
list(hlds__goal), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__generate_du_type_to_term_recursive_clauses(
|
|
in, in, in, in, in,
|
|
out, in, out) is det.
|
|
|
|
unify_proc__generate_du_type_to_term_recursive_clauses(
|
|
[], Var, Context, _TermType, _TermListType,
|
|
[ Goal ]) -->
|
|
{ create_atomic_unification(
|
|
Var,
|
|
functor(cons(unqualified("[]"), 0), []),
|
|
Context, explicit, [],
|
|
Goal) }.
|
|
|
|
unify_proc__generate_du_type_to_term_recursive_clauses(
|
|
[ ArgVar | ArgVars ], Var, Context, TermType, TermListType,
|
|
[ TypeToTermGoal, TermGoal | Goals ]) -->
|
|
unify_proc__info_new_var(TermType, TermVar),
|
|
unify_proc__info_new_var(TermListType, TermListVar),
|
|
unify_proc__build_call("type_to_term",[ArgVar, TermVar],TypeToTermGoal),
|
|
{ create_atomic_unification(
|
|
Var,
|
|
functor(cons(unqualified("."), 2), [ TermVar, TermListVar ]),
|
|
Context, explicit, [],
|
|
TermGoal) },
|
|
unify_proc__generate_du_type_to_term_recursive_clauses(
|
|
ArgVars, TermListVar, Context, TermType, TermListType, Goals).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred unify_proc__build_call(string, list(var), hlds__goal,
|
|
unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__build_call(in, in, out, in, out) is det.
|
|
|
|
unify_proc__build_call(Name, ArgVars, Goal) -->
|
|
unify_proc__info_get_module_info(ModuleInfo),
|
|
{ module_info_get_predicate_table(ModuleInfo, PredicateTable) },
|
|
{ list__length(ArgVars, Arity) },
|
|
{
|
|
predicate_table_search_pred_m_n_a(PredicateTable,
|
|
"mercury_builtin", Name, Arity, [PredId])
|
|
->
|
|
IndexPredId = PredId
|
|
;
|
|
string__append_list(["unify_proc__build_call: ",
|
|
"invalid/ambiguous pred `mercury_builtin:", Name, "'"],
|
|
ErrorMessage),
|
|
error(ErrorMessage)
|
|
},
|
|
{ ModeId = 0 },
|
|
% We cheat by not providing a context for the call.
|
|
% Since automatically generated procedures should not have errors,
|
|
% the absence of a context should not be a problem.
|
|
{ Call = call(IndexPredId, ModeId, ArgVars, not_builtin,
|
|
no, unqualified(Name)) },
|
|
{ goal_info_init(GoalInfo) },
|
|
{ Goal = Call - GoalInfo }.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred unify_proc__make_fresh_vars_from_types(list(type), list(var),
|
|
unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__make_fresh_vars_from_types(in, out, in, out) is det.
|
|
|
|
unify_proc__make_fresh_vars_from_types([], []) --> [].
|
|
unify_proc__make_fresh_vars_from_types([Type | Types], [Var | Vars]) -->
|
|
unify_proc__info_new_var(Type, Var),
|
|
unify_proc__make_fresh_vars_from_types(Types, Vars).
|
|
|
|
:- pred unify_proc__make_fresh_vars(list(constructor_arg), list(var),
|
|
unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__make_fresh_vars(in, out, in, out) is det.
|
|
|
|
unify_proc__make_fresh_vars([], []) --> [].
|
|
unify_proc__make_fresh_vars([_Name - Type | Args], [Var | Vars]) -->
|
|
unify_proc__info_new_var(Type, Var),
|
|
unify_proc__make_fresh_vars(Args, Vars).
|
|
|
|
:- pred unify_proc__unify_var_lists(list(var), list(var), list(hlds__goal)).
|
|
:- mode unify_proc__unify_var_lists(in, in, out) is det.
|
|
|
|
unify_proc__unify_var_lists([], [_|_], _) :-
|
|
error("unify_proc__unify_var_lists: length mismatch").
|
|
unify_proc__unify_var_lists([_|_], [], _) :-
|
|
error("unify_proc__unify_var_lists: length mismatch").
|
|
unify_proc__unify_var_lists([], [], []).
|
|
unify_proc__unify_var_lists([Var1 | Vars1], [Var2 | Vars2], [Goal | Goals]) :-
|
|
term__context_init(Context),
|
|
create_atomic_unification(Var1, var(Var2), Context, explicit, [],
|
|
Goal),
|
|
unify_proc__unify_var_lists(Vars1, Vars2, Goals).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% It's a pity that we don't have nested modules.
|
|
|
|
% :- begin_module unify_proc_info.
|
|
% :- interface.
|
|
|
|
:- type unify_proc_info.
|
|
|
|
:- pred unify_proc__info_init(module_info, unify_proc_info).
|
|
:- mode unify_proc__info_init(in, out) is det.
|
|
|
|
:- pred unify_proc__info_new_var(type, var, unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__info_new_var(in, out, in, out) is det.
|
|
|
|
:- pred unify_proc__info_extract(unify_proc_info, varset, map(var, type)).
|
|
:- mode unify_proc__info_extract(in, out, out) is det.
|
|
|
|
:- pred unify_proc__info_get_varset(varset, unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__info_get_varset(out, in, out) is det.
|
|
|
|
:- pred unify_proc__info_set_varset(varset, unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__info_set_varset(in, in, out) is det.
|
|
|
|
:- pred unify_proc__info_get_types(map(var, type), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__info_get_types(out, in, out) is det.
|
|
|
|
:- pred unify_proc__info_set_types(map(var, type), unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__info_set_types(in, in, out) is det.
|
|
|
|
:- pred unify_proc__info_get_module_info(module_info,
|
|
unify_proc_info, unify_proc_info).
|
|
:- mode unify_proc__info_get_module_info(out, in, out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% :- implementation
|
|
|
|
:- type unify_proc_info
|
|
---> unify_proc_info(
|
|
varset,
|
|
map(var, type),
|
|
module_info
|
|
).
|
|
|
|
unify_proc__info_init(ModuleInfo, VarTypeInfo) :-
|
|
varset__init(VarSet),
|
|
map__init(Types),
|
|
VarTypeInfo = unify_proc_info(VarSet, Types, ModuleInfo).
|
|
|
|
unify_proc__info_new_var(Type, Var,
|
|
unify_proc_info(VarSet0, Types0, ModuleInfo),
|
|
unify_proc_info(VarSet, Types, ModuleInfo)) :-
|
|
varset__new_var(VarSet0, Var, VarSet),
|
|
map__set(Types0, Var, Type, Types).
|
|
|
|
unify_proc__info_extract(unify_proc_info(VarSet, Types, _ModuleInfo),
|
|
VarSet, Types).
|
|
|
|
unify_proc__info_get_varset(VarSet, ProcInfo, ProcInfo) :-
|
|
ProcInfo = unify_proc_info(VarSet, _Types, _ModuleInfo).
|
|
|
|
unify_proc__info_set_varset(VarSet, unify_proc_info(_VarSet, Types, ModuleInfo),
|
|
unify_proc_info(VarSet, Types, ModuleInfo)).
|
|
|
|
unify_proc__info_get_types(Types, ProcInfo, ProcInfo) :-
|
|
ProcInfo = unify_proc_info(_VarSet, Types, _ModuleInfo).
|
|
|
|
unify_proc__info_set_types(Types, unify_proc_info(VarSet, _Types, ModuleInfo),
|
|
unify_proc_info(VarSet, Types, ModuleInfo)).
|
|
|
|
unify_proc__info_get_module_info(ModuleInfo, VarTypeInfo, VarTypeInfo) :-
|
|
VarTypeInfo = unify_proc_info(_VarSet, _Types, ModuleInfo).
|
|
|
|
% :- end_module unify_proc_info.
|
|
|
|
%-----------------------------------------------------------------------------%
|