[m-rev.] for review: support nondet code in Erlang backend
Peter Wang
wangp at students.csse.unimelb.edu.au
Thu May 17 11:59:49 AEST 2007
Estimated hours taken: 25
Branches: main
Add support for nondet code in the Erlang backend. Nondet procedures are
supplied a success continuation as an extra argument, which is called for each
solution.
compiler/elds.m:
Extend the ELDS with calls to Erlang builtins, and `try' and `throw'
statements. These are used to implement commits.
Add some comments.
compiler/elds_to_erlang.m:
Handle additions to the ELDS (builtins, try, throw).
When writing `-export' annotations in .erl files, take into account
that nondet procedures need an extra argument.
Print the module name as an atom so it is quoted if necessary.
Don't output `begin', `end' keywords in the generated code unless
strictly necessary.
Other cosmetic improvements to the generated code.
compiler/erl_call_gen.m:
Handle plain and higher-order calls to nondet procedures.
compiler/erl_code_gen.m:
Support nondet code and commits.
Improve the generated code for switches. Previously we simply
duplicated the success expression (the code that must be evaluated
after the switch succeeds) directly into each branch of the switch.
This leads to exponentially large output if switches follow one another.
We avoid that by estimating the "size" of the success expression, and
storing that once in a closure if it is too big. Then each branch of
the case statement only calls the closure on success.
compiler/erl_code_util.m:
Replace `erl_gen_info_new_var' by `erl_gen_info_new_named_var'. The
generated code is easier to read if introduced variables are named.
Add `erl_expr_size', used to estimate the size of an ELDS expression.
Conform to additions to the ELDS.
compiler/erl_unify_gen.m:
When creating closure expressions, take into account the extra argument
for nondet procedures.
Conform to some changes from above.
Index: compiler/elds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/elds.m,v
retrieving revision 1.1
diff -u -r1.1 elds.m
--- compiler/elds.m 15 May 2007 02:38:20 -0000 1.1
+++ compiler/elds.m 17 May 2007 01:23:57 -0000
@@ -50,7 +50,6 @@
:- type elds_defn
---> elds_defn(
defn_proc_id :: pred_proc_id,
- defn_arity :: int,
defn_varset :: prog_varset,
defn_clause :: elds_clause
).
@@ -61,16 +60,70 @@
clause_expr :: elds_expr
).
+ % An Erlang expression.
+ %
:- type elds_expr
+
+ % begin Expr1, Expr2, ... end
+ %
---> elds_block(list(elds_expr))
+
+ % A term.
+ %
; elds_term(elds_term)
- ; elds_eq(elds_expr, elds_expr) % `='
+
+ % Expr = Expr
+ %
+ ; elds_eq(elds_expr, elds_expr)
+
+ % A unary or binary operator expression.
+ %
; elds_unop(elds_unop, elds_expr)
; elds_binop(elds_binop, elds_expr, elds_expr)
- ; elds_call(pred_proc_id, list(elds_expr)) % input args
- ; elds_call_ho(elds_expr, list(elds_expr)) % input args
+
+ % A normal call.
+ % proc(Expr, ...)
+ %
+ ; elds_call(pred_proc_id, list(elds_expr))
+
+ % A higher order call.
+ % Proc(Expr, ...)
+ %
+ ; elds_call_ho(elds_expr, list(elds_expr))
+
+ % A call to a Erlang builtin.
+ % builtin(Expr, ...)
+ %
+ ; elds_call_builtin(string, list(elds_expr))
+
+ % fun(Args, ...) -> Expr end
+ % (We only use single clause functions.)
+ %
; elds_fun(elds_clause)
- ; elds_case_expr(elds_expr, list(elds_case)).
+
+ % case Expr of
+ % Pattern -> Expr,
+ % ...
+ % end
+ %
+ ; elds_case_expr(elds_expr, list(elds_case))
+
+ % try Expr of
+ % Pattern -> Expr,
+ % ...
+ % catch
+ % Pattern:Pattern -> Expr
+ % end
+ %
+ ; elds_try(
+ try_expr :: elds_expr,
+ try_cases :: list(elds_case),
+ try_catch :: elds_catch
+ )
+
+ % throw(Expr)
+ %
+ ; elds_throw(elds_expr).
:- type elds_term
---> elds_char(char)
@@ -96,6 +149,9 @@
:- type elds_case
---> elds_case(elds_term, elds_expr).
+:- type elds_catch
+ ---> elds_catch(elds_term, elds_term, elds_expr).
+
:- type elds_unop
---> plus
; minus
@@ -138,8 +194,14 @@
:- func elds_true = elds_term.
:- func elds_false = elds_term.
:- func elds_fail = elds_term.
+:- func elds_throw_atom = elds_term.
:- func elds_empty_tuple = elds_term.
+ % We implement commits by throwing Erlang exceptions with this
+ % distinguishing atom as the first element of the tuple.
+ %
+:- func elds_commit_marker = elds_expr.
+
:- func term_from_var(prog_var) = elds_term.
:- func terms_from_vars(prog_vars) = list(elds_term).
:- func expr_from_var(prog_var) = elds_expr.
@@ -169,6 +231,12 @@
%
:- func expr_or_void(maybe(elds_expr)) = elds_expr.
+ % det_expr(MaybeExpr)
+ %
+ % Return Expr if MaybeExpr is `yes(Expr)', otherwise abort.
+ %
+:- func det_expr(maybe(elds_expr)) = elds_expr.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -181,8 +249,11 @@
elds_true = elds_atom_raw("true").
elds_false = elds_atom_raw("false").
elds_fail = elds_atom_raw("fail").
+elds_throw_atom = elds_atom_raw("throw").
elds_empty_tuple = elds_tuple([]).
+elds_commit_marker = elds_term(elds_atom_raw("MERCURY_COMMIT")).
+
term_from_var(Var) = elds_var(Var).
terms_from_vars(Vars) = list.map(term_from_var, Vars).
@@ -220,6 +291,10 @@
expr_or_void(yes(Expr)) = Expr.
expr_or_void(no) = elds_term(elds_atom_raw("void")).
+det_expr(yes(Expr)) = Expr.
+det_expr(no) = _ :-
+ unexpected(this_file, "det_expr: no expression").
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/elds_to_erlang.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/elds_to_erlang.m,v
retrieving revision 1.1
diff -u -r1.1 elds_to_erlang.m
--- compiler/elds_to_erlang.m 15 May 2007 02:38:20 -0000 1.1
+++ compiler/elds_to_erlang.m 17 May 2007 01:23:57 -0000
@@ -107,12 +107,14 @@
list.foldl(output_defn(ModuleInfo), Defns, !IO).
+%-----------------------------------------------------------------------------%
+
:- pred output_exports(module_info::in, list(elds_defn)::in, bool::in,
io::di, io::uo) is det.
output_exports(_ModuleInfo, [], _NeedComma, !IO).
output_exports(ModuleInfo, [Defn | Defns], NeedComma, !IO) :-
- Defn = elds_defn(PredProcId, Arity, _, _),
+ Defn = elds_defn(PredProcId, _, Clause),
PredProcId = proc(PredId, _ProcId),
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_get_import_status(PredInfo, ImportStatus),
@@ -128,15 +130,21 @@
nl_indent_line(1, !IO),
output_pred_proc_id(ModuleInfo, PredProcId, !IO),
io.write_char('/', !IO),
- io.write_int(Arity, !IO),
+ io.write_int(elds_clause_arity(Clause), !IO),
output_exports(ModuleInfo, Defns, yes, !IO)
;
IsExported = no,
output_exports(ModuleInfo, Defns, NeedComma, !IO)
).
+:- func elds_clause_arity(elds_clause) = arity.
+
+elds_clause_arity(elds_clause(Args, _Expr)) = list.length(Args).
+
+%-----------------------------------------------------------------------------%
+
output_defn(ModuleInfo, Defn, !IO) :-
- Defn = elds_defn(PredProcId, _Arity, VarSet, Clause),
+ Defn = elds_defn(PredProcId, VarSet, Clause),
io.nl(!IO),
output_pred_proc_id(ModuleInfo, PredProcId, !IO),
Indent = 0,
@@ -152,7 +160,8 @@
io.write_list(Pattern, ", ",
output_term(ModuleInfo, VarSet, Indent), !IO),
io.write_string(") -> ", !IO),
- output_expr(ModuleInfo, VarSet, Indent + 1, Expr, !IO).
+ nl_indent_line(Indent + 1, !IO),
+ output_block_expr(ModuleInfo, VarSet, Indent + 1, Expr, !IO).
%-----------------------------------------------------------------------------%
%
@@ -181,13 +190,22 @@
io.write_list(Exprs, ", ",
output_expr(ModuleInfo, VarSet, Indent), !IO).
+:- pred output_block_expr(module_info::in, prog_varset::in, indent::in,
+ elds_expr::in, io::di, io::uo) is det.
+
+output_block_expr(ModuleInfo, VarSet, Indent, Expr, !IO) :-
+ ( Expr = elds_block(Exprs) ->
+ output_exprs_with_nl(ModuleInfo, VarSet, Indent, Exprs, !IO)
+ ;
+ output_expr(ModuleInfo, VarSet, Indent, Expr, !IO)
+ ).
+
:- pred output_expr(module_info::in, prog_varset::in, indent::in,
elds_expr::in, io::di, io::uo) is det.
output_expr(ModuleInfo, VarSet, Indent, Expr, !IO) :-
(
Expr = elds_block(Exprs),
- nl_indent_line(Indent, !IO),
io.write_string("(begin", !IO),
nl_indent_line(Indent + 1, !IO),
output_exprs_with_nl(ModuleInfo, VarSet, Indent + 1, Exprs, !IO),
@@ -211,33 +229,61 @@
output_elds_binop(Binop, !IO),
output_expr(ModuleInfo, VarSet, Indent, ExprB, !IO)
;
- Expr = elds_call(PredProcId, Args),
- output_pred_proc_id(ModuleInfo, PredProcId, !IO),
- io.write_string("(", !IO),
- output_exprs(ModuleInfo, VarSet, Indent, Args, !IO),
- io.write_string(") ", !IO)
- ;
- Expr = elds_call_ho(Closure, Args),
- output_expr(ModuleInfo, VarSet, Indent, Closure, !IO),
+ (
+ Expr = elds_call(PredProcId, Args),
+ output_pred_proc_id(ModuleInfo, PredProcId, !IO)
+ ;
+ Expr = elds_call_ho(Closure, Args),
+ output_expr(ModuleInfo, VarSet, Indent, Closure, !IO)
+ ;
+ Expr = elds_call_builtin(FunName, Args),
+ output_atom(FunName, !IO)
+ ),
io.write_string("(", !IO),
output_exprs(ModuleInfo, VarSet, Indent, Args, !IO),
- io.write_string(") ", !IO)
+ io.write_string(")", !IO)
;
Expr = elds_fun(Clause),
- io.write_string("fun", !IO),
+ io.write_string("(fun", !IO),
output_clause(ModuleInfo, VarSet, Indent, Clause, !IO),
- io.write_string("end ", !IO)
+ nl_indent_line(Indent, !IO),
+ io.write_string("end)", !IO)
;
Expr = elds_case_expr(ExprA, Cases),
- io.write_string("(case ", !IO),
+ io.write_string("(case", !IO),
nl_indent_line(Indent + 1, !IO),
output_expr(ModuleInfo, VarSet, Indent + 1, ExprA, !IO),
nl_indent_line(Indent, !IO),
- io.write_string("of ", !IO),
- io.write_list(Cases, "; ",
+ io.write_string("of", !IO),
+ io.write_list(Cases, ";",
output_case(ModuleInfo, VarSet, Indent + 1), !IO),
nl_indent_line(Indent, !IO),
io.write_string("end)", !IO)
+ ;
+ Expr = elds_try(ExprA, Cases, Catch),
+ io.write_string("(try", !IO),
+ nl_indent_line(Indent + 1, !IO),
+ output_block_expr(ModuleInfo, VarSet, Indent + 1, ExprA, !IO),
+ (
+ Cases = []
+ ;
+ Cases = [_ | _],
+ nl_indent_line(Indent, !IO),
+ io.write_string("of", !IO),
+ io.write_list(Cases, ";",
+ output_case(ModuleInfo, VarSet, Indent + 1), !IO)
+ ),
+ nl_indent_line(Indent, !IO),
+ io.write_string("catch", !IO),
+ nl_indent_line(Indent + 1, !IO),
+ output_catch(ModuleInfo, VarSet, Indent + 1, Catch, !IO),
+ nl_indent_line(Indent, !IO),
+ io.write_string("end)", !IO)
+ ;
+ Expr = elds_throw(ExprA),
+ io.write_string("throw(", !IO),
+ output_expr(ModuleInfo, VarSet, Indent, ExprA, !IO),
+ io.write_string(")", !IO)
).
:- pred output_case(module_info::in, prog_varset::in, indent::in,
@@ -248,7 +294,19 @@
output_term(ModuleInfo, VarSet, Indent, Pattern, !IO),
io.write_string("->", !IO),
nl_indent_line(Indent + 1, !IO),
- output_expr(ModuleInfo, VarSet, Indent + 1, Expr, !IO).
+ output_block_expr(ModuleInfo, VarSet, Indent + 1, Expr, !IO).
+
+:- pred output_catch(module_info::in, prog_varset::in, indent::in,
+ elds_catch::in, io::di, io::uo) is det.
+
+output_catch(ModuleInfo, VarSet, Indent, Catch, !IO) :-
+ Catch = elds_catch(PatternA, PatternB, CatchExpr),
+ output_term(ModuleInfo, VarSet, Indent, PatternA, !IO),
+ io.write_char(':', !IO),
+ output_term(ModuleInfo, VarSet, Indent, PatternB, !IO),
+ io.write_string("->", !IO),
+ nl_indent_line(Indent + 1, !IO),
+ output_block_expr(ModuleInfo, VarSet, Indent + 1, CatchExpr, !IO).
%-----------------------------------------------------------------------------%
@@ -326,11 +384,11 @@
->
io.write_char('{', !IO),
output_exprs(ModuleInfo, VarSet, Indent, Args1, !IO),
- io.write_char('}', !IO)
+ io.write_string("} ", !IO)
;
io.write_char('{', !IO),
output_exprs(ModuleInfo, VarSet, Indent, Args, !IO),
- io.write_char('}', !IO)
+ io.write_string("} ", !IO)
).
:- func elds_tuple = elds_expr.
Index: compiler/erl_call_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_call_gen.m,v
retrieving revision 1.1
diff -u -r1.1 erl_call_gen.m
--- compiler/erl_call_gen.m 15 May 2007 02:38:20 -0000 1.1
+++ compiler/erl_call_gen.m 17 May 2007 01:23:57 -0000
@@ -88,17 +88,19 @@
erl_gen_arg_list(ModuleInfo, ArgVars, CalleeTypes, ArgModes,
InputVars, OutputVars),
- CallExpr = elds_call(proc(PredId, ProcId), elds.exprs_from_vars(InputVars)),
-
+ PPId = proc(PredId, ProcId),
+ NormalCallExpr = elds_call(PPId, exprs_from_vars(InputVars)),
(
CodeModel = model_det,
- make_det_call(CallExpr, OutputVars, MaybeSuccessExpr, Statement)
+ make_det_call(NormalCallExpr, OutputVars, MaybeSuccessExpr, Statement)
;
CodeModel = model_semi,
- make_semidet_call(CallExpr, OutputVars, MaybeSuccessExpr, Statement)
+ SuccessExpr = det_expr(MaybeSuccessExpr),
+ make_semidet_call(NormalCallExpr, OutputVars, SuccessExpr, Statement)
;
CodeModel = model_non,
- sorry(this_file, "model_non code in Erlang backend")
+ SuccessExpr = det_expr(MaybeSuccessExpr),
+ make_nondet_call(PPId, InputVars, OutputVars, SuccessExpr, Statement)
).
:- pred make_det_call(elds_expr::in, prog_vars::in, maybe(elds_expr)::in,
@@ -131,34 +133,49 @@
)
).
-:- pred make_semidet_call(elds_expr::in, prog_vars::in, maybe(elds_expr)::in,
+:- pred make_semidet_call(elds_expr::in, prog_vars::in, elds_expr::in,
elds_expr::out) is det.
-make_semidet_call(CallExpr, OutputVars, MaybeSuccessExpr, Statement) :-
- (
- MaybeSuccessExpr = yes(SuccessExpr),
- UnpackTerm = elds_tuple(exprs_from_vars(OutputVars)),
- (if
- MaybeSuccessExpr = yes(elds_term(UnpackTerm))
- then
- % Avoid unnecessary unpacking.
- Statement = CallExpr
- else
- % case CallExpr of
- % {OutputVars, ...} -> SuccessExpr ;
- % _ -> fail
- % end
- %
- Statement = elds_case_expr(CallExpr, [TrueCase, FalseCase]),
- TrueCase = elds_case(UnpackTerm, SuccessExpr),
- FalseCase = elds_case(elds_anon_var, elds_term(elds_fail))
- )
- ;
- MaybeSuccessExpr = no,
- unexpected(this_file,
- "make_semidet_call: no success expression for semidet call")
+make_semidet_call(CallExpr, OutputVars, SuccessExpr, Statement) :-
+ UnpackTerm = elds_tuple(exprs_from_vars(OutputVars)),
+ (if
+ SuccessExpr = elds_term(UnpackTerm)
+ then
+ % Avoid unnecessary unpacking.
+ Statement = CallExpr
+ else
+ % case CallExpr of
+ % {OutputVars, ...} -> SuccessExpr ;
+ % _ -> fail
+ % end
+ %
+ Statement = elds_case_expr(CallExpr, [TrueCase, FalseCase]),
+ TrueCase = elds_case(UnpackTerm, SuccessExpr),
+ FalseCase = elds_case(elds_anon_var, elds_term(elds_fail))
).
+:- pred make_nondet_call(pred_proc_id::in, prog_vars::in, prog_vars::in,
+ elds_expr::in, elds_expr::out) is det.
+
+make_nondet_call(PredProcId, InputVars, OutputVars, SuccessCont0, Statement) :-
+ %
+ % Proc(InputVars, ...,
+ % fun(OutputVars, ...) ->
+ % SuccessCont0
+ % end)
+ %
+ (if
+ SuccessCont0 = elds_call_ho(SuccessCont1, exprs_from_vars(OutputVars))
+ then
+ % Avoid an unnecessary closure.
+ SuccessCont = SuccessCont1
+ else
+ SuccessCont = elds_fun(elds_clause(terms_from_vars(OutputVars),
+ SuccessCont0))
+ ),
+ Statement = elds_call(PredProcId,
+ exprs_from_vars(InputVars) ++ [SuccessCont]).
+
%-----------------------------------------------------------------------------%
%
% Code for generic calls
@@ -172,19 +189,31 @@
erl_variable_types(!.Info, ArgVars, ArgTypes),
erl_gen_arg_list(ModuleInfo, ArgVars, ArgTypes, Modes,
InputVars, OutputVars),
- CallExpr = elds_call_ho(elds.expr_from_var(ClosureVar),
- elds.exprs_from_vars(InputVars)),
+
+ ClosureVarExpr = expr_from_var(ClosureVar),
+ InputVarsExprs = exprs_from_vars(InputVars),
+ NormalCallExpr = elds_call_ho(ClosureVarExpr, InputVarsExprs),
determinism_to_code_model(Detism, CallCodeModel),
(
CallCodeModel = model_det,
- make_det_call(CallExpr, OutputVars, MaybeSuccessExpr, Statement)
+ make_det_call(NormalCallExpr, OutputVars, MaybeSuccessExpr, Statement)
;
CallCodeModel = model_semi,
- make_semidet_call(CallExpr, OutputVars, MaybeSuccessExpr, Statement)
+ SuccessExpr = det_expr(MaybeSuccessExpr),
+ make_semidet_call(NormalCallExpr, OutputVars, SuccessExpr, Statement)
;
CallCodeModel = model_non,
- sorry(this_file, "model_non code in Erlang backend")
+ %
+ % Proc(InputVars, ...,
+ % fun(OutputVars, ...) ->
+ % SuccessCont0
+ % end)
+ %
+ SuccessCont = elds_fun(elds_clause(terms_from_vars(OutputVars),
+ det_expr(MaybeSuccessExpr))),
+ Statement = elds_call_ho(ClosureVarExpr,
+ InputVarsExprs ++ [SuccessCont])
).
erl_gen_cast(_Context, ArgVars, MaybeSuccessExpr, Statement, !Info) :-
Index: compiler/erl_code_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_gen.m,v
retrieving revision 1.1
diff -u -r1.1 erl_code_gen.m
--- compiler/erl_code_gen.m 15 May 2007 02:38:21 -0000 1.1
+++ compiler/erl_code_gen.m 17 May 2007 01:23:57 -0000
@@ -21,7 +21,6 @@
% failure).
%
% TODO: (this is incomplete)
-% - nondet code
% - contexts are ignored at the moment
% - RTTI
% - type classes
@@ -34,10 +33,7 @@
:- interface.
:- import_module erl_backend.elds.
-:- import_module erl_backend.erl_code_util.
-:- import_module hlds.code_model.
:- import_module hlds.hlds_module.
-:- import_module parse_tree.prog_data.
:- import_module io.
@@ -48,25 +44,13 @@
%
:- pred erl_code_gen(module_info::in, elds::out, io::di, io::uo) is det.
- % erl_gen_wrap_goal(OuterCodeModel, InnerCodeModel, Context,
- % Statement0, Statement):
- %
- % OuterCodeModel is the code model expected by the context in which a goal
- % is called. InnerCodeModel is the code model which the goal actually has.
- % This predicate converts the code generated for the goal using
- % InnerCodeModel into code that uses the calling convention appropriate
- % for OuterCodeModel.
- %
-:- pred erl_gen_wrap_goal(code_model::in, code_model::in, prog_context::in,
- elds_expr::in, elds_expr::out, erl_gen_info::in, erl_gen_info::out)
- is det.
-
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module erl_backend.erl_call_gen.
+:- import_module erl_backend.erl_code_util.
:- import_module erl_backend.erl_unify_gen.
:- import_module hlds.code_model.
:- import_module hlds.goal_util.
@@ -76,7 +60,10 @@
:- import_module hlds.passes_aux.
:- import_module hlds.pred_table.
:- import_module libs.compiler_util.
+:- import_module parse_tree.prog_data.
+:- import_module bool.
+:- import_module int.
:- import_module list.
:- import_module map.
:- import_module maybe.
@@ -175,17 +162,16 @@
proc_info::in, list(elds_defn)::in, list(elds_defn)::out) is det.
erl_gen_proc(ModuleInfo, PredId, ProcId, _PredInfo, _ProcInfo, !Defns) :-
- erl_gen_proc_defn(ModuleInfo, PredId, ProcId, Arity, ProcVarSet,
- ProcClause),
- ProcDefn = elds_defn(proc(PredId, ProcId), Arity, ProcVarSet, ProcClause),
+ erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcClause),
+ ProcDefn = elds_defn(proc(PredId, ProcId), ProcVarSet, ProcClause),
!:Defns = [ProcDefn | !.Defns].
% Generate an ELDS definition for the specified procedure.
%
:- pred erl_gen_proc_defn(module_info::in, pred_id::in, proc_id::in,
- arity::out, prog_varset::out, elds_clause::out) is det.
+ prog_varset::out, elds_clause::out) is det.
-erl_gen_proc_defn(ModuleInfo, PredId, ProcId, Arity, ProcVarSet, ProcClause) :-
+erl_gen_proc_defn(ModuleInfo, PredId, ProcId, ProcVarSet, ProcClause) :-
module_info_pred_proc_info(ModuleInfo, PredId, ProcId, PredInfo, ProcInfo),
pred_info_get_import_status(PredInfo, ImportStatus),
proc_info_interface_code_model(ProcInfo, CodeModel),
@@ -218,9 +204,6 @@
!Info)
),
- erl_gen_info_get_input_vars(!.Info, InputVars),
- Arity = list.length(InputVars),
-
erl_gen_info_get_varset(!.Info, ProcVarSet)
).
@@ -230,18 +213,30 @@
erl_gen_proc_body(CodeModel, InstMap0, Goal, ProcClause, !Info) :-
erl_gen_info_get_input_vars(!.Info, InputVars),
erl_gen_info_get_output_vars(!.Info, OutputVars),
+ OutputVarsExprs = exprs_from_vars(OutputVars),
(
( CodeModel = model_det
; CodeModel = model_semi
),
- SuccessExpr = elds_term(elds_tuple(exprs_from_vars(OutputVars)))
+ %
+ % On success, the procedure returns a tuple of its output variables.
+ %
+ InputVarsTerms = terms_from_vars(InputVars),
+ SuccessExpr = elds_term(elds_tuple(OutputVarsExprs))
;
CodeModel = model_non,
- sorry(this_file, "nondet code in Erlang backend")
+ %
+ % On success, the procedure calls a continuation, passing the values of
+ % its output variables as arguments. The continuation is supplied as
+ % an extra argument to the current procedure.
+ %
+ erl_gen_info_new_named_var("SucceedHeadVar", SucceedVar, !Info),
+ InputVarsTerms = terms_from_vars(InputVars ++ [SucceedVar]),
+ SuccessExpr = elds_call_ho(expr_from_var(SucceedVar), OutputVarsExprs)
),
erl_gen_goal(CodeModel, InstMap0, Goal, yes(SuccessExpr), Statement,
!Info),
- ProcClause = elds_clause(terms_from_vars(InputVars), Statement).
+ ProcClause = elds_clause(InputVarsTerms, Statement).
%-----------------------------------------------------------------------------%
%
@@ -256,57 +251,137 @@
%
% If MaybeSuccessExpr is `yes(SuccessExpr)' then SuccessExpr is the
% expression that the code generated for Goal must evaluate to, if the Goal
- % succeeds.
+ % succeeds. MaybeSuccessExpr can only be `no' for model_det code.
+ % On failure, model_semi code returns the atom `fail'.
+ % On failure, model_non code may return anything.
%
erl_gen_goal(CodeModel, InstMap, Goal, MaybeSuccessExpr, Code, !Info) :-
Goal = hlds_goal(GoalExpr, GoalInfo),
goal_info_get_context(GoalInfo, Context),
+ goal_info_get_code_model(GoalInfo, GoalCodeModel),
+ (
+ (
+ CodeModel = model_det,
+ GoalCodeModel = model_semi
+ ;
+ CodeModel = model_det,
+ GoalCodeModel = model_non
+ ;
+ CodeModel = model_semi,
+ GoalCodeModel = model_non
+ )
+ ->
+ unexpected(this_file, "erl_gen_goal: code model mismatch")
+ ;
+ erl_gen_goal_expr(GoalExpr, GoalCodeModel, InstMap, Context,
+ MaybeSuccessExpr, Code, !Info)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % Generate code for a commit.
+ %
+:- pred erl_gen_commit(hlds_goal::in, code_model::in, instmap::in,
+ prog_context::in, maybe(elds_expr)::in, elds_expr::out,
+ erl_gen_info::in, erl_gen_info::out) is det.
- % Generate code for the goal in its own code model.
+erl_gen_commit(Goal, CodeModel, InstMap, Context, MaybeSuccessExpr,
+ Statement, !Info) :-
+ Goal = hlds_goal(_, GoalInfo),
goal_info_get_code_model(GoalInfo, GoalCodeModel),
- erl_gen_goal_expr(GoalExpr, GoalCodeModel, InstMap, Context,
- MaybeSuccessExpr, GoalCode, !Info),
+ goal_info_get_context(GoalInfo, _GoalContext),
- % Add whatever wrapper is needed to convert the goal's code model
- % to the desired code model.
- erl_gen_wrap_goal(CodeModel, GoalCodeModel, Context,
- GoalCode, Code, !Info).
-
- % If the inner and outer code models are equal, we don't need to do
- % anything special.
-
-erl_gen_wrap_goal(model_det, model_det, _, !Code, !Info).
-erl_gen_wrap_goal(model_semi, model_semi, _, !Code, !Info).
-erl_gen_wrap_goal(model_non, model_non, _, !Code, !Info).
-
- % If the inner code model is more precise than the outer code model,
- % then we need to append some statements to convert the calling convention
- % for the inner code model to that of the outer code model.
-
-erl_gen_wrap_goal(model_semi, model_det, _Context, !Code, !Info).
- % Currently nothing is required because det goals always
- % return their results in a tuple, which is exactly the same as
- % a successful return from a semidet goal.
-
-erl_gen_wrap_goal(model_non, model_det, _Context, !Code, !Info) :-
- sorry(this_file, "nondet code in Erlang backend").
-
-erl_gen_wrap_goal(model_non, model_semi, _Context, !Code, !Info) :-
- sorry(this_file, "nondet code in Erlang backend").
-
- % If the inner code model is less precise than the outer code model,
- % then simplify.m is supposed to wrap the goal inside a `some'
- % to indicate that a commit is needed.
-
-erl_gen_wrap_goal(model_det, model_semi, _, _, _, !Info) :-
- unexpected(this_file,
- "erl_gen_wrap_goal: code model mismatch -- semi in det").
-erl_gen_wrap_goal(model_det, model_non, _, _, _, !Info) :-
- unexpected(this_file,
- "erl_gen_wrap_goal: code model mismatch -- nondet in det").
-erl_gen_wrap_goal(model_semi, model_non, _, _, _, !Info) :-
- unexpected(this_file,
- "erl_gen_wrap_goal: code model mismatch -- nondet in semi").
+ (
+ GoalCodeModel = model_non,
+ CodeModel = model_semi
+ ->
+ % model_non in semi context:
+ % <succeeded = Goal>
+ % ===>
+ %
+ % let Throw = ``throw({'MERCURY_COMMIT', {NonLocals, ...})''
+ % where NonLocals are variables bound by Goal.
+ %
+ % try
+ % <Goal && Throw()>
+ % of
+ % _ -> fail
+ % catch
+ % throw: {'MERCURY_COMMIT', {NonLocals, ...}} ->
+ % SuccessExpr
+ % end
+
+ erl_gen_commit_pieces(Goal, InstMap, Context, no,
+ GoalStatement, PackedNonLocals, !Info),
+
+ Statement = elds_try(GoalStatement, [AnyCase], Catch),
+ AnyCase = elds_case(elds_anon_var, elds_term(elds_fail)),
+ Catch = elds_catch(elds_throw_atom,
+ elds_tuple([elds_commit_marker, PackedNonLocals]),
+ det_expr(MaybeSuccessExpr))
+ ;
+ GoalCodeModel = model_non,
+ CodeModel = model_det
+ ->
+ % model_non in det context:
+ % <do Goal>
+ % ===>
+ %
+ % let Throw = ``throw({'MERCURY_COMMIT', {NonLocals, ...}})''
+ % where NonLocals are variables bound by Goal.
+ %
+ % {NonLocals, ...} =
+ % (try
+ % <Goal && Throw()>
+ % catch
+ % throw: {'MERCURY_COMMIT', Results} -> Results
+ % end)
+
+ erl_gen_commit_pieces(Goal, InstMap, Context, yes,
+ GoalStatement, PackedNonLocals, !Info),
+
+ erl_gen_info_new_named_var("Results", ResultsVar, !Info),
+ ResultsVarExpr = expr_from_var(ResultsVar),
+
+ Statement = elds_eq(PackedNonLocals, TryExpr),
+ TryExpr = elds_try(GoalStatement, [], Catch),
+ Catch = elds_catch(elds_throw_atom,
+ elds_tuple([elds_commit_marker, ResultsVarExpr]), ResultsVarExpr)
+ ;
+ % No commit required.
+ erl_gen_goal(CodeModel, InstMap, Goal, MaybeSuccessExpr, Statement,
+ !Info)
+ ).
+
+:- pred erl_gen_commit_pieces(hlds_goal::in, instmap::in, prog_context::in,
+ bool::in, elds_expr::out, elds_expr::out,
+ erl_gen_info::in, erl_gen_info::out) is det.
+
+erl_gen_commit_pieces(Goal, InstMap, _Context, DoRenaming,
+ GoalStatement, PackedNonLocals, !Info) :-
+ % Find the nonlocal variables bound by the goal.
+ erl_gen_info_get_module_info(!.Info, ModuleInfo),
+ erl_bound_nonlocals_in_goal(ModuleInfo, InstMap, Goal, NonLocalsSet),
+ NonLocals = set.to_sorted_list(NonLocalsSet),
+
+ % Throw = ``throw({'MERCURY_COMMIT', {NonLocals, ...})''
+ Throw = elds_throw(elds_term(ThrowValue)),
+ ThrowValue = elds_tuple([elds_commit_marker, PackedNonLocals]),
+ PackedNonLocals = elds_term(elds_tuple(exprs_from_vars(NonLocals))),
+
+ % Generate the goal expression such that it throws the exception
+ % at the first solution.
+ erl_gen_goal(model_non, InstMap, Goal, yes(Throw), GoalStatement0, !Info),
+
+ % Rename the nonlocal variables in the generated expression if we have to.
+ (
+ DoRenaming = yes,
+ erl_create_renaming(NonLocals, Subn, !Info),
+ erl_rename_vars_in_expr(Subn, GoalStatement0, GoalStatement)
+ ;
+ DoRenaming = no,
+ GoalStatement = GoalStatement0
+ ).
%-----------------------------------------------------------------------------%
@@ -322,21 +397,24 @@
Context, MaybeSuccessExpr, Statement, !Info).
erl_gen_goal_expr(scope(ScopeReason, Goal), CodeModel, InstMap, Context,
- MaybeSuccessExpr, CodeExpr, !Info) :-
+ MaybeSuccessExpr, Statement, !Info) :-
(
( ScopeReason = exist_quant(_)
; ScopeReason = promise_solutions(_, _)
; ScopeReason = promise_purity(_, _)
- ; ScopeReason = commit(_)
; ScopeReason = barrier(_)
; ScopeReason = trace_goal(_, _, _, _, _)
),
sorry(this_file, "exotic scope type in erlang code generator")
;
+ ScopeReason = commit(_),
+ erl_gen_commit(Goal, CodeModel, InstMap, Context,
+ MaybeSuccessExpr, Statement, !Info)
+ ;
ScopeReason = from_ground_term(_),
Goal = hlds_goal(GoalExpr, _),
erl_gen_goal_expr(GoalExpr, CodeModel, InstMap, Context,
- MaybeSuccessExpr, CodeExpr, !Info)
+ MaybeSuccessExpr, Statement, !Info)
).
erl_gen_goal_expr(if_then_else(_Vars, Cond, Then, Else), CodeModel,
@@ -417,32 +495,76 @@
% Code for switches
%
- % The generated code looks like:
+:- func duplicate_expr_limit = int.
+
+duplicate_expr_limit = 10. % XXX arbitrary
+
+:- pred erl_gen_switch(prog_var::in, can_fail::in, list(hlds_goal.case)::in,
+ code_model::in, instmap::in, prog_context::in, maybe(elds_expr)::in,
+ elds_expr::out, erl_gen_info::in, erl_gen_info::out) is det.
+
+erl_gen_switch(Var, CanFail, CasesList, CodeModel, InstMap, _Context,
+ MaybeSuccessExpr0, Statement, !Info) :-
%
- % case Var of
- % Pattern1 -> Expr1 [[ MaybeSuccessExpr ]];
- % Pattern2 -> Expr2 [[ MaybeSuccessExpr ]];
- % ...
- % end
+ % If the success expression is not too big, then we generate code for
+ % a switch like this:
+ %
+ % case Var of
+ % Pattern1 -> Expr1 [[ SuccessExpr ]] ;
+ % Pattern2 -> Expr2 [[ SuccessExpr ]] ;
+ % ...
+ % end
+ %
+ % Otherwise the success expression is put into a closure and the closure
+ % is called on success of each case:
+ %
+ % SuccessClosure = fun(Vars, ...) ->
+ % /* Vars are those variables bound by Expr<n> */
+ % SuccessExpr
+ % end,
+ % case Var of
+ % Pattern1 -> Expr1 [[ SuccessClosure() ]] ;
+ % Pattern2 -> Expr2 [[ SuccessClosure() ]] ;
+ % ...
+ % end
%
% If the switch can fail, a default case is added:
%
% _ -> fail
%
-:- pred erl_gen_switch(prog_var::in, can_fail::in, list(hlds_goal.case)::in,
- code_model::in, instmap::in, prog_context::in, maybe(elds_expr)::in,
- elds_expr::out, erl_gen_info::in, erl_gen_info::out) is det.
-erl_gen_switch(Var, CanFail, CasesList, CodeModel, InstMap, _Context,
- MaybeSuccessExpr, Statement, !Info) :-
% Get the union of all variables bound in all cases.
erl_gen_info_get_module_info(!.Info, ModuleInfo),
CasesGoals = list.map((func(case(_, Goal)) = Goal), CasesList),
union_bound_nonlocals_in_goals(ModuleInfo, InstMap, CasesGoals,
- MustBindNonLocals),
+ NonLocalsBoundInCases),
+
+ (if
+ MaybeSuccessExpr0 = yes(SuccessExpr0),
+ erl_expr_size(SuccessExpr0) > duplicate_expr_limit
+ then
+ erl_gen_info_new_named_var("SuccessClosure", ClosureVar, !Info),
+ ClosureVarExpr = expr_from_var(ClosureVar),
+ ClosureArgs = set.to_sorted_list(NonLocalsBoundInCases),
+ ClosureArgsTerms = terms_from_vars(ClosureArgs),
+ ClosureArgsExprs = exprs_from_vars(ClosureArgs),
+
+ % ``SuccessClosure = fun(ClosureArgs, ...) -> SuccessExpr0 end''
+ MakeClosure = elds_eq(ClosureVarExpr, ClosureFun),
+ ClosureFun = elds_fun(elds_clause(ClosureArgsTerms, SuccessExpr0)),
+
+ % ``SuccessClosure(ClosureArgs, ...)''
+ CallClosure = elds_call_ho(ClosureVarExpr, ClosureArgsExprs),
+
+ MaybeMakeClosure = yes(MakeClosure),
+ MaybeSuccessExpr = yes(CallClosure)
+ else
+ MaybeMakeClosure = no,
+ MaybeSuccessExpr = MaybeSuccessExpr0
+ ),
% Generate code for each case.
- list.map_foldl(erl_gen_case(CodeModel, InstMap, MustBindNonLocals,
+ list.map_foldl(erl_gen_case(CodeModel, InstMap, NonLocalsBoundInCases,
MaybeSuccessExpr), CasesList, ErlCases0, !Info),
(
CanFail = can_fail,
@@ -453,7 +575,16 @@
CanFail = cannot_fail,
ErlCases = ErlCases0
),
- Statement = elds_case_expr(expr_from_var(Var), ErlCases).
+
+ % Create the overall switch statement,.
+ CaseExpr = elds_case_expr(expr_from_var(Var), ErlCases),
+ (
+ MaybeMakeClosure = yes(MakeClosure1),
+ Statement = join_exprs(MakeClosure1, CaseExpr)
+ ;
+ MaybeMakeClosure = no,
+ Statement = CaseExpr
+ ).
:- pred union_bound_nonlocals_in_goals(module_info::in, instmap::in,
hlds_goals::in, set(prog_var)::out) is det.
@@ -573,7 +704,45 @@
FalseCase = elds_case(elds_anon_var, ElseStatement)
;
CondCodeModel = model_non,
- sorry(this_file, "nondet code in Erlang backend")
+ %
+ % model_non cond:
+ % <(Cond -> Then ; Else)>
+ % ===>
+ % let PutAndThen = ``put(Ref, true), <Then>''
+ %
+ % Ref = make_ref(), /* defaults to `undefined' */
+ % <Cond && PutAndThen>
+ % case get(Ref) of
+ % true -> true ;
+ % _ -> <Else>
+ % end,
+ % erase(Ref)
+ %
+
+ erl_gen_info_new_named_var("Ref", Ref, !Info),
+ RefExpr = expr_from_var(Ref),
+ MakeRef = elds_eq(RefExpr, elds_call_builtin("make_ref", [])),
+ PutRef = elds_call_builtin("put", [RefExpr, elds_term(elds_true)]),
+ GetRef = elds_call_builtin("get", [RefExpr]),
+ EraseRef = elds_call_builtin("erase", [RefExpr]),
+
+ update_instmap(Cond, InstMap0, InstMap1),
+ erl_gen_goal(CodeModel, InstMap1, Then, MaybeSuccessExpr,
+ ThenStatement, !Info),
+ PutAndThen = join_exprs(PutRef, ThenStatement),
+
+ erl_gen_goal(CondCodeModel, InstMap0, Cond, yes(PutAndThen),
+ CondThen, !Info),
+
+ erl_gen_goal(CodeModel, InstMap0, Else, MaybeSuccessExpr,
+ ElseStatement, !Info),
+
+ CaseElse = elds_case_expr(GetRef, [TrueCase, OtherCase]),
+ TrueCase = elds_case(elds_true, elds_term(elds_true)),
+ OtherCase = elds_case(elds_anon_var, ElseStatement),
+
+ Statement = list.foldr(join_exprs,
+ [MakeRef, CondThen, CaseElse], EraseRef)
).
%-----------------------------------------------------------------------------%
@@ -654,10 +823,15 @@
erl_gen_conj([], CodeModel, _InstMap0, _Context, MaybeSuccessExpr,
Statement, !Info) :-
- % XXX implement this for other code models
- require(unify(CodeModel, model_det),
- "erl_gen_conj: CodeModel != model_det"),
- Statement = expr_or_void(MaybeSuccessExpr).
+ (
+ CodeModel = model_det,
+ Statement = expr_or_void(MaybeSuccessExpr)
+ ;
+ ( CodeModel = model_semi
+ ; CodeModel = model_non
+ ),
+ Statement = det_expr(MaybeSuccessExpr)
+ ).
erl_gen_conj([SingleGoal], CodeModel, InstMap0, _Context, MaybeSuccessExpr,
Statement, !Info) :-
erl_gen_goal(CodeModel, InstMap0, SingleGoal, MaybeSuccessExpr,
@@ -676,6 +850,13 @@
update_instmap(First, InstMap0, InstMap1),
(
FirstCodeModel = model_det,
+ %
+ % model_det Goal:
+ % <Goal, Goals>
+ % ===>
+ % <do Goal>,
+ % <Goals>
+ %
erl_gen_goal(model_det, InstMap0, First, no,
FirstStatement, !Info),
erl_gen_conj(Rest, CodeModel, InstMap1, Context, MaybeSuccessExpr,
@@ -683,13 +864,64 @@
Statement = join_exprs(FirstStatement, RestStatement)
;
FirstCodeModel = model_semi,
+ %
+ % model_semi Goal:
+ % <Goal, Goals>
+ % ===>
+ % case <Goal> of
+ % {Outputs, ...} ->
+ % <Goals> ;
+ % _ ->
+ % fail
+ % end
+ %
erl_gen_conj(Rest, CodeModel, InstMap1, Context, MaybeSuccessExpr,
RestStatement, !Info),
erl_gen_goal(model_semi, InstMap0, First, yes(RestStatement),
Statement, !Info)
;
FirstCodeModel = model_non,
- sorry(this_file, "nondet code in Erlang backend")
+ %
+ % model_non Goal:
+ % <Goal, Goals>
+ % ===>
+ % SUCCEED1 = fun(Outputs, ...) ->
+ % <Goals && SUCCEED()>
+ % end,
+ % <Goal && SUCCEED1()>
+ %
+
+ % Generate the code for Rest.
+ erl_gen_conj(Rest, CodeModel, InstMap1, Context, MaybeSuccessExpr,
+ RestStatement, !Info),
+
+ % Find the variables bound by First.
+ erl_gen_info_get_module_info(!.Info, ModuleInfo),
+ erl_bound_nonlocals_in_goal(ModuleInfo, InstMap0, First,
+ NonLocalsSet),
+ NonLocals = set.to_sorted_list(NonLocalsSet),
+
+ % Make the success continuation. Rename apart any variables bound
+ % by First to avoid warnings about the closure shadowing variables.
+ SucceedFunc0 = elds_fun(elds_clause(terms_from_vars(NonLocals),
+ RestStatement)),
+ erl_create_renaming(NonLocals, Subst, !Info),
+ erl_rename_vars_in_expr(Subst, SucceedFunc0, SucceedFunc),
+
+ % MakeSucceed == "SucceedConj = fun(...) -> ... end "
+ % CallSucceed == "SucceedConj(...)"
+ erl_gen_info_new_named_var("SucceedConj", SucceedVar, !Info),
+ SucceedVarExpr = expr_from_var(SucceedVar),
+ MakeSucceed = elds_eq(SucceedVarExpr, SucceedFunc),
+ CallSucceed = elds_call_ho(SucceedVarExpr,
+ exprs_from_vars(NonLocals)),
+
+ % Generate the code for First, such that it calls the success
+ % continuation on success.
+ erl_gen_goal(model_non, InstMap0, First, yes(CallSucceed),
+ FirstStatement, !Info),
+
+ Statement = join_exprs(MakeSucceed, FirstStatement)
)
).
@@ -704,6 +936,7 @@
erl_gen_disj([], CodeModel, _InstMap, _Context, _MaybeSuccessExpr,
Statement, !Info) :-
+ % Handle empty disjunctions (a.ka. `fail').
(
CodeModel = model_det,
unexpected(this_file, "erl_gen_disj: `fail' has determinism `det'")
@@ -723,14 +956,11 @@
erl_gen_disj([First | Rest], CodeModel, InstMap, Context, MaybeSuccessExpr,
Statement, !Info) :-
Rest = [_ | _],
- ( CodeModel = model_non ->
- % model_non disj:
- %
- % <(Goal ; Goals) && SUCCEED()>
- % ===>
+ (
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
- sorry(this_file, "nondet code in Erlang backend")
- ;
% model_det/model_semi disj:
%
% model_det goal:
@@ -742,9 +972,9 @@
% model_semi goal:
% <Goal ; Goals>
% ===>
- % case Goal of
- % fail -> Goals ;
- % Anything -> Anything
+ % case <Goal> of
+ % fail -> <Goals> ;
+ % Any -> Anything
% end
%
% TODO This can lead to contorted code when <Goal> itself is a `case'
@@ -757,10 +987,7 @@
(
FirstCodeModel = model_det,
erl_gen_goal(model_det, InstMap, First, MaybeSuccessExpr,
- GoalStatement, !Info),
- % Is this necessary?
- erl_gen_wrap_goal(CodeModel, model_det, Context,
- GoalStatement, Statement, !Info)
+ Statement, !Info)
;
FirstCodeModel = model_semi,
@@ -780,15 +1007,43 @@
erl_create_renaming(FirstVars, Subn, !Info),
erl_rename_vars_in_expr(Subn, FirstStatement0, FirstStatement),
- erl_gen_info_new_var(Dummy, !Info),
+ erl_gen_info_new_named_var("Any", AnyVar, !Info),
Statement = elds_case_expr(FirstStatement, [FailCase, OtherCase]),
FailCase = elds_case(elds_fail, RestStatement),
- OtherCase = elds_case(term_from_var(Dummy), expr_from_var(Dummy))
+ OtherCase = elds_case(term_from_var(AnyVar), expr_from_var(AnyVar))
;
FirstCodeModel = model_non,
% simplify.m should get wrap commits around these.
unexpected(this_file, "model_non disj in model_det disjunction")
)
+ ;
+ CodeModel = model_non,
+
+ % model_non disj:
+ %
+ % <(Goal ; Goals) && SUCCEED()>
+ % ===>
+ % <Goal && SUCCEED()>
+ % <Goals && SUCCEED()>
+ %
+
+ % Generate the first disjunct, renaming apart variables bound by it.
+ % Otherwise the second and later disjuncts would try to bind the same
+ % variables to different values.
+ erl_gen_goal(model_non, InstMap, First, MaybeSuccessExpr,
+ FirstStatement0, !Info),
+
+ erl_gen_info_get_module_info(!.Info, ModuleInfo),
+ erl_bound_nonlocals_in_goal(ModuleInfo, InstMap, First, FirstVarsSet),
+ FirstVars = set.to_sorted_list(FirstVarsSet),
+ erl_create_renaming(FirstVars, Subst, !Info),
+ erl_rename_vars_in_expr(Subst, FirstStatement0, FirstStatement),
+
+ % Generate the rest of the disjunction.
+ erl_gen_disj(Rest, model_non, InstMap, Context, MaybeSuccessExpr,
+ RestStatements, !Info),
+
+ Statement = join_exprs(FirstStatement, RestStatements)
).
%-----------------------------------------------------------------------------%
Index: compiler/erl_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_code_util.m,v
retrieving revision 1.1
diff -u -r1.1 erl_code_util.m
--- compiler/erl_code_util.m 15 May 2007 02:38:21 -0000 1.1
+++ compiler/erl_code_util.m 17 May 2007 01:23:57 -0000
@@ -52,7 +52,7 @@
% Create a new variable.
%
-:- pred erl_gen_info_new_var(prog_var::out,
+:- pred erl_gen_info_new_named_var(string::in, prog_var::out,
erl_gen_info::in, erl_gen_info::out) is det.
% Create multiple new variables.
@@ -123,6 +123,12 @@
:- pred erl_rename_vars_in_expr(prog_var_renaming::in,
elds_expr::in, elds_expr::out) is det.
+ % Return a rough indication of the "size" of an expression, where each
+ % simple constant has a value of 1. This is used to decide if an
+ % expression is too big to duplicate.
+ %
+:- func erl_expr_size(elds_expr) = int.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -132,6 +138,7 @@
:- import_module check_hlds.type_util.
:- import_module libs.compiler_util.
+:- import_module int.
:- import_module map.
:- import_module set.
:- import_module term.
@@ -193,9 +200,9 @@
erl_gen_info_set_varset(VarSet, Info, Info ^ varset := VarSet).
-erl_gen_info_new_var(NewVar, !Info) :-
+erl_gen_info_new_named_var(Name, NewVar, !Info) :-
erl_gen_info_get_varset(!.Info, VarSet0),
- varset.new_var(VarSet0, NewVar, VarSet),
+ varset.new_named_var(VarSet0, Name, NewVar, VarSet),
erl_gen_info_set_varset(VarSet, !Info).
erl_gen_info_new_vars(Num, NewVars, !Info) :-
@@ -340,6 +347,10 @@
erl_rename_vars_in_exprs(Subn, ExprsB0, ExprsB),
Expr = elds_call_ho(ExprA, ExprsB)
;
+ Expr0 = elds_call_builtin(Atom, ExprsA0),
+ erl_rename_vars_in_exprs(Subn, ExprsA0, ExprsA),
+ Expr = elds_call_builtin(Atom, ExprsA)
+ ;
Expr0 = elds_fun(Clause0),
erl_rename_vars_in_clause(Subn, Clause0, Clause),
Expr = elds_fun(Clause)
@@ -348,6 +359,16 @@
erl_rename_vars_in_expr(Subn, ExprA0, ExprA),
erl_rename_vars_in_cases(Subn, Cases0, Cases),
Expr = elds_case_expr(ExprA, Cases)
+ ;
+ Expr0 = elds_try(ExprA0, Cases0, Catch0),
+ erl_rename_vars_in_expr(Subn, ExprA0, ExprA),
+ erl_rename_vars_in_cases(Subn, Cases0, Cases),
+ erl_rename_vars_in_catch(Subn, Catch0, Catch),
+ Expr = elds_try(ExprA, Cases, Catch)
+ ;
+ Expr0 = elds_throw(ExprA0),
+ erl_rename_vars_in_expr(Subn, ExprA0, ExprA),
+ Expr = elds_throw(ExprA)
).
:- pred erl_rename_vars_in_terms(prog_var_renaming::in,
@@ -404,6 +425,101 @@
erl_rename_vars_in_expr(Subn, Expr0, Expr),
Case = elds_case(Pattern, Expr).
+:- pred erl_rename_vars_in_catch(prog_var_renaming::in,
+ elds_catch::in, elds_catch::out) is det.
+
+erl_rename_vars_in_catch(Subn, Catch0, Catch) :-
+ Catch0 = elds_catch(PatternA0, PatternB0, Expr0),
+ erl_rename_vars_in_term(Subn, PatternA0, PatternA),
+ erl_rename_vars_in_term(Subn, PatternB0, PatternB),
+ erl_rename_vars_in_expr(Subn, Expr0, Expr),
+ Catch = elds_catch(PatternA, PatternB, Expr).
+
+%-----------------------------------------------------------------------------%
+
+:- func erl_exprs_size(list(elds_expr)) = int.
+
+erl_exprs_size(Exprs) = sum(list.map(erl_expr_size, Exprs)).
+
+erl_expr_size(Expr) = Size :-
+ (
+ Expr = elds_block(Exprs),
+ Size = erl_exprs_size(Exprs)
+ ;
+ Expr = elds_term(Term),
+ Size = erl_term_size(Term)
+ ;
+ Expr = elds_eq(ExprA, ExprB),
+ Size = erl_expr_size(ExprA) + erl_expr_size(ExprB)
+ ;
+ Expr = elds_unop(_Op, ExprA),
+ Size = erl_expr_size(ExprA)
+ ;
+ Expr = elds_binop(_Op, ExprA, ExprB),
+ Size = erl_expr_size(ExprA) + erl_expr_size(ExprB)
+ ;
+ Expr = elds_call(_PredProcId, Exprs),
+ Size = 1 + erl_exprs_size(Exprs)
+ ;
+ Expr = elds_call_ho(ExprA, ExprsB),
+ Size = 1 + erl_expr_size(ExprA) + erl_exprs_size(ExprsB)
+ ;
+ Expr = elds_call_builtin(_Atom, ExprsA),
+ Size = 1 + erl_exprs_size(ExprsA)
+ ;
+ Expr = elds_fun(elds_clause(Terms, ExprA)),
+ Size = 1 + erl_terms_size(Terms) + erl_expr_size(ExprA)
+ ;
+ Expr = elds_case_expr(ExprA, Cases),
+ Size = 1 + erl_expr_size(ExprA) + erl_cases_size(Cases)
+ ;
+ Expr = elds_try(ExprA, Cases, Catch),
+ Catch = elds_catch(TermA, TermB, CatchExpr),
+ Size = 1 + erl_expr_size(ExprA) + erl_cases_size(Cases) +
+ erl_term_size(TermA) + erl_term_size(TermB) +
+ erl_expr_size(CatchExpr)
+ ;
+ Expr = elds_throw(ExprA),
+ Size = 1 + erl_expr_size(ExprA)
+ ).
+
+:- func erl_terms_size(list(elds_term)) = int.
+
+erl_terms_size(Terms) = sum(list.map(erl_term_size, Terms)).
+
+:- func erl_term_size(elds_term) = int.
+
+erl_term_size(Term) = Size :-
+ (
+ ( Term = elds_int(_)
+ ; Term = elds_float(_)
+ ; Term = elds_string(_)
+ ; Term = elds_char(_)
+ ; Term = elds_atom_raw(_)
+ ; Term = elds_atom(_)
+ ; Term = elds_var(_)
+ ; Term = elds_anon_var
+ ),
+ Size = 1
+ ;
+ Term = elds_tuple(Exprs),
+ Size = 1 + erl_exprs_size(Exprs)
+ ).
+
+:- func erl_cases_size(list(elds_case)) = int.
+
+erl_cases_size(Cases) = 1 + sum(list.map(erl_case_size, Cases)).
+
+:- func erl_case_size(elds_case) = int.
+
+erl_case_size(Case) = Size :-
+ Case = elds_case(Pattern, Expr),
+ Size = 1 + erl_term_size(Pattern) + erl_expr_size(Expr).
+
+:- func sum(list(int)) = int.
+
+sum(Xs) = list.foldl(int.plus, Xs, 0).
+
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/erl_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_unify_gen.m,v
retrieving revision 1.1
diff -u -r1.1 erl_unify_gen.m
--- compiler/erl_unify_gen.m 15 May 2007 02:38:21 -0000 1.1
+++ compiler/erl_unify_gen.m 17 May 2007 01:23:57 -0000
@@ -116,30 +116,20 @@
erl_gen_construct(Var, ConsId, Args, ArgModes, Context, Construct, !Info),
Statement = maybe_join_exprs(Construct, MaybeSuccessExpr).
-erl_gen_unification(Unification, CodeModel, Context, MaybeSuccessExpr,
+erl_gen_unification(Unification, _CodeModel, Context, MaybeSuccessExpr,
Statement, !Info) :-
Unification = deconstruct(Var, ConsId, Args, ArgModes, CanFail, _CanCGC),
(
CanFail = can_fail,
- ExpectedCodeModel = model_semi,
+ SuccessExpr = det_expr(MaybeSuccessExpr),
erl_gen_semidet_deconstruct(Var, ConsId, Args, ArgModes, Context,
- MaybeSuccessExpr, Statement1, !Info)
+ SuccessExpr, Statement, !Info)
;
CanFail = cannot_fail,
- ExpectedCodeModel = model_det,
erl_gen_det_deconstruct(Var, ConsId, Args, ArgModes, Context,
Statement0, !Info),
- Statement1 = maybe_join_exprs(Statement0, MaybeSuccessExpr)
- ),
-
- % In ml_unify_gen.m it's written:
- % We used to require that CodeModel = ExpectedCodeModel. But the
- % delds_terminism field in the goal_info is allowed to be a conservative
- % approximation, so we need to handle the case were CodeModel is less
- % precise than ExpectedCodeModel.
- %
- erl_gen_wrap_goal(CodeModel, ExpectedCodeModel, Context,
- Statement1, Statement, !Info).
+ Statement = maybe_join_exprs(Statement0, MaybeSuccessExpr)
+ ).
erl_gen_unification(complicated_unify(_, _, _), _, _, _, _, !Info) :-
% Simplify.m should have converted these into procedure calls.
@@ -167,17 +157,11 @@
Statement = elds_eq(LHS, expr_from_var(Var)).
:- pred erl_gen_semidet_deconstruct(prog_var::in, cons_id::in, prog_vars::in,
- list(uni_mode)::in, prog_context::in, maybe(elds_expr)::in, elds_expr::out,
+ list(uni_mode)::in, prog_context::in, elds_expr::in, elds_expr::out,
erl_gen_info::in, erl_gen_info::out) is det.
erl_gen_semidet_deconstruct(Var, ConsId, Args, _Modes, _Context,
- MaybeSuccessExpr, Statement, !Info) :-
- (
- MaybeSuccessExpr = yes(SuccessExpr)
- ;
- MaybeSuccessExpr = no,
- unexpected(this_file, "erl_gen_semidet_deconstruct: no success value")
- ),
+ SuccessExpr, Statement, !Info) :-
( cons_id_to_term(ConsId, Args, Pattern0, !Info) ->
Pattern = Pattern0
;
@@ -247,7 +231,7 @@
; ConsId = table_io_decl(_)
),
sorry(this_file,
- "tabling and deep profiling not support on Erlang backend")
+ "tabling and deep profiling not supported on Erlang backend")
).
:- pred pred_const_to_closure(shrouded_pred_proc_id::in, prog_vars::in,
@@ -259,6 +243,7 @@
module_info_pred_proc_info(ModuleInfo, PredProcId, PredInfo, ProcInfo),
pred_info_get_arg_types(PredInfo, CalleeTypes),
proc_info_get_argmodes(ProcInfo, ArgModes),
+ proc_info_interface_code_model(ProcInfo, CodeModel),
% Create extra variables needed to complete the call to the procedure.
NumExtraVars = list.length(CalleeTypes) - list.length(Args),
@@ -269,11 +254,26 @@
ArgModes, AllInputVars, OutputVars),
InputExtraVars = list.delete_elems(AllExtraVars, OutputVars),
- % (elds_fun(InputExtraVars, ...) -> Proc(AllInputVars, ...) end)
- % where InputExtraVars are part of AllInputVars.
+ (
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
+ InputTerms = terms_from_vars(InputExtraVars),
+ CallArgs = exprs_from_vars(AllInputVars)
+ ;
+ CodeModel = model_non,
+ % One more extra variable is needed for the success continuation for
+ % model_non procedures.
+ erl_gen_info_new_named_var("Succeed", SucceedVar, !Info),
+ InputTerms = terms_from_vars(InputExtraVars ++ [SucceedVar]),
+ CallArgs = exprs_from_vars(AllInputVars ++ [SucceedVar])
+ ),
+
+ % FunExpr = ``fun(InputTerms, ...) -> Proc(CallArgs, ...) end''
+ % where InputTerms are part of CallArgs.
%
- FunExpr = elds_fun(elds_clause(terms_from_vars(InputExtraVars), Call)),
- Call = elds_call(PredProcId, exprs_from_vars(AllInputVars)).
+ FunExpr = elds_fun(elds_clause(InputTerms, Call)),
+ Call = elds_call(PredProcId, CallArgs).
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list