QPQ-AG/sophia
10
0
Fork 0
Code Issues 41 Pull Requests 5 Actions Packages Projects Releases 16 Wiki Activity

Merge 'origin/lima' into merge_lima_to_master

Browse Source
This commit is contained in:
Hans Svensson 2019-12-19 15:09:48 +01:00
commit cf1072140e
16 changed files with 719 additions and 208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@ -7,6 +7,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
## [Unreleased] ## [Unreleased]
### Added ### Added
### Changed ### Changed
- FATE code generator improvements.
### Removed ### Removed
## [4.1.0] - 2019-11-26 ## [4.1.0] - 2019-11-26

76
src/aeso_ast_infer_types.erl
View File

@ -1189,21 +1189,20 @@ infer_expr(Env, {list, As, Elems}) ->
NewElems = [check_expr(Env, X, ElemType) || X <- Elems], NewElems = [check_expr(Env, X, ElemType) || X <- Elems],
{typed, As, {list, As, NewElems}, {app_t, As, {id, As, "list"}, [ElemType]}}; {typed, As, {list, As, NewElems}, {app_t, As, {id, As, "list"}, [ElemType]}};
infer_expr(Env, {list_comp, As, Yield, []}) -> infer_expr(Env, {list_comp, As, Yield, []}) ->
{typed, _, TypedYield, Type} = infer_expr(Env, Yield), {typed, _, _, Type} = TypedYield = infer_expr(Env, Yield),
{typed, As, {list_comp, As, TypedYield, []}, {app_t, As, {id, As, "list"}, [Type]}}; {typed, As, {list_comp, As, TypedYield, []}, {app_t, As, {id, As, "list"}, [Type]}};
infer_expr(Env, {list_comp, As, Yield, [{comprehension_bind, Arg, BExpr}|Rest]}) -> infer_expr(Env, {list_comp, As, Yield, [{comprehension_bind, Pat, BExpr}|Rest]}) ->
BindVarType = fresh_uvar(As),
TypedBind = {typed, As2, _, TypeBExpr} = infer_expr(Env, BExpr), TypedBind = {typed, As2, _, TypeBExpr} = infer_expr(Env, BExpr),
{NewE, TypedPat = {typed, _, _, PatType}} = infer_pattern(Env, Pat),
unify( Env unify( Env
, TypeBExpr , TypeBExpr
, {app_t, As, {id, As, "list"}, [BindVarType]} , {app_t, As, {id, As, "list"}, [PatType]}
, {list_comp, TypedBind, TypeBExpr, {app_t, As2, {id, As, "list"}, [BindVarType]}}), , {list_comp, TypedBind, TypeBExpr, {app_t, As2, {id, As, "list"}, [PatType]}}),
NewE = bind_var(Arg, BindVarType, Env),
{typed, _, {list_comp, _, TypedYield, TypedRest}, ResType} = {typed, _, {list_comp, _, TypedYield, TypedRest}, ResType} =
infer_expr(NewE, {list_comp, As, Yield, Rest}), infer_expr(NewE, {list_comp, As, Yield, Rest}),
{ typed { typed
, As , As
, {list_comp, As, TypedYield, [{comprehension_bind, {typed, Arg, BindVarType}, TypedBind}|TypedRest]} , {list_comp, As, TypedYield, [{comprehension_bind, TypedPat, TypedBind}|TypedRest]}
, ResType}; , ResType};
infer_expr(Env, {list_comp, AttrsL, Yield, [{comprehension_if, AttrsIF, Cond}|Rest]}) -> infer_expr(Env, {list_comp, AttrsL, Yield, [{comprehension_if, AttrsIF, Cond}|Rest]}) ->
NewCond = check_expr(Env, Cond, {id, AttrsIF, "bool"}), NewCond = check_expr(Env, Cond, {id, AttrsIF, "bool"}),
@ -1213,8 +1212,8 @@ infer_expr(Env, {list_comp, AttrsL, Yield, [{comprehension_if, AttrsIF, Cond}|Re
, AttrsL , AttrsL
, {list_comp, AttrsL, TypedYield, [{comprehension_if, AttrsIF, NewCond}|TypedRest]} , {list_comp, AttrsL, TypedYield, [{comprehension_if, AttrsIF, NewCond}|TypedRest]}
, ResType}; , ResType};
infer_expr(Env, {list_comp, AsLC, Yield, [{letval, AsLV, Pattern, Type, E}|Rest]}) -> infer_expr(Env, {list_comp, AsLC, Yield, [{letval, AsLV, Pattern, E}|Rest]}) ->
NewE = {typed, _, _, PatType} = infer_expr(Env, {typed, AsLV, E, arg_type(AsLV, Type)}), NewE = {typed, _, _, PatType} = infer_expr(Env, E),
BlockType = fresh_uvar(AsLV), BlockType = fresh_uvar(AsLV),
{'case', _, NewPattern, NewRest} = {'case', _, NewPattern, NewRest} =
infer_case( Env infer_case( Env
@ -1226,7 +1225,7 @@ infer_expr(Env, {list_comp, AsLC, Yield, [{letval, AsLV, Pattern, Type, E}|Rest]
{typed, _, {list_comp, _, TypedYield, TypedRest}, ResType} = NewRest, {typed, _, {list_comp, _, TypedYield, TypedRest}, ResType} = NewRest,
{ typed { typed
, AsLC , AsLC
, {list_comp, AsLC, TypedYield, [{letval, AsLV, NewPattern, Type, NewE}|TypedRest]} , {list_comp, AsLC, TypedYield, [{letval, AsLV, NewPattern, NewE}|TypedRest]}
, ResType , ResType
}; };
infer_expr(Env, {list_comp, AsLC, Yield, [Def={letfun, AsLF, _, _, _, _}|Rest]}) -> infer_expr(Env, {list_comp, AsLC, Yield, [Def={letfun, AsLF, _, _, _, _}|Rest]}) ->
@ -1341,6 +1340,16 @@ infer_expr(Env, {block, Attrs, Stmts}) ->
BlockType = fresh_uvar(Attrs), BlockType = fresh_uvar(Attrs),
NewStmts = infer_block(Env, Attrs, Stmts, BlockType), NewStmts = infer_block(Env, Attrs, Stmts, BlockType),
{typed, Attrs, {block, Attrs, NewStmts}, BlockType}; {typed, Attrs, {block, Attrs, NewStmts}, BlockType};
infer_expr(_Env, {record_or_map_error, Attrs, Fields}) ->
type_error({mixed_record_and_map, {record, Attrs, Fields}}),
Type = fresh_uvar(Attrs),
{typed, Attrs, {record, Attrs, []}, Type};
infer_expr(Env, {record_or_map_error, Attrs, Expr, []}) ->
type_error({empty_record_or_map_update, {record, Attrs, Expr, []}}),
infer_expr(Env, Expr);
infer_expr(Env, {record_or_map_error, Attrs, Expr, Fields}) ->
type_error({mixed_record_and_map, {record, Attrs, Expr, Fields}}),
infer_expr(Env, Expr);
infer_expr(Env, {lam, Attrs, Args, Body}) -> infer_expr(Env, {lam, Attrs, Args, Body}) ->
ArgTypes = [fresh_uvar(As) || {arg, As, _, _} <- Args], ArgTypes = [fresh_uvar(As) || {arg, As, _, _} <- Args],
ArgPatterns = [{typed, As, Pat, check_type(Env, T)} || {arg, As, Pat, T} <- Args], ArgPatterns = [{typed, As, Pat, check_type(Env, T)} || {arg, As, Pat, T} <- Args],
@ -1349,7 +1358,7 @@ infer_expr(Env, {lam, Attrs, Args, Body}) ->
infer_case(Env, Attrs, {tuple, Attrs, ArgPatterns}, {tuple_t, Attrs, ArgTypes}, Body, ResultType), infer_case(Env, Attrs, {tuple, Attrs, ArgPatterns}, {tuple_t, Attrs, ArgTypes}, Body, ResultType),
NewArgs = [{arg, As, NewPat, NewT} || {typed, As, NewPat, NewT} <- NewArgPatterns], NewArgs = [{arg, As, NewPat, NewT} || {typed, As, NewPat, NewT} <- NewArgPatterns],
{typed, Attrs, {lam, Attrs, NewArgs, NewBody}, {fun_t, Attrs, [], ArgTypes, ResultType}}; {typed, Attrs, {lam, Attrs, NewArgs, NewBody}, {fun_t, Attrs, [], ArgTypes, ResultType}};
infer_expr(Env, Let = {letval, Attrs, _, _, _}) -> infer_expr(Env, Let = {letval, Attrs, _, _}) ->
type_error({missing_body_for_let, Attrs}), type_error({missing_body_for_let, Attrs}),
infer_expr(Env, {block, Attrs, [Let, abort_expr(Attrs, "missing body")]}); infer_expr(Env, {block, Attrs, [Let, abort_expr(Attrs, "missing body")]});
infer_expr(Env, Let = {letfun, Attrs, _, _, _, _}) -> infer_expr(Env, Let = {letfun, Attrs, _, _, _, _}) ->
@ -1412,15 +1421,19 @@ infer_op(Env, As, Op, Args, InferOp) ->
unify(Env, ArgTypes, OperandTypes, {infer_app, Op, Args, Inferred, ArgTypes}), unify(Env, ArgTypes, OperandTypes, {infer_app, Op, Args, Inferred, ArgTypes}),
{typed, As, {app, As, Op, TypedArgs}, ResultType}. {typed, As, {app, As, Op, TypedArgs}, ResultType}.
infer_case(Env, Attrs, Pattern, ExprType, Branch, SwitchType) -> infer_pattern(Env, Pattern) ->
Vars = free_vars(Pattern), Vars = free_vars(Pattern),
Names = [N || {id, _, N} <- Vars, N /= "_"], Names = [N || {id, _, N} <- Vars, N /= "_"],
case Names -- lists:usort(Names) of case Names -- lists:usort(Names) of
[] -> ok; [] -> ok;
Nonlinear -> type_error({non_linear_pattern, Pattern, lists:usort(Nonlinear)}) Nonlinear -> type_error({non_linear_pattern, Pattern, lists:usort(Nonlinear)})
end, end,
NewEnv = bind_vars([{Var, fresh_uvar(Ann)} || Var = {id, Ann, _} <- Vars], Env#env{ in_pattern = true }), NewEnv = bind_vars([{Var, fresh_uvar(Ann1)} || Var = {id, Ann1, _} <- Vars], Env#env{ in_pattern = true }),
NewPattern = {typed, _, _, PatType} = infer_expr(NewEnv, Pattern), NewPattern = infer_expr(NewEnv, Pattern),
{NewEnv, NewPattern}.
infer_case(Env, Attrs, Pattern, ExprType, Branch, SwitchType) ->
{NewEnv, NewPattern = {typed, _, _, PatType}} = infer_pattern(Env, Pattern),
NewBranch = check_expr(NewEnv#env{ in_pattern = false }, Branch, SwitchType), NewBranch = check_expr(NewEnv#env{ in_pattern = false }, Branch, SwitchType),
unify(Env, PatType, ExprType, {case_pat, Pattern, PatType, ExprType}), unify(Env, PatType, ExprType, {case_pat, Pattern, PatType, ExprType}),
{'case', Attrs, NewPattern, NewBranch}. {'case', Attrs, NewPattern, NewBranch}.
@ -1435,11 +1448,11 @@ infer_block(Env, Attrs, [Def={letfun, Ann, _, _, _, _}|Rest], BlockType) ->
FunT = typesig_to_fun_t(TypeSig), FunT = typesig_to_fun_t(TypeSig),
NewE = bind_var({id, Ann, Name}, FunT, Env), NewE = bind_var({id, Ann, Name}, FunT, Env),
[LetFun|infer_block(NewE, Attrs, Rest, BlockType)]; [LetFun|infer_block(NewE, Attrs, Rest, BlockType)];
infer_block(Env, _, [{letval, Attrs, Pattern, Type, E}|Rest], BlockType) -> infer_block(Env, _, [{letval, Attrs, Pattern, E}|Rest], BlockType) ->
NewE = {typed, _, _, PatType} = infer_expr(Env, {typed, Attrs, E, arg_type(aeso_syntax:get_ann(Pattern), Type)}), NewE = {typed, _, _, PatType} = infer_expr(Env, E),
{'case', _, NewPattern, {typed, _, {block, _, NewRest}, _}} = {'case', _, NewPattern, {typed, _, {block, _, NewRest}, _}} =
infer_case(Env, Attrs, Pattern, PatType, {block, Attrs, Rest}, BlockType), infer_case(Env, Attrs, Pattern, PatType, {block, Attrs, Rest}, BlockType),
[{letval, Attrs, NewPattern, Type, NewE}|NewRest]; [{letval, Attrs, NewPattern, NewE}|NewRest];
infer_block(Env, Attrs, [E|Rest], BlockType) -> infer_block(Env, Attrs, [E|Rest], BlockType) ->
[infer_expr(Env, E)|infer_block(Env, Attrs, Rest, BlockType)]. [infer_expr(Env, E)|infer_block(Env, Attrs, Rest, BlockType)].
@ -1481,18 +1494,13 @@ infer_prefix({IntOp,As}) when IntOp =:= '-' ->
abort_expr(Ann, Str) -> abort_expr(Ann, Str) ->
{app, Ann, {id, Ann, "abort"}, [{string, Ann, Str}]}. {app, Ann, {id, Ann, "abort"}, [{string, Ann, Str}]}.
free_vars({int, _, _}) -> free_vars({int, _, _}) -> [];
[]; free_vars({char, _, _}) -> [];
free_vars({char, _, _}) -> free_vars({string, _, _}) -> [];
[]; free_vars({bool, _, _}) -> [];
free_vars({string, _, _}) -> free_vars(Id={id, _, _}) -> [Id];
[]; free_vars({con, _, _}) -> [];
free_vars({bool, _, _}) -> free_vars({qcon, _, _}) -> [];
[];
free_vars(Id={id, _, _}) ->
[Id];
free_vars({con, _, _}) ->
[];
free_vars({tuple, _, Cpts}) -> free_vars({tuple, _, Cpts}) ->
free_vars(Cpts); free_vars(Cpts);
free_vars({list, _, Elems}) -> free_vars({list, _, Elems}) ->
@ -1501,6 +1509,8 @@ free_vars({app, _, {'::', _}, Args}) ->
free_vars(Args); free_vars(Args);
free_vars({app, _, {con, _, _}, Args}) -> free_vars({app, _, {con, _, _}, Args}) ->
free_vars(Args); free_vars(Args);
free_vars({app, _, {qcon, _, _}, Args}) ->
free_vars(Args);
free_vars({record, _, Fields}) -> free_vars({record, _, Fields}) ->
free_vars([E || {field, _, _, E} <- Fields]); free_vars([E || {field, _, _, E} <- Fields]);
free_vars({typed, _, A, _}) -> free_vars({typed, _, A, _}) ->
@ -2507,6 +2517,14 @@ mk_error({compiler_version_mismatch, Ann, Version, Op, Bound}) ->
"because it does not satisfy the constraint" "because it does not satisfy the constraint"
" ~s ~s ~s\n", [PrintV(Version), Op, PrintV(Bound)]), " ~s ~s ~s\n", [PrintV(Version), Op, PrintV(Bound)]),
mk_t_err(pos(Ann), Msg); mk_t_err(pos(Ann), Msg);
mk_error({empty_record_or_map_update, Expr}) ->
Msg = io_lib:format("Empty record/map update\n~s",
[pp_expr(" ", Expr)]),
mk_t_err(pos(Expr), Msg);
mk_error({mixed_record_and_map, Expr}) ->
Msg = io_lib:format("Mixed record fields and map keys in\n~s",
[pp_expr(" ", Expr)]),
mk_t_err(pos(Expr), Msg);
mk_error(Err) -> mk_error(Err) ->
Msg = io_lib:format("Unknown error: ~p\n", [Err]), Msg = io_lib:format("Unknown error: ~p\n", [Err]),
mk_t_err(pos(0, 0), Msg). mk_t_err(pos(0, 0), Msg).

582
src/aeso_ast_to_fcode.erl
View File

@ -24,6 +24,8 @@
-type var_name() :: string(). -type var_name() :: string().
-type sophia_name() :: [string()]. -type sophia_name() :: [string()].
-type state_reg() :: pos_integer().
-type builtin() :: atom(). -type builtin() :: atom().
-type op() :: '+' | '-' | '*' | '/' | mod | '^' | '++' | '::' | -type op() :: '+' | '-' | '*' | '/' | mod | '^' | '++' | '::' |
@ -68,6 +70,8 @@
| {funcall, fexpr(), [fexpr()]} %% Call to unknown function | {funcall, fexpr(), [fexpr()]} %% Call to unknown function
| {closure, fun_name(), fexpr()} | {closure, fun_name(), fexpr()}
| {switch, fsplit()} | {switch, fsplit()}
| {set_state, state_reg(), fexpr()}
| {get_state, state_reg()}
%% The following (unapplied top-level functions/builtins and %% The following (unapplied top-level functions/builtins and
%% lambdas) are generated by the fcode compiler, but translated %% lambdas) are generated by the fcode compiler, but translated
%% to closures by the lambda lifter. %% to closures by the lambda lifter.
@ -116,6 +120,7 @@
-type fcode() :: #{ contract_name := string(), -type fcode() :: #{ contract_name := string(),
state_type := ftype(), state_type := ftype(),
state_layout := state_layout(),
event_type := ftype() | none, event_type := ftype() | none,
functions := #{ fun_name() => fun_def() }, functions := #{ fun_name() => fun_def() },
payable := boolean() }. payable := boolean() }.
@ -137,15 +142,18 @@
| {namespace, string()} | {namespace, string()}
| {abstract_contract, string()}. | {abstract_contract, string()}.
-type env() :: #{ type_env := type_env(), -type state_layout() :: {tuple, [state_layout()]} | {reg, state_reg()}.
fun_env := fun_env(),
con_env := con_env(), -type env() :: #{ type_env := type_env(),
event_type => aeso_syntax:typedef(), fun_env := fun_env(),
builtins := builtins(), con_env := con_env(),
options := [option()], event_type => aeso_syntax:typedef(),
context => context(), builtins := builtins(),
vars => [var_name()], options := [option()],
functions := #{ fun_name() => fun_def() } }. state_layout => state_layout(),
context => context(),
vars => [var_name()],
functions := #{ fun_name() => fun_def() } }.
-define(HASH_BYTES, 32). -define(HASH_BYTES, 32).
@ -156,12 +164,14 @@
-spec ast_to_fcode(aeso_syntax:ast(), [option()]) -> fcode(). -spec ast_to_fcode(aeso_syntax:ast(), [option()]) -> fcode().
ast_to_fcode(Code, Options) -> ast_to_fcode(Code, Options) ->
Verbose = lists:member(pp_fcode, Options), Verbose = lists:member(pp_fcode, Options),
init_fresh_names(),
FCode1 = to_fcode(init_env(Options), Code), FCode1 = to_fcode(init_env(Options), Code),
[io:format("-- Before lambda lifting --\n~s\n\n", [format_fcode(FCode1)]) || Verbose], [io:format("-- Before lambda lifting --\n~s\n\n", [format_fcode(FCode1)]) || Verbose],
FCode2 = lambda_lift(FCode1), FCode2 = optimize_fcode(FCode1),
[ io:format("-- After lambda lifting --\n~s\n\n", [format_fcode(FCode2)]) || Verbose, FCode2 /= FCode1 ], [ io:format("-- After optimization --\n~s\n\n", [format_fcode(FCode2)]) || Verbose, FCode2 /= FCode1 ],
FCode3 = optimize_fcode(FCode2), FCode3 = lambda_lift(FCode2),
[ io:format("-- After optimization --\n~s\n\n", [format_fcode(FCode3)]) || Verbose, FCode3 /= FCode2 ], [ io:format("-- After lambda lifting --\n~s\n\n", [format_fcode(FCode3)]) || Verbose, FCode3 /= FCode2 ],
clear_fresh_names(),
FCode3. FCode3.
%% -- Environment ------------------------------------------------------------ %% -- Environment ------------------------------------------------------------
@ -221,6 +231,8 @@ builtins() ->
|| {NS, Funs} <- Scopes, || {NS, Funs} <- Scopes,
{Fun, Arity} <- Funs ]). {Fun, Arity} <- Funs ]).
state_layout(Env) -> maps:get(state_layout, Env, {reg, 1}).
-define(type(T), fun([]) -> T end). -define(type(T), fun([]) -> T end).
-define(type(X, T), fun([X]) -> T end). -define(type(X, T), fun([X]) -> T end).
-define(type(X, Y, T), fun([X, Y]) -> T end). -define(type(X, Y, T), fun([X, Y]) -> T end).
@ -247,7 +259,13 @@ init_type_env() ->
}. }.
is_no_code(Env) -> is_no_code(Env) ->
proplists:get_value(no_code, maps:get(options, Env, []), false). get_option(no_code, Env).
get_option(Opt, Env) ->
get_option(Opt, Env, false).
get_option(Opt, Env, Default) ->
proplists:get_value(Opt, maps:get(options, Env, []), Default).
%% -- Compilation ------------------------------------------------------------ %% -- Compilation ------------------------------------------------------------
@ -260,11 +278,13 @@ to_fcode(Env, [{contract, Attrs, MainCon = {con, _, Main}, Decls}]) ->
[Main, "Chain", "event"] => {chain_event, 1}} }, [Main, "Chain", "event"] => {chain_event, 1}} },
#{ functions := Funs } = Env1 = #{ functions := Funs } = Env1 =
decls_to_fcode(MainEnv, Decls), decls_to_fcode(MainEnv, Decls),
StateType = lookup_type(Env1, [Main, "state"], [], {tuple, []}), StateType = lookup_type(Env1, [Main, "state"], [], {tuple, []}),
EventType = lookup_type(Env1, [Main, "event"], [], none), EventType = lookup_type(Env1, [Main, "event"], [], none),
Payable = proplists:get_value(payable, Attrs, false), StateLayout = state_layout(Env1),
Payable = proplists:get_value(payable, Attrs, false),
#{ contract_name => Main, #{ contract_name => Main,
state_type => StateType, state_type => StateType,
state_layout => StateLayout,
event_type => EventType, event_type => EventType,
payable => Payable, payable => Payable,
functions => add_init_function(Env1, MainCon, StateType, functions => add_init_function(Env1, MainCon, StateType,
@ -284,9 +304,7 @@ decls_to_fcode(Env, Decls) ->
%% environment. %% environment.
Env1 = add_fun_env(Env, Decls), Env1 = add_fun_env(Env, Decls),
lists:foldl(fun(D, E) -> lists:foldl(fun(D, E) ->
init_fresh_names(),
R = decl_to_fcode(E, D), R = decl_to_fcode(E, D),
clear_fresh_names(),
R R
end, Env1, Decls). end, Env1, Decls).
@ -322,14 +340,15 @@ typedef_to_fcode(Env, Id = {id, _, Name}, Xs, Def) ->
FDef = fun(Args) when length(Args) == length(Xs) -> FDef = fun(Args) when length(Args) == length(Xs) ->
Sub = maps:from_list(lists:zip([X || {tvar, _, X} <- Xs], Args)), Sub = maps:from_list(lists:zip([X || {tvar, _, X} <- Xs], Args)),
case Def of case Def of
{record_t, Fields} -> {todo, Xs, Args, record_t, Fields}; {record_t, Fields} ->
{tuple, [type_to_fcode(Env, Sub, T) || {field_t, _, _, T} <- Fields]};
{variant_t, Cons} -> {variant_t, Cons} ->
FCons = [ begin FCons = [ begin
{constr_t, _, _, Ts} = Con, {constr_t, _, _, Ts} = Con,
[type_to_fcode(Env, Sub, T) || T <- Ts] [type_to_fcode(Env, Sub, T) || T <- Ts]
end || Con <- Cons ], end || Con <- Cons ],
{variant, FCons}; {variant, FCons};
{alias_t, Type} -> {todo, Xs, Args, alias_t, Type} {alias_t, Type} -> type_to_fcode(Env, Sub, Type)
end; end;
(Args) -> internal_error({type_arity_mismatch, Name, length(Args), length(Xs)}) (Args) -> internal_error({type_arity_mismatch, Name, length(Args), length(Xs)})
end, end,
@ -351,7 +370,34 @@ typedef_to_fcode(Env, Id = {id, _, Name}, Xs, Def) ->
"event" -> Env1#{ event_type => Def }; "event" -> Env1#{ event_type => Def };
_ -> Env1 _ -> Env1
end, end,
bind_type(Env2, Q, FDef). Env3 = compute_state_layout(Env2, Name, FDef),
bind_type(Env3, Q, FDef).
compute_state_layout(Env = #{ context := {main_contract, _} }, "state", Type) ->
NoLayout = get_option(no_flatten_state, Env),
Layout =
case Type([]) of
_ when NoLayout -> {reg, 1};
T ->
{_, L} = compute_state_layout(1, T),
L
end,
Env#{ state_layout => Layout };
compute_state_layout(Env, _, _) -> Env.
compute_state_layout(R, {tuple, [T]}) ->
compute_state_layout(R, T);
compute_state_layout(R, {tuple, Ts}) ->
{R1, Ls} = compute_state_layout(R, Ts),
{R1, {tuple, Ls}};
compute_state_layout(R, []) ->
{R, []};
compute_state_layout(R, [H | T]) ->
{R1, H1} = compute_state_layout(R, H),
{R2, T1} = compute_state_layout(R1, T),
{R2, [H1 | T1]};
compute_state_layout(R, _) ->
{R + 1, {reg, R}}.
check_state_and_event_types(#{ context := {main_contract, _} }, Id, [_ | _]) -> check_state_and_event_types(#{ context := {main_contract, _} }, Id, [_ | _]) ->
case Id of case Id of
@ -404,6 +450,13 @@ make_let(Expr, Body) ->
{'let', X, Expr, Body({var, X})} {'let', X, Expr, Body({var, X})}
end. end.
let_bind(X, {var, Y}, Body) -> rename([{X, Y}], Body);
let_bind(X, Expr, Body) -> {'let', X, Expr, Body}.
let_bind(Binds, Body) ->
lists:foldr(fun({X, E}, Rest) -> let_bind(X, E, Rest) end,
Body, Binds).
-spec expr_to_fcode(env(), aeso_syntax:expr()) -> fexpr(). -spec expr_to_fcode(env(), aeso_syntax:expr()) -> fexpr().
expr_to_fcode(Env, {typed, _, Expr, Type}) -> expr_to_fcode(Env, {typed, _, Expr, Type}) ->
expr_to_fcode(Env, Type, Expr); expr_to_fcode(Env, Type, Expr);
@ -464,7 +517,7 @@ expr_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Args}) when C
%% Tuples %% Tuples
expr_to_fcode(Env, _Type, {tuple, _, Es}) -> expr_to_fcode(Env, _Type, {tuple, _, Es}) ->
{tuple, [expr_to_fcode(Env, E) || E <- Es]}; make_tuple([expr_to_fcode(Env, E) || E <- Es]);
%% Records %% Records
expr_to_fcode(Env, Type, {proj, _Ann, Rec = {typed, _, _, RecType}, {id, _, X}}) -> expr_to_fcode(Env, Type, {proj, _Ann, Rec = {typed, _, _, RecType}, {id, _, X}}) ->
@ -476,18 +529,28 @@ expr_to_fcode(Env, Type, {proj, _Ann, Rec = {typed, _, _, RecType}, {id, _, X}})
FArgs = [type_to_fcode(Env, Arg) || Arg <- Args], FArgs = [type_to_fcode(Env, Arg) || Arg <- Args],
{remote_u, FArgs, type_to_fcode(Env, Ret), expr_to_fcode(Env, Rec), {remote_u, FArgs, type_to_fcode(Env, Ret), expr_to_fcode(Env, Rec),
{entrypoint, list_to_binary(X)}}; {entrypoint, list_to_binary(X)}};
{record_t, [_]} -> expr_to_fcode(Env, Rec); %% Singleton record
{record_t, _} -> {record_t, _} ->
{proj, expr_to_fcode(Env, Rec), field_index(Rec, X)} {proj, expr_to_fcode(Env, Rec), field_index(Rec, X)}
end; end;
expr_to_fcode(Env, {record_t, [FieldT]}, {record, _Ann, [_] = Fields}) ->
{set, E} = field_value(FieldT, Fields),
expr_to_fcode(Env, E);
expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Fields}) -> expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Fields}) ->
FVal = fun(F) -> FVal = fun(F) ->
%% All fields are present and no updates %% All fields are present and no updates
{set, E} = field_value(F, Fields), {set, E} = field_value(F, Fields),
expr_to_fcode(Env, E) expr_to_fcode(Env, E)
end, end,
{tuple, lists:map(FVal, FieldTypes)}; make_tuple(lists:map(FVal, FieldTypes));
expr_to_fcode(Env, {record_t, [FieldT]}, {record, _Ann, Rec, Fields}) ->
case field_value(FieldT, Fields) of
false -> expr_to_fcode(Env, Rec);
{set, E} -> expr_to_fcode(Env, E);
{upd, Z, E} -> {'let', Z, expr_to_fcode(Env, Rec), expr_to_fcode(bind_var(Env, Z), E)}
end;
expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Rec, Fields}) -> expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Rec, Fields}) ->
X = fresh_name(), X = fresh_name(),
Proj = fun(I) -> {proj, {var, X}, I - 1} end, Proj = fun(I) -> {proj, {var, X}, I - 1} end,
@ -519,9 +582,12 @@ expr_to_fcode(Env, _Type, {app, _, {'..', _}, [A, B]}) ->
expr_to_fcode(Env, _Type, {list_comp, _, Yield, []}) -> expr_to_fcode(Env, _Type, {list_comp, _, Yield, []}) ->
{op, '::', [expr_to_fcode(Env, Yield), nil]}; {op, '::', [expr_to_fcode(Env, Yield), nil]};
expr_to_fcode(Env, _Type, {list_comp, As, Yield, [{comprehension_bind, {typed, {id, _, Arg}, _}, BindExpr}|Rest]}) -> expr_to_fcode(Env, _Type, {list_comp, As, Yield, [{comprehension_bind, Pat = {typed, _, _, PatType}, BindExpr}|Rest]}) ->
Arg = fresh_name(),
Env1 = bind_var(Env, Arg), Env1 = bind_var(Env, Arg),
Bind = {lam, [Arg], expr_to_fcode(Env1, {list_comp, As, Yield, Rest})}, Bind = {lam, [Arg], expr_to_fcode(Env1, {switch, As, {typed, As, {id, As, Arg}, PatType},
[{'case', As, Pat, {list_comp, As, Yield, Rest}},
{'case', As, {id, As, "_"}, {list, As, []}}]})},
{def_u, FlatMap, _} = resolve_fun(Env, ["ListInternal", "flat_map"]), {def_u, FlatMap, _} = resolve_fun(Env, ["ListInternal", "flat_map"]),
{def, FlatMap, [Bind, expr_to_fcode(Env, BindExpr)]}; {def, FlatMap, [Bind, expr_to_fcode(Env, BindExpr)]};
expr_to_fcode(Env, Type, {list_comp, As, Yield, [{comprehension_if, _, Cond}|Rest]}) -> expr_to_fcode(Env, Type, {list_comp, As, Yield, [{comprehension_if, _, Cond}|Rest]}) ->
@ -529,7 +595,7 @@ expr_to_fcode(Env, Type, {list_comp, As, Yield, [{comprehension_if, _, Cond}|Res
expr_to_fcode(Env, Type, {list_comp, As, Yield, Rest}), expr_to_fcode(Env, Type, {list_comp, As, Yield, Rest}),
nil nil
); );
expr_to_fcode(Env, Type, {list_comp, As, Yield, [LV = {letval, _, _, _, _}|Rest]}) -> expr_to_fcode(Env, Type, {list_comp, As, Yield, [LV = {letval, _, _, _}|Rest]}) ->
expr_to_fcode(Env, Type, {block, As, [LV, {list_comp, As, Yield, Rest}]}); expr_to_fcode(Env, Type, {block, As, [LV, {list_comp, As, Yield, Rest}]});
expr_to_fcode(Env, Type, {list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}) -> expr_to_fcode(Env, Type, {list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}) ->
expr_to_fcode(Env, Type, {block, As, [LF, {list_comp, As, Yield, Rest}]}); expr_to_fcode(Env, Type, {block, As, [LF, {list_comp, As, Yield, Rest}]});
@ -574,8 +640,8 @@ expr_to_fcode(Env, _Type, {app, _, Fun = {typed, _, _, {fun_t, _, NamedArgsT, _,
Args1 = get_named_args(NamedArgsT, Args), Args1 = get_named_args(NamedArgsT, Args),
FArgs = [expr_to_fcode(Env, Arg) || Arg <- Args1], FArgs = [expr_to_fcode(Env, Arg) || Arg <- Args1],
case expr_to_fcode(Env, Fun) of case expr_to_fcode(Env, Fun) of
{builtin_u, B, _Ar, TypeArgs} -> builtin_to_fcode(B, FArgs ++ TypeArgs); {builtin_u, B, _Ar, TypeArgs} -> builtin_to_fcode(state_layout(Env), B, FArgs ++ TypeArgs);
{builtin_u, B, _Ar} -> builtin_to_fcode(B, FArgs); {builtin_u, B, _Ar} -> builtin_to_fcode(state_layout(Env), B, FArgs);
{def_u, F, _Ar} -> {def, F, FArgs}; {def_u, F, _Ar} -> {def, F, FArgs};
{remote_u, ArgsT, RetT, Ct, RFun} -> {remote, ArgsT, RetT, Ct, RFun, FArgs}; {remote_u, ArgsT, RetT, Ct, RFun} -> {remote, ArgsT, RetT, Ct, RFun, FArgs};
FFun -> FFun ->
@ -639,6 +705,13 @@ make_if(Cond, Then, Else) ->
X = fresh_name(), X = fresh_name(),
{'let', X, Cond, make_if({var, X}, Then, Else)}. {'let', X, Cond, make_if({var, X}, Then, Else)}.
-spec make_tuple([fexpr()]) -> fexpr().
make_tuple([E]) -> E;
make_tuple(Es) -> {tuple, Es}.
-spec strip_singleton_tuples(ftype()) -> ftype().
strip_singleton_tuples({tuple, [T]}) -> strip_singleton_tuples(T);
strip_singleton_tuples(T) -> T.
get_oracle_type(oracle_register, {fun_t, _, _, _, OType}) -> OType; get_oracle_type(oracle_register, {fun_t, _, _, _, OType}) -> OType;
get_oracle_type(oracle_query, {fun_t, _, _, [OType | _], _}) -> OType; get_oracle_type(oracle_query, {fun_t, _, _, [OType | _], _}) -> OType;
@ -726,10 +799,13 @@ split_tree(Env, Vars, Alts = [{'case', Pats, Body} | _]) ->
{nosplit, rename(Ren, Body)}; {nosplit, rename(Ren, Body)};
I when is_integer(I) -> I when is_integer(I) ->
{Vars0, [{X, Type} | Vars1]} = lists:split(I - 1, Vars), {Vars0, [{X, Type} | Vars1]} = lists:split(I - 1, Vars),
Type1 = strip_singleton_tuples(Type),
SAlts = merge_alts(I, X, [ split_alt(I, A) || A <- Alts ]), SAlts = merge_alts(I, X, [ split_alt(I, A) || A <- Alts ]),
Cases = [ {'case', SPat, split_tree(Env, Vars0 ++ split_vars(SPat, Type) ++ Vars1, FAlts)} MakeCase = fun({var, Z}, Split) -> {'case', {var, "_"}, rename_split([{Z, X}], Split)};
(SPat, Split) -> {'case', SPat, Split} end,
Cases = [ MakeCase(SPat, split_tree(Env, Vars0 ++ split_vars(SPat, Type1) ++ Vars1, FAlts))
|| {SPat, FAlts} <- SAlts ], || {SPat, FAlts} <- SAlts ],
{split, Type, X, Cases} {split, Type1, X, Cases}
end. end.
-spec merge_alts(integer(), var_name(), [{fsplit_pat(), falt()}]) -> [{fsplit_pat(), [falt()]}]. -spec merge_alts(integer(), var_name(), [{fsplit_pat(), falt()}]) -> [{fsplit_pat(), [falt()]}].
@ -852,7 +928,7 @@ pat_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Pats}) when C
#con_tag{tag = I, arities = As} = lookup_con(Env, Con), #con_tag{tag = I, arities = As} = lookup_con(Env, Con),
{con, As, I, [pat_to_fcode(Env, Pat) || Pat <- Pats]}; {con, As, I, [pat_to_fcode(Env, Pat) || Pat <- Pats]};
pat_to_fcode(Env, _Type, {tuple, _, Pats}) -> pat_to_fcode(Env, _Type, {tuple, _, Pats}) ->
{tuple, [ pat_to_fcode(Env, Pat) || Pat <- Pats ]}; make_tuple([ pat_to_fcode(Env, Pat) || Pat <- Pats ]);
pat_to_fcode(_Env, _Type, {bool, _, B}) -> {bool, B}; pat_to_fcode(_Env, _Type, {bool, _, B}) -> {bool, B};
pat_to_fcode(_Env, _Type, {int, _, N}) -> {int, N}; pat_to_fcode(_Env, _Type, {int, _, N}) -> {int, N};
pat_to_fcode(_Env, _Type, {char, _, N}) -> {int, N}; pat_to_fcode(_Env, _Type, {char, _, N}) -> {int, N};
@ -870,8 +946,8 @@ pat_to_fcode(Env, {record_t, Fields}, {record, _, FieldPats}) ->
{set, Pat} -> Pat {set, Pat} -> Pat
%% {upd, _, _} is impossible in patterns %% {upd, _, _} is impossible in patterns
end end, end end,
{tuple, [pat_to_fcode(Env, FieldPat(Field)) make_tuple([pat_to_fcode(Env, FieldPat(Field))
|| Field <- Fields]}; || Field <- Fields]);
pat_to_fcode(_Env, Type, Pat) -> pat_to_fcode(_Env, Type, Pat) ->
error({todo, Pat, ':', Type}). error({todo, Pat, ':', Type}).
@ -905,8 +981,10 @@ decision_tree_to_fcode({'if', A, Then, Else}) ->
%% -- Statements -- %% -- Statements --
-spec stmts_to_fcode(env(), [aeso_syntax:stmt()]) -> fexpr(). -spec stmts_to_fcode(env(), [aeso_syntax:stmt()]) -> fexpr().
stmts_to_fcode(Env, [{letval, _, {typed, _, {id, _, X}, _}, _, Expr} | Stmts]) -> stmts_to_fcode(Env, [{letval, _, {typed, _, {id, _, X}, _}, Expr} | Stmts]) ->
{'let', X, expr_to_fcode(Env, Expr), stmts_to_fcode(bind_var(Env, X), Stmts)}; {'let', X, expr_to_fcode(Env, Expr), stmts_to_fcode(bind_var(Env, X), Stmts)};
stmts_to_fcode(Env, [{letval, Ann, Pat, Expr} | Stmts]) ->
expr_to_fcode(Env, {switch, Ann, Expr, [{'case', Ann, Pat, {block, Ann, Stmts}}]});
stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, Expr} | Stmts]) -> stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, Expr} | Stmts]) ->
{'let', X, expr_to_fcode(Env, {lam, Ann, Args, Expr}), {'let', X, expr_to_fcode(Env, {lam, Ann, Args, Expr}),
stmts_to_fcode(bind_var(Env, X), Stmts)}; stmts_to_fcode(bind_var(Env, X), Stmts)};
@ -934,23 +1012,40 @@ op_builtins() ->
mcl_bls12_381_int_to_fr, mcl_bls12_381_int_to_fp, mcl_bls12_381_fr_to_int, mcl_bls12_381_fp_to_int mcl_bls12_381_int_to_fr, mcl_bls12_381_int_to_fp, mcl_bls12_381_fr_to_int, mcl_bls12_381_fp_to_int
]. ].
builtin_to_fcode(require, [Cond, Msg]) -> set_state({reg, R}, Val) ->
{set_state, R, Val};
set_state({tuple, Ls}, Val) ->
?make_let(X, Val,
lists:foldr(fun({I, L}, Code) ->
{'let', "_", set_state(L, {proj, X, I - 1}), Code}
end, {tuple, []}, indexed(Ls))).
get_state({reg, R}) ->
{get_state, R};
get_state({tuple, Ls}) ->
{tuple, [get_state(L) || L <- Ls]}.
builtin_to_fcode(Layout, set_state, [Val]) ->
set_state(Layout, Val);
builtin_to_fcode(Layout, get_state, []) ->
get_state(Layout);
builtin_to_fcode(_Layout, require, [Cond, Msg]) ->
make_if(Cond, {tuple, []}, {builtin, abort, [Msg]}); make_if(Cond, {tuple, []}, {builtin, abort, [Msg]});
builtin_to_fcode(chain_event, [Event]) -> builtin_to_fcode(_Layout, chain_event, [Event]) ->
{def, event, [Event]}; {def, event, [Event]};
builtin_to_fcode(map_delete, [Key, Map]) -> builtin_to_fcode(_Layout, map_delete, [Key, Map]) ->
{op, map_delete, [Map, Key]}; {op, map_delete, [Map, Key]};
builtin_to_fcode(map_member, [Key, Map]) -> builtin_to_fcode(_Layout, map_member, [Key, Map]) ->
{op, map_member, [Map, Key]}; {op, map_member, [Map, Key]};
builtin_to_fcode(map_lookup, [Key0, Map0]) -> builtin_to_fcode(_Layout, map_lookup, [Key0, Map0]) ->
?make_let(Key, Key0, ?make_let(Key, Key0,
?make_let(Map, Map0, ?make_let(Map, Map0,
make_if({op, map_member, [Map, Key]}, make_if({op, map_member, [Map, Key]},
{con, [0, 1], 1, [{op, map_get, [Map, Key]}]}, {con, [0, 1], 1, [{op, map_get, [Map, Key]}]},
{con, [0, 1], 0, []}))); {con, [0, 1], 0, []})));
builtin_to_fcode(map_lookup_default, [Key, Map, Def]) -> builtin_to_fcode(_Layout, map_lookup_default, [Key, Map, Def]) ->
{op, map_get_d, [Map, Key, Def]}; {op, map_get_d, [Map, Key, Def]};
builtin_to_fcode(Builtin, Args) -> builtin_to_fcode(_Layout, Builtin, Args) ->
case lists:member(Builtin, op_builtins()) of case lists:member(Builtin, op_builtins()) of
true -> {op, Builtin, Args}; true -> {op, Builtin, Args};
false -> {builtin, Builtin, Args} false -> {builtin, Builtin, Args}
@ -965,8 +1060,9 @@ add_init_function(Env, Main, StateType, Funs0) ->
Funs = add_default_init_function(Env, Main, StateType, Funs0), Funs = add_default_init_function(Env, Main, StateType, Funs0),
InitName = {entrypoint, <<"init">>}, InitName = {entrypoint, <<"init">>},
InitFun = #{ body := InitBody} = maps:get(InitName, Funs), InitFun = #{ body := InitBody} = maps:get(InitName, Funs),
Funs#{ InitName => InitFun#{ return => {tuple, []}, Funs1 = Funs#{ InitName => InitFun#{ return => {tuple, []},
body => {builtin, set_state, [InitBody]} } } body => builtin_to_fcode(state_layout(Env), set_state, [InitBody]) } },
Funs1
end. end.
add_default_init_function(_Env, Main, StateType, Funs) -> add_default_init_function(_Env, Main, StateType, Funs) ->
@ -1017,12 +1113,10 @@ event_function(_Env = #{event_type := {variant_t, EventCons}}, EventType = {vari
%% the top-level and replace it with a closure. %% the top-level and replace it with a closure.
-spec lambda_lift(fcode()) -> fcode(). -spec lambda_lift(fcode()) -> fcode().
lambda_lift(FCode = #{ functions := Funs }) -> lambda_lift(FCode = #{ functions := Funs, state_layout := StateLayout }) ->
init_fresh_names(),
init_lambda_funs(), init_lambda_funs(),
Funs1 = maps:map(fun lambda_lift_fun/2, Funs), Funs1 = maps:map(fun(_, Body) -> lambda_lift_fun(StateLayout, Body) end, Funs),
NewFuns = get_lambda_funs(), NewFuns = get_lambda_funs(),
clear_fresh_names(),
FCode#{ functions := maps:merge(Funs1, NewFuns) }. FCode#{ functions := maps:merge(Funs1, NewFuns) }.
-define(lambda_key, '%lambdalifted'). -define(lambda_key, '%lambdalifted').
@ -1035,8 +1129,8 @@ add_lambda_fun(Def) ->
put(?lambda_key, Funs#{ Name => Def }), put(?lambda_key, Funs#{ Name => Def }),
Name. Name.
lambda_lift_fun(_, Def = #{ body := Body }) -> lambda_lift_fun(Layout, Def = #{ body := Body }) ->
Def#{ body := lambda_lift_expr(Body) }. Def#{ body := lambda_lift_expr(Layout, Body) }.
lifted_fun([Z], Xs, Body) -> lifted_fun([Z], Xs, Body) ->
#{ attrs => [private], #{ attrs => [private],
@ -1057,10 +1151,10 @@ make_closure(FVs, Xs, Body) ->
Tup = fun([Y]) -> Y; (Ys) -> {tuple, Ys} end, Tup = fun([Y]) -> Y; (Ys) -> {tuple, Ys} end,
{closure, Fun, Tup([{var, Y} || Y <- FVs])}. {closure, Fun, Tup([{var, Y} || Y <- FVs])}.
lambda_lift_expr({lam, Xs, Body}) -> lambda_lift_expr(Layout, {lam, Xs, Body}) ->
FVs = free_vars({lam, Xs, Body}), FVs = free_vars({lam, Xs, Body}),
make_closure(FVs, Xs, lambda_lift_expr(Body)); make_closure(FVs, Xs, lambda_lift_expr(Layout, Body));
lambda_lift_expr(UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == builtin_u -> lambda_lift_expr(Layout, UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == builtin_u ->
[Tag, F, Ar | _] = tuple_to_list(UExpr), [Tag, F, Ar | _] = tuple_to_list(UExpr),
ExtraArgs = case UExpr of ExtraArgs = case UExpr of
{builtin_u, _, _, TypeArgs} -> TypeArgs; {builtin_u, _, _, TypeArgs} -> TypeArgs;
@ -1069,40 +1163,42 @@ lambda_lift_expr(UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == bu
Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, Ar) ], Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, Ar) ],
Args = [{var, X} || X <- Xs] ++ ExtraArgs, Args = [{var, X} || X <- Xs] ++ ExtraArgs,
Body = case Tag of Body = case Tag of
builtin_u -> builtin_to_fcode(F, Args); builtin_u -> builtin_to_fcode(Layout, F, Args);
def_u -> {def, F, Args} def_u -> {def, F, Args}
end, end,
make_closure([], Xs, Body); make_closure([], Xs, Body);
lambda_lift_expr({remote_u, ArgsT, RetT, Ct, F}) -> lambda_lift_expr(Layout, {remote_u, ArgsT, RetT, Ct, F}) ->
FVs = free_vars(Ct), FVs = free_vars(Ct),
Ct1 = lambda_lift_expr(Ct), Ct1 = lambda_lift_expr(Layout, Ct),
GasAndValueArgs = 2, GasAndValueArgs = 2,
Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, length(ArgsT) + GasAndValueArgs) ], Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, length(ArgsT) + GasAndValueArgs) ],
Args = [{var, X} || X <- Xs], Args = [{var, X} || X <- Xs],
make_closure(FVs, Xs, {remote, ArgsT, RetT, Ct1, F, Args}); make_closure(FVs, Xs, {remote, ArgsT, RetT, Ct1, F, Args});
lambda_lift_expr(Expr) -> lambda_lift_expr(Layout, Expr) ->
case Expr of case Expr of
{lit, _} -> Expr; {lit, _} -> Expr;
nil -> Expr; nil -> Expr;
{var, _} -> Expr; {var, _} -> Expr;
{closure, _, _} -> Expr; {closure, _, _} -> Expr;
{def, D, As} -> {def, D, lambda_lift_exprs(As)}; {def, D, As} -> {def, D, lambda_lift_exprs(Layout, As)};
{builtin, B, As} -> {builtin, B, lambda_lift_exprs(As)}; {builtin, B, As} -> {builtin, B, lambda_lift_exprs(Layout, As)};
{remote, ArgsT, RetT, Ct, F, As} -> {remote, ArgsT, RetT, lambda_lift_expr(Ct), F, lambda_lift_exprs(As)}; {remote, ArgsT, RetT, Ct, F, As} -> {remote, ArgsT, RetT, lambda_lift_expr(Layout, Ct), F, lambda_lift_exprs(Layout, As)};
{con, Ar, C, As} -> {con, Ar, C, lambda_lift_exprs(As)}; {con, Ar, C, As} -> {con, Ar, C, lambda_lift_exprs(Layout, As)};
{tuple, As} -> {tuple, lambda_lift_exprs(As)}; {tuple, As} -> {tuple, lambda_lift_exprs(Layout, As)};
{proj, A, I} -> {proj, lambda_lift_expr(A), I}; {proj, A, I} -> {proj, lambda_lift_expr(Layout, A), I};
{set_proj, A, I, B} -> {set_proj, lambda_lift_expr(A), I, lambda_lift_expr(B)}; {set_proj, A, I, B} -> {set_proj, lambda_lift_expr(Layout, A), I, lambda_lift_expr(Layout, B)};
{op, Op, As} -> {op, Op, lambda_lift_exprs(As)}; {op, Op, As} -> {op, Op, lambda_lift_exprs(Layout, As)};
{'let', X, A, B} -> {'let', X, lambda_lift_expr(A), lambda_lift_expr(B)}; {'let', X, A, B} -> {'let', X, lambda_lift_expr(Layout, A), lambda_lift_expr(Layout, B)};
{funcall, A, Bs} -> {funcall, lambda_lift_expr(A), lambda_lift_exprs(Bs)}; {funcall, A, Bs} -> {funcall, lambda_lift_expr(Layout, A), lambda_lift_exprs(Layout, Bs)};
{switch, S} -> {switch, lambda_lift_expr(S)}; {set_state, R, A} -> {set_state, R, lambda_lift_expr(Layout, A)};
{split, Type, X, Alts} -> {split, Type, X, lambda_lift_exprs(Alts)}; {get_state, _} -> Expr;
{nosplit, A} -> {nosplit, lambda_lift_expr(A)}; {switch, S} -> {switch, lambda_lift_expr(Layout, S)};
{'case', P, S} -> {'case', P, lambda_lift_expr(S)} {split, Type, X, Alts} -> {split, Type, X, lambda_lift_exprs(Layout, Alts)};
{nosplit, A} -> {nosplit, lambda_lift_expr(Layout, A)};
{'case', P, S} -> {'case', P, lambda_lift_expr(Layout, S)}
end. end.
lambda_lift_exprs(As) -> [lambda_lift_expr(A) || A <- As]. lambda_lift_exprs(Layout, As) -> [lambda_lift_expr(Layout, A) || A <- As].
%% -- Optimisations ---------------------------------------------------------- %% -- Optimisations ----------------------------------------------------------
@ -1120,7 +1216,12 @@ optimize_fcode(Code = #{ functions := Funs }) ->
-spec optimize_fun(fcode(), fun_name(), fun_def()) -> fun_def(). -spec optimize_fun(fcode(), fun_name(), fun_def()) -> fun_def().
optimize_fun(Fcode, Fun, Def = #{ body := Body }) -> optimize_fun(Fcode, Fun, Def = #{ body := Body }) ->
%% io:format("Optimizing ~p =\n~s\n", [_Fun, prettypr:format(pp_fexpr(_Body))]), %% io:format("Optimizing ~p =\n~s\n", [_Fun, prettypr:format(pp_fexpr(_Body))]),
Def#{ body := inliner(Fcode, Fun, Body) }. Def#{ body := drop_unused_lets(
simplifier(
let_floating(
bind_subexpressions(
inline_local_functions(
inliner(Fcode, Fun, Body)))))) }.
%% --- Inlining --- %% --- Inlining ---
@ -1136,6 +1237,246 @@ should_inline(_Fcode, _Fun1) -> false == list_to_atom("true"). %% Dialyzer
inline(_Fcode, Fun, Args) -> {def, Fun, Args}. %% TODO inline(_Fcode, Fun, Args) -> {def, Fun, Args}. %% TODO
%% --- Bind subexpressions ---
-define(make_lets(Xs, Es, Body), make_lets(Es, fun(Xs) -> Body end)).
bind_subexpressions(Expr) ->
bottom_up(fun bind_subexpressions/2, Expr).
bind_subexpressions(_, {tuple, Es}) ->
?make_lets(Xs, Es, {tuple, Xs});
bind_subexpressions(_, {set_proj, A, I, B}) ->
?make_lets([X, Y], [A, B], {set_proj, X, I, Y});
bind_subexpressions(_, E) -> E.
make_lets(Es, Body) -> make_lets(Es, [], Body).
make_lets([], Xs, Body) -> Body(lists:reverse(Xs));
make_lets([{var, _} = E | Es], Xs, Body) ->
make_lets(Es, [E | Xs], Body);
make_lets([{lit, _} = E | Es], Xs, Body) ->
make_lets(Es, [E | Xs], Body);
make_lets([E | Es], Xs, Body) ->
?make_let(X, E, make_lets(Es, [X | Xs], Body)).
%% --- Inline local functions ---
inline_local_functions(Expr) ->
bottom_up(fun inline_local_functions/2, Expr).
inline_local_functions(Env, {funcall, {proj, {var, Y}, 0}, [{proj, {var, Y}, 1} | Args]} = Expr) ->
%% TODO: Don't always inline local funs?
case maps:get(Y, Env, free) of
{lam, Xs, Body} -> let_bind(lists:zip(Xs, Args), Body);
_ -> Expr
end;
inline_local_functions(_, Expr) -> Expr.
%% --- Let-floating ---
let_floating(Expr) -> bottom_up(fun let_float/2, Expr).
let_float(_, {'let', X, E, Body}) ->
pull_out_let({'let', X, {here, E}, Body});
let_float(_, {proj, E, I}) ->
pull_out_let({proj, {here, E}, I});
let_float(_, {set_proj, E, I, V}) ->
pull_out_let({set_proj, {here, E}, I, {here, V}});
let_float(_, {op, Op, Es}) ->
{Lets, Es1} = pull_out_let([{here, E} || E <- Es]),
let_bind(Lets, {op, Op, Es1});
let_float(_, E) -> E.
pull_out_let(Expr) when is_tuple(Expr) ->
{Lets, Es} = pull_out_let(tuple_to_list(Expr)),
Inner = list_to_tuple(Es),
let_bind(Lets, Inner);
pull_out_let(Es) when is_list(Es) ->
case lists:splitwith(fun({here, _}) -> false; (_) -> true end, Es) of
{Es0, [{here, E} | Es1]} ->
case let_view(E) of
{[], _} ->
{Lets, Es2} = pull_out_let(Es1),
{Lets, Es0 ++ [E] ++ Es2};
{Lets, E1} ->
{Lets1, Es2} = pull_out_let(Es1),
{Lets ++ Lets1, Es0 ++ [E1] ++ Es2}
end;
{_, []} -> {[], Es}
end.
%% Also renames the variables to fresh names
let_view(E) -> let_view(E, [], []).
let_view({'let', X, E, Rest}, Ren, Lets) ->
Z = fresh_name(),
let_view(Rest, [{X, Z} | Ren], [{Z, rename(Ren, E)} | Lets]);
let_view(E, Ren, Lets) ->
{lists:reverse(Lets), rename(Ren, E)}.
%% --- Simplification ---
-spec simplifier(fexpr()) -> fexpr().
simplifier(Expr) ->
bottom_up(fun simplify/2, Expr).
-spec simplify(#{var_name() => fexpr()}, fexpr()) -> fexpr().
%% (e₀, .., en).i ->
%% let _ = e₀ in .. let x = ei in .. let _ = en in x
simplify(_Env, {proj, {tuple, Es}, I}) ->
It = lists:nth(I + 1, Es),
X = fresh_name(),
Dup = safe_to_duplicate(It),
Val = if Dup -> It; true -> {var, X} end,
lists:foldr(
fun({J, E}, Rest) when I == J ->
case Dup of
true -> Rest;
false -> {'let', X, E, Rest}
end;
({_, E}, Rest) ->
case read_only(E) of
true -> Rest;
false -> {'let', "_", E, Rest}
end
end, Val, indexed(Es));
%% let x = e in .. x.i ..
simplify(Env, {proj, {var, X}, I} = Expr) ->
case simpl_proj(Env, I, {var, X}) of
false -> Expr;
E -> E
end;
simplify(Env, {switch, Split}) ->
case simpl_switch(Env, Split) of
nomatch -> {builtin, abort, [{lit, {string, <<"Incomplete patterns">>}}]};
stuck -> {switch, Split};
Expr -> Expr
end;
simplify(_, E) ->
E.
simpl_proj(Env, I, Expr) ->
IfSafe = fun(E) -> case safe_to_duplicate(E) of
true -> E;
false -> false
end end,
case Expr of
false -> false;
{var, X} -> simpl_proj(Env, I, maps:get(X, Env, false));
{tuple, Es} -> IfSafe(lists:nth(I + 1, Es));
{set_proj, _, I, Val} -> IfSafe(Val);
{set_proj, E, _, _} -> simpl_proj(Env, I, E);
{proj, E, J} -> simpl_proj(Env, I, simpl_proj(Env, J, E));
_ -> false
end.
simpl_switch(_Env, {nosplit, E}) -> E;
simpl_switch(Env, {split, _, X, Alts}) ->
case constructor_form(Env, {var, X}) of
false -> stuck;
E -> simpl_switch(Env, E, Alts)
end.
simpl_switch(_, _, []) -> nomatch;
simpl_switch(Env, E, [{'case', Pat, Body} | Alts]) ->
case match_pat(Pat, E) of
false -> simpl_switch(Env, E, Alts);
Binds ->
Env1 = maps:merge(Env, maps:from_list(Binds)),
case simpl_switch(Env1, Body) of
nomatch -> simpl_switch(Env, E, Alts);
stuck -> stuck;
Body1 -> let_bind(Binds, Body1)
end
end.
-spec match_pat(fsplit_pat(), fexpr()) -> false | [{var_name(), fexpr()}].
match_pat({tuple, Xs}, {tuple, Es}) -> lists:zip(Xs, Es);
match_pat({con, _, C, Xs}, {con, _, C, Es}) -> lists:zip(Xs, Es);
match_pat(L, {lit, L}) -> [];
match_pat(nil, nil) -> [];
match_pat({'::', X, Y}, {op, '::', [A, B]}) -> [{X, A}, {Y, B}];
match_pat({var, X}, E) -> [{X, E}];
match_pat(_, _) -> false.
constructor_form(Env, Expr) ->
case Expr of
{var, X} ->
case maps:get(X, Env, free) of
free -> false;
E -> constructor_form(Env, E) %% TODO: shadowing?
end;
{set_proj, E, I, V} ->
case constructor_form(Env, E) of
{tuple, Es} -> {tuple, setnth(I + 1, V, Es)};
_ -> false
end;
{proj, E, I} ->
case constructor_form(Env, E) of
{tuple, Es} -> constructor_form(Env, lists:nth(I + 1, Es));
_ -> false
end;
{con, _, _, _} -> Expr;
{tuple, _} -> Expr;
{lit, _} -> Expr;
nil -> Expr;
{op, '::', _} -> Expr;
_ -> false
end.
%% --- Drop unused lets ---
drop_unused_lets(Expr) -> bottom_up(fun drop_unused_lets/2, Expr).
drop_unused_lets(_, {'let', X, E, Body} = Expr) ->
case {read_only(E), not lists:member(X, free_vars(Body))} of
{true, true} -> Body;
{false, true} -> {'let', "_", E, Body};
_ -> Expr
end;
drop_unused_lets(_, Expr) -> Expr.
%% -- Static analysis --------------------------------------------------------
safe_to_duplicate({lit, _}) -> true;
safe_to_duplicate({var, _}) -> true;
safe_to_duplicate(nil) -> true;
safe_to_duplicate({tuple, []}) -> true;
safe_to_duplicate(_) -> false.
-spec read_only(fexpr() | fsplit() | fcase() | [fexpr()] | [fcase()]) -> boolean().
read_only({lit, _}) -> true;
read_only({var, _}) -> true;
read_only(nil) -> true;
read_only({con, _, _, Es}) -> read_only(Es);
read_only({tuple, Es}) -> read_only(Es);
read_only({proj, E, _}) -> read_only(E);
read_only({set_proj, A, _, B}) -> read_only([A, B]);
read_only({op, _, Es}) -> read_only(Es);
read_only({get_state, _}) -> true;
read_only({set_state, _, _}) -> false;
read_only({def_u, _, _}) -> true;
read_only({remote_u, _, _, _, _}) -> true;
read_only({builtin_u, _, _}) -> true;
read_only({builtin_u, _, _, _}) -> true;
read_only({lam, _, _}) -> true;
read_only({def, _, _}) -> false; %% TODO: purity analysis
read_only({remote, _, _, _, _, _}) -> false;
read_only({builtin, _, _}) -> false; %% TODO: some builtins are
read_only({switch, Split}) -> read_only(Split);
read_only({split, _, _, Cases}) -> read_only(Cases);
read_only({nosplit, E}) -> read_only(E);
read_only({'case', _, Split}) -> read_only(Split);
read_only({'let', _, A, B}) -> read_only([A, B]);
read_only({funcall, _, _}) -> false;
read_only({closure, _, _}) -> internal_error(no_closures_here);
read_only(Es) when is_list(Es) -> lists:all(fun read_only/1, Es).
%% --- Deadcode elimination --- %% --- Deadcode elimination ---
-spec eliminate_dead_code(fcode()) -> fcode(). -spec eliminate_dead_code(fcode()) -> fcode().
@ -1257,10 +1598,10 @@ resolve_var(#{ vars := Vars } = Env, [X]) ->
end; end;
resolve_var(Env, Q) -> resolve_fun(Env, Q). resolve_var(Env, Q) -> resolve_fun(Env, Q).
resolve_fun(#{ fun_env := Funs, builtins := Builtin }, Q) -> resolve_fun(#{ fun_env := Funs, builtins := Builtin } = Env, Q) ->
case {maps:get(Q, Funs, not_found), maps:get(Q, Builtin, not_found)} of case {maps:get(Q, Funs, not_found), maps:get(Q, Builtin, not_found)} of
{not_found, not_found} -> internal_error({unbound_variable, Q}); {not_found, not_found} -> internal_error({unbound_variable, Q});
{_, {B, none}} -> {builtin, B, []}; {_, {B, none}} -> builtin_to_fcode(state_layout(Env), B, []);
{_, {B, Ar}} -> {builtin_u, B, Ar}; {_, {B, Ar}} -> {builtin_u, B, Ar};
{{Fun, Ar}, _} -> {def_u, Fun, Ar} {{Fun, Ar}, _} -> {def_u, Fun, Ar}
end. end.
@ -1295,14 +1636,14 @@ pat_vars({con, _, _, Ps}) -> pat_vars(Ps);
pat_vars(Ps) when is_list(Ps) -> [X || P <- Ps, X <- pat_vars(P)]. pat_vars(Ps) when is_list(Ps) -> [X || P <- Ps, X <- pat_vars(P)].
-spec fsplit_pat_vars(fsplit_pat()) -> [var_name()]. -spec fsplit_pat_vars(fsplit_pat()) -> [var_name()].
fsplit_pat_vars({var, X}) -> [X || X /= "_"]; fsplit_pat_vars({var, X}) -> [X || X /= "_"];
fsplit_pat_vars({bool, _}) -> []; fsplit_pat_vars({bool, _}) -> [];
fsplit_pat_vars({int, _}) -> []; fsplit_pat_vars({int, _}) -> [];
fsplit_pat_vars({string, _}) -> []; fsplit_pat_vars({string, _}) -> [];
fsplit_pat_vars(nil) -> []; fsplit_pat_vars(nil) -> [];
fsplit_pat_vars({'::', P, Q}) -> [P, Q]; fsplit_pat_vars({'::', P, Q}) -> [P, Q];
fsplit_pat_vars({tuple, Ps}) -> Ps; fsplit_pat_vars({tuple, Ps}) -> Ps;
fsplit_pat_vars({con, _, _, Ps}) -> Ps. fsplit_pat_vars({con, _, _, Ps}) -> Ps.
free_vars(Xs) when is_list(Xs) -> free_vars(Xs) when is_list(Xs) ->
lists:umerge([ free_vars(X) || X <- Xs ]); lists:umerge([ free_vars(X) || X <- Xs ]);
@ -1325,6 +1666,8 @@ free_vars(Expr) ->
{op, _, As} -> free_vars(As); {op, _, As} -> free_vars(As);
{'let', X, A, B} -> free_vars([A, {lam, [X], B}]); {'let', X, A, B} -> free_vars([A, {lam, [X], B}]);
{funcall, A, Bs} -> free_vars([A | Bs]); {funcall, A, Bs} -> free_vars([A | Bs]);
{set_state, _, A} -> free_vars(A);
{get_state, _} -> [];
{lam, Xs, B} -> free_vars(B) -- lists:sort(Xs); {lam, Xs, B} -> free_vars(B) -- lists:sort(Xs);
{closure, _, A} -> free_vars(A); {closure, _, A} -> free_vars(A);
{switch, A} -> free_vars(A); {switch, A} -> free_vars(A);
@ -1354,6 +1697,8 @@ used_defs(Expr) ->
{op, _, As} -> used_defs(As); {op, _, As} -> used_defs(As);
{'let', _, A, B} -> used_defs([A, B]); {'let', _, A, B} -> used_defs([A, B]);
{funcall, A, Bs} -> used_defs([A | Bs]); {funcall, A, Bs} -> used_defs([A | Bs]);
{set_state, _, A} -> used_defs(A);
{get_state, _} -> [];
{lam, _, B} -> used_defs(B); {lam, _, B} -> used_defs(B);
{closure, F, A} -> lists:umerge([F], used_defs(A)); {closure, F, A} -> lists:umerge([F], used_defs(A));
{switch, A} -> used_defs(A); {switch, A} -> used_defs(A);
@ -1362,6 +1707,50 @@ used_defs(Expr) ->
{'case', _, A} -> used_defs(A) {'case', _, A} -> used_defs(A)
end. end.
bottom_up(F, Expr) -> bottom_up(F, #{}, Expr).
bottom_up(F, Env, Expr) ->
F(Env, case Expr of
{lit, _} -> Expr;
nil -> Expr;
{var, _} -> Expr;
{def, D, Es} -> {def, D, [bottom_up(F, Env, E) || E <- Es]};
{def_u, _, _} -> Expr;
{builtin, B, Es} -> {builtin, B, [bottom_up(F, Env, E) || E <- Es]};
{builtin_u, _, _} -> Expr;
{builtin_u, _, _, _} -> Expr;
{remote, ArgsT, RetT, Ct, Fun, Es} -> {remote, ArgsT, RetT, bottom_up(F, Env, Ct), Fun, [bottom_up(F, Env, E) || E <- Es]};
{remote_u, ArgsT, RetT, Ct, Fun} -> {remote_u, ArgsT, RetT, bottom_up(F, Env, Ct), Fun};
{con, Ar, I, Es} -> {con, Ar, I, [bottom_up(F, Env, E) || E <- Es]};
{tuple, Es} -> {tuple, [bottom_up(F, Env, E) || E <- Es]};
{proj, E, I} -> {proj, bottom_up(F, Env, E), I};
{set_proj, R, I, E} -> {set_proj, bottom_up(F, Env, R), I, bottom_up(F, Env, E)};
{op, Op, Es} -> {op, Op, [bottom_up(F, Env, E) || E <- Es]};
{funcall, Fun, Es} -> {funcall, bottom_up(F, Env, Fun), [bottom_up(F, Env, E) || E <- Es]};
{set_state, R, E} -> {set_state, R, bottom_up(F, Env, E)};
{get_state, _} -> Expr;
{closure, F, CEnv} -> {closure, F, bottom_up(F, Env, CEnv)};
{switch, Split} -> {switch, bottom_up(F, Env, Split)};
{lam, Xs, B} -> {lam, Xs, bottom_up(F, Env, B)};
{'let', X, E, Body} ->
E1 = bottom_up(F, Env, E),
%% Always freshen user variables to avoid shadowing issues.
ShouldFreshen = fun(Y = "%" ++ _) -> maps:is_key(Y, Env);
(_) -> true end,
case ShouldFreshen(X) of
true ->
Z = fresh_name(),
Env1 = Env#{ Z => E1 },
{'let', Z, E1, bottom_up(F, Env1, rename([{X, Z}], Body))};
false ->
Env1 = Env#{ X => E1 },
{'let', X, E1, bottom_up(F, Env1, Body)}
end;
{split, Type, X, Cases} -> {split, Type, X, [bottom_up(F, Env, Case) || Case <- Cases]};
{nosplit, E} -> {nosplit, bottom_up(F, Env, E)};
{'case', Pat, Split} -> {'case', Pat, bottom_up(F, Env, Split)}
end).
get_named_args(NamedArgsT, Args) -> get_named_args(NamedArgsT, Args) ->
IsNamed = fun({named_arg, _, _, _}) -> true; IsNamed = fun({named_arg, _, _, _}) -> true;
(_) -> false end, (_) -> false end,
@ -1396,6 +1785,8 @@ rename(Ren, Expr) ->
{set_proj, R, I, E} -> {set_proj, rename(Ren, R), I, rename(Ren, E)}; {set_proj, R, I, E} -> {set_proj, rename(Ren, R), I, rename(Ren, E)};
{op, Op, Es} -> {op, Op, [rename(Ren, E) || E <- Es]}; {op, Op, Es} -> {op, Op, [rename(Ren, E) || E <- Es]};
{funcall, Fun, Es} -> {funcall, rename(Ren, Fun), [rename(Ren, E) || E <- Es]}; {funcall, Fun, Es} -> {funcall, rename(Ren, Fun), [rename(Ren, E) || E <- Es]};
{set_state, R, E} -> {set_state, R, rename(Ren, E)};
{get_state, _} -> Expr;
{closure, F, Env} -> {closure, F, rename(Ren, Env)}; {closure, F, Env} -> {closure, F, rename(Ren, Env)};
{switch, Split} -> {switch, rename_split(Ren, Split)}; {switch, Split} -> {switch, rename_split(Ren, Split)};
{lam, Xs, B} -> {lam, Xs, B} ->
@ -1502,6 +1893,10 @@ get_attributes(Ann) ->
indexed(Xs) -> indexed(Xs) ->
lists:zip(lists:seq(1, length(Xs)), Xs). lists:zip(lists:seq(1, length(Xs)), Xs).
setnth(I, X, Xs) ->
{Ys, [_ | Zs]} = lists:split(I - 1, Xs),
Ys ++ [X] ++ Zs.
-dialyzer({nowarn_function, [fcode_error/1, internal_error/1]}). -dialyzer({nowarn_function, [fcode_error/1, internal_error/1]}).
fcode_error(Error) -> fcode_error(Error) ->
@ -1604,9 +1999,18 @@ pp_fexpr({op, Op, [A] = Args}) ->
end; end;
pp_fexpr({op, Op, As}) -> pp_fexpr({op, Op, As}) ->
pp_beside(pp_text(Op), pp_fexpr({tuple, As})); pp_beside(pp_text(Op), pp_fexpr({tuple, As}));
pp_fexpr({'let', X, A, B}) -> pp_fexpr({'let', _, _, _} = Expr) ->
pp_par([pp_beside([pp_text("let "), pp_text(X), pp_text(" = "), pp_fexpr(A), pp_text(" in")]), Lets = fun Lets({'let', Y, C, D}) ->
pp_fexpr(B)]); {Ls, E} = Lets(D),
{[{Y, C} | Ls], E};
Lets(E) -> {[], E} end,
{Ls, Body} = Lets(Expr),
pp_parens(
pp_par(
[ pp_beside([ pp_text("let "),
pp_above([ pp_par([pp_text(X), pp_text("="), prettypr:nest(2, pp_fexpr(A))]) || {X, A} <- Ls ]),
pp_text(" in ") ]),
pp_fexpr(Body) ]));
pp_fexpr({builtin_u, B, N}) -> pp_fexpr({builtin_u, B, N}) ->
pp_beside([pp_text(B), pp_text("/"), pp_text(N)]); pp_beside([pp_text(B), pp_text("/"), pp_text(N)]);
pp_fexpr({builtin_u, B, N, TypeArgs}) -> pp_fexpr({builtin_u, B, N, TypeArgs}) ->
@ -1619,6 +2023,10 @@ pp_fexpr({remote, ArgsT, RetT, Ct, Fun, As}) ->
pp_call(pp_parens(pp_beside([pp_fexpr(Ct), pp_text("."), pp_fun_name(Fun), pp_text(" : "), pp_ftype({function, ArgsT, RetT})])), As); pp_call(pp_parens(pp_beside([pp_fexpr(Ct), pp_text("."), pp_fun_name(Fun), pp_text(" : "), pp_ftype({function, ArgsT, RetT})])), As);
pp_fexpr({funcall, Fun, As}) -> pp_fexpr({funcall, Fun, As}) ->
pp_call(pp_fexpr(Fun), As); pp_call(pp_fexpr(Fun), As);
pp_fexpr({set_state, R, A}) ->
pp_call(pp_text("set_state"), [{lit, {int, R}}, A]);
pp_fexpr({get_state, R}) ->
pp_call(pp_text("get_state"), [{lit, {int, R}}]);
pp_fexpr({switch, Split}) -> pp_split(Split). pp_fexpr({switch, Split}) -> pp_split(Split).
pp_call(Fun, Args) -> pp_call(Fun, Args) ->
@ -1634,7 +2042,7 @@ pp_ftype({tvar, X}) -> pp_text(X);
pp_ftype({bytes, N}) -> pp_call(pp_text("bytes"), [{lit, {int, N}}]); pp_ftype({bytes, N}) -> pp_call(pp_text("bytes"), [{lit, {int, N}}]);
pp_ftype({oracle, Q, R}) -> pp_call_t("oracle", [Q, R]); pp_ftype({oracle, Q, R}) -> pp_call_t("oracle", [Q, R]);
pp_ftype({tuple, Ts}) -> pp_ftype({tuple, Ts}) ->
pp_parens(pp_par(pp_punctuate(pp_text(","), [pp_ftype(T) || T <- Ts]))); pp_parens(pp_par(pp_punctuate(pp_text(" *"), [pp_ftype(T) || T <- Ts])));
pp_ftype({list, T}) -> pp_ftype({list, T}) ->
pp_call_t("list", [T]); pp_call_t("list", [T]);
pp_ftype({function, Args, Res}) -> pp_ftype({function, Args, Res}) ->

16
src/aeso_ast_to_icode.erl
View File

@ -318,19 +318,23 @@ ast_body({app, As, Fun, Args}, Icode) ->
end; end;
ast_body({list_comp, _, Yield, []}, Icode) -> ast_body({list_comp, _, Yield, []}, Icode) ->
#list{elems = [ast_body(Yield, Icode)]}; #list{elems = [ast_body(Yield, Icode)]};
ast_body({list_comp, As, Yield, [{comprehension_bind, {typed, Arg, ArgType}, BindExpr}|Rest]}, Icode) -> ast_body({list_comp, As, Yield, [{comprehension_bind, {typed, _, Pat, ArgType}, BindExpr}|Rest]}, Icode) ->
Arg = "%lc",
Body = {switch, As, {typed, As, {id, As, Arg}, ArgType},
[{'case', As, Pat, {list_comp, As, Yield, Rest}},
{'case', As, {id, As, "_"}, {list, As, []}}]},
#funcall #funcall
{ function = #var_ref{ name = ["ListInternal", "flat_map"] } { function = #var_ref{ name = ["ListInternal", "flat_map"] }
, args = , args =
[ #lambda{ args=[#arg{name = ast_id(Arg), type = ast_type(ArgType, Icode)}] [ #lambda{ args=[#arg{name = Arg, type = ast_type(ArgType, Icode)}]
, body = ast_body({list_comp, As, Yield, Rest}, Icode) , body = ast_body(Body, Icode)
} }
, ast_body(BindExpr, Icode) , ast_body(BindExpr, Icode)
] ]
}; };
ast_body({list_comp, As, Yield, [{comprehension_if, AsIF, Cond}|Rest]}, Icode) -> ast_body({list_comp, As, Yield, [{comprehension_if, AsIF, Cond}|Rest]}, Icode) ->
ast_body({'if', AsIF, Cond, {list_comp, As, Yield, Rest}, {list, As, []}}, Icode); ast_body({'if', AsIF, Cond, {list_comp, As, Yield, Rest}, {list, As, []}}, Icode);
ast_body({list_comp, As, Yield, [LV = {letval, _, _, _, _}|Rest]}, Icode) -> ast_body({list_comp, As, Yield, [LV = {letval, _, _, _}|Rest]}, Icode) ->
ast_body({block, As, [LV, {list_comp, As, Yield, Rest}]}, Icode); ast_body({block, As, [LV, {list_comp, As, Yield, Rest}]}, Icode);
ast_body({list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}, Icode) -> ast_body({list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}, Icode) ->
ast_body({block, As, [LF, {list_comp, As, Yield, Rest}]}, Icode); ast_body({block, As, [LF, {list_comp, As, Yield, Rest}]}, Icode);
@ -344,14 +348,14 @@ ast_body({switch,_,A,Cases}, Icode) ->
#switch{expr=ast_body(A, Icode), #switch{expr=ast_body(A, Icode),
cases=[{ast_body(Pat, Icode),ast_body(Body, Icode)} cases=[{ast_body(Pat, Icode),ast_body(Body, Icode)}
|| {'case',_,Pat,Body} <- Cases]}; || {'case',_,Pat,Body} <- Cases]};
ast_body({block, As, [{letval, _, Pat, _, E} | Rest]}, Icode) -> ast_body({block, As, [{letval, _, Pat, E} | Rest]}, Icode) ->
E1 = ast_body(E, Icode), E1 = ast_body(E, Icode),
Pat1 = ast_body(Pat, Icode), Pat1 = ast_body(Pat, Icode),
Rest1 = ast_body({block, As, Rest}, Icode), Rest1 = ast_body({block, As, Rest}, Icode),
#switch{expr = E1, #switch{expr = E1,
cases = [{Pat1, Rest1}]}; cases = [{Pat1, Rest1}]};
ast_body({block, As, [{letfun, Ann, F, Args, _Type, Expr} | Rest]}, Icode) -> ast_body({block, As, [{letfun, Ann, F, Args, _Type, Expr} | Rest]}, Icode) ->
ast_body({block, As, [{letval, Ann, F, unused, {lam, Ann, Args, Expr}} | Rest]}, Icode); ast_body({block, As, [{letval, Ann, F, {lam, Ann, Args, Expr}} | Rest]}, Icode);
ast_body({block,_,[]}, _Icode) -> ast_body({block,_,[]}, _Icode) ->
#tuple{cpts=[]}; #tuple{cpts=[]};
ast_body({block,_,[E]}, Icode) -> ast_body({block,_,[E]}, Icode) ->

127
src/aeso_fcode_to_fate.erl
View File

@ -41,8 +41,8 @@
-define(TODO(What), error({todo, ?FILE, ?LINE, ?FUNCTION_NAME, What})). -define(TODO(What), error({todo, ?FILE, ?LINE, ?FUNCTION_NAME, What})).
-define(i(X), {immediate, X}). -define(i(X), {immediate, X}).
-define(a, {stack, 0}). -define(a, {stack, 0}).
-define(s, {store, 1}). -define(s(N), {store, N}).
-define(void, {var, 9999}). -define(void, {var, 9999}).
-record(env, { contract, vars = [], locals = [], current_function, tailpos = true }). -record(env, { contract, vars = [], locals = [], current_function, tailpos = true }).
@ -120,9 +120,10 @@ type_to_scode(name) -> name;
type_to_scode(channel) -> channel; type_to_scode(channel) -> channel;
type_to_scode(bits) -> bits; type_to_scode(bits) -> bits;
type_to_scode(any) -> any; type_to_scode(any) -> any;
type_to_scode({variant, Cons}) -> {variant, lists:map(fun(T) -> type_to_scode({tuple, T}) end, Cons)}; type_to_scode({variant, Cons}) -> {variant, [{tuple, types_to_scode(Con)} || Con <- Cons]};
type_to_scode({list, Type}) -> {list, type_to_scode(Type)}; type_to_scode({list, Type}) -> {list, type_to_scode(Type)};
type_to_scode({tuple, Types}) -> {tuple, lists:map(fun type_to_scode/1, Types)}; type_to_scode({tuple, [Type]}) -> type_to_scode(Type);
type_to_scode({tuple, Types}) -> {tuple, types_to_scode(Types)};
type_to_scode({map, Key, Val}) -> {map, type_to_scode(Key), type_to_scode(Val)}; type_to_scode({map, Key, Val}) -> {map, type_to_scode(Key), type_to_scode(Val)};
type_to_scode({function, _Args, _Res}) -> {tuple, [string, any]}; type_to_scode({function, _Args, _Res}) -> {tuple, [string, any]};
type_to_scode({tvar, X}) -> type_to_scode({tvar, X}) ->
@ -134,6 +135,8 @@ type_to_scode({tvar, X}) ->
J -> {tvar, J} J -> {tvar, J}
end. end.
types_to_scode(Ts) -> lists:map(fun type_to_scode/1, Ts).
%% -- Phase I ---------------------------------------------------------------- %% -- Phase I ----------------------------------------------------------------
%% Icode to structured assembly %% Icode to structured assembly
@ -179,84 +182,99 @@ lit_to_fate(L) ->
{typerep, T} -> aeb_fate_data:make_typerep(type_to_scode(T)) {typerep, T} -> aeb_fate_data:make_typerep(type_to_scode(T))
end. end.
term_to_fate({lit, L}) -> term_to_fate(E) -> term_to_fate(#{}, E).
term_to_fate(_Env, {lit, L}) ->
lit_to_fate(L); lit_to_fate(L);
%% negative literals are parsed as 0 - N %% negative literals are parsed as 0 - N
term_to_fate({op, '-', [{lit, {int, 0}}, {lit, {int, N}}]}) -> term_to_fate(_Env, {op, '-', [{lit, {int, 0}}, {lit, {int, N}}]}) ->
aeb_fate_data:make_integer(-N); aeb_fate_data:make_integer(-N);
term_to_fate(nil) -> term_to_fate(_Env, nil) ->
aeb_fate_data:make_list([]); aeb_fate_data:make_list([]);
term_to_fate({op, '::', [Hd, Tl]}) -> term_to_fate(Env, {op, '::', [Hd, Tl]}) ->
%% The Tl will translate into a list, because FATE lists are just lists %% The Tl will translate into a list, because FATE lists are just lists
[term_to_fate(Hd) | term_to_fate(Tl)]; [term_to_fate(Env, Hd) | term_to_fate(Env, Tl)];
term_to_fate({tuple, As}) -> term_to_fate(Env, {tuple, As}) ->
aeb_fate_data:make_tuple(list_to_tuple([ term_to_fate(A) || A<-As])); aeb_fate_data:make_tuple(list_to_tuple([ term_to_fate(Env, A) || A<-As]));
term_to_fate({con, Ar, I, As}) -> term_to_fate(Env, {con, Ar, I, As}) ->
FateAs = [ term_to_fate(A) || A <- As ], FateAs = [ term_to_fate(Env, A) || A <- As ],
aeb_fate_data:make_variant(Ar, I, list_to_tuple(FateAs)); aeb_fate_data:make_variant(Ar, I, list_to_tuple(FateAs));
term_to_fate({builtin, bits_all, []}) -> term_to_fate(_Env, {builtin, bits_all, []}) ->
aeb_fate_data:make_bits(-1); aeb_fate_data:make_bits(-1);
term_to_fate({builtin, bits_none, []}) -> term_to_fate(_Env, {builtin, bits_none, []}) ->
aeb_fate_data:make_bits(0); aeb_fate_data:make_bits(0);
term_to_fate({op, bits_set, [B, I]}) -> term_to_fate(_Env, {op, bits_set, [B, I]}) ->
{bits, N} = term_to_fate(B), {bits, N} = term_to_fate(B),
J = term_to_fate(I), J = term_to_fate(I),
{bits, N bor (1 bsl J)}; {bits, N bor (1 bsl J)};
term_to_fate({op, bits_clear, [B, I]}) -> term_to_fate(_Env, {op, bits_clear, [B, I]}) ->
{bits, N} = term_to_fate(B), {bits, N} = term_to_fate(B),
J = term_to_fate(I), J = term_to_fate(I),
{bits, N band bnot (1 bsl J)}; {bits, N band bnot (1 bsl J)};
term_to_fate({builtin, map_empty, []}) -> term_to_fate(Env, {'let', X, E, Body}) ->
Env1 = Env#{ X => term_to_fate(Env, E) },
term_to_fate(Env1, Body);
term_to_fate(Env, {var, X}) ->
case maps:get(X, Env, undefined) of
undefined -> throw(not_a_fate_value);
V -> V
end;
term_to_fate(_Env, {builtin, map_empty, []}) ->
aeb_fate_data:make_map(#{}); aeb_fate_data:make_map(#{});
term_to_fate({'let', _, {builtin, map_empty, []}, Set}) -> term_to_fate(Env, {op, map_set, [M, K, V]}) ->
aeb_fate_data:make_map(map_to_fate(Set)). Map = term_to_fate(Env, M),
Map#{term_to_fate(Env, K) => term_to_fate(Env, V)};
term_to_fate(_Env, _) ->
throw(not_a_fate_value).
map_to_fate({op, map_set, [{var, _}, K, V]}) -> to_scode(Env, T) ->
#{term_to_fate(K) => term_to_fate(V)}; try term_to_fate(T) of
map_to_fate({op, map_set, [Set, K, V]}) -> V -> [push(?i(V))]
Map = map_to_fate(Set), Map#{term_to_fate(K) => term_to_fate(V)}. catch throw:not_a_fate_value ->
to_scode1(Env, T)
end.
to_scode(_Env, {lit, L}) -> to_scode1(_Env, {lit, L}) ->
[push(?i(lit_to_fate(L)))]; [push(?i(lit_to_fate(L)))];
to_scode(_Env, nil) -> to_scode1(_Env, nil) ->
[aeb_fate_ops:nil(?a)]; [aeb_fate_ops:nil(?a)];
to_scode(Env, {var, X}) -> to_scode1(Env, {var, X}) ->
[push(lookup_var(Env, X))]; [push(lookup_var(Env, X))];
to_scode(Env, {con, Ar, I, As}) -> to_scode1(Env, {con, Ar, I, As}) ->
N = length(As), N = length(As),
[[to_scode(notail(Env), A) || A <- As], [[to_scode(notail(Env), A) || A <- As],
aeb_fate_ops:variant(?a, ?i(Ar), ?i(I), ?i(N))]; aeb_fate_ops:variant(?a, ?i(Ar), ?i(I), ?i(N))];
to_scode(Env, {tuple, As}) -> to_scode1(Env, {tuple, As}) ->
N = length(As), N = length(As),
[[ to_scode(notail(Env), A) || A <- As ], [[ to_scode(notail(Env), A) || A <- As ],
tuple(N)]; tuple(N)];
to_scode(Env, {proj, E, I}) -> to_scode1(Env, {proj, E, I}) ->
[to_scode(notail(Env), E), [to_scode(notail(Env), E),
aeb_fate_ops:element_op(?a, ?i(I), ?a)]; aeb_fate_ops:element_op(?a, ?i(I), ?a)];
to_scode(Env, {set_proj, R, I, E}) -> to_scode1(Env, {set_proj, R, I, E}) ->
[to_scode(notail(Env), E), [to_scode(notail(Env), E),
to_scode(notail(Env), R), to_scode(notail(Env), R),
aeb_fate_ops:setelement(?a, ?i(I), ?a, ?a)]; aeb_fate_ops:setelement(?a, ?i(I), ?a, ?a)];
to_scode(Env, {op, Op, Args}) -> to_scode1(Env, {op, Op, Args}) ->
call_to_scode(Env, op_to_scode(Op), Args); call_to_scode(Env, op_to_scode(Op), Args);
to_scode(Env, {'let', X, {var, Y}, Body}) -> to_scode1(Env, {'let', X, {var, Y}, Body}) ->
Env1 = bind_var(X, lookup_var(Env, Y), Env), Env1 = bind_var(X, lookup_var(Env, Y), Env),
to_scode(Env1, Body); to_scode(Env1, Body);
to_scode(Env, {'let', X, Expr, Body}) -> to_scode1(Env, {'let', X, Expr, Body}) ->
{I, Env1} = bind_local(X, Env), {I, Env1} = bind_local(X, Env),
[ to_scode(notail(Env), Expr), [ to_scode(notail(Env), Expr),
aeb_fate_ops:store({var, I}, {stack, 0}), aeb_fate_ops:store({var, I}, {stack, 0}),
to_scode(Env1, Body) ]; to_scode(Env1, Body) ];
to_scode(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args}) -> to_scode1(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args}) ->
%% Tail-call to current function, f(e0..en). Compile to %% Tail-call to current function, f(e0..en). Compile to
%% [ let xi = ei ] %% [ let xi = ei ]
%% [ STORE argi xi ] %% [ STORE argi xi ]
@ -274,17 +292,17 @@ to_scode(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args})
|| {I, J} <- lists:zip(lists:seq(0, length(Vars) - 1), || {I, J} <- lists:zip(lists:seq(0, length(Vars) - 1),
lists:reverse(Vars)) ], lists:reverse(Vars)) ],
loop ]; loop ];
to_scode(Env, {def, Fun, Args}) -> to_scode1(Env, {def, Fun, Args}) ->
FName = make_function_id(Fun), FName = make_function_id(Fun),
Lbl = aeb_fate_data:make_string(FName), Lbl = aeb_fate_data:make_string(FName),
call_to_scode(Env, local_call(Env, ?i(Lbl)), Args); call_to_scode(Env, local_call(Env, ?i(Lbl)), Args);
to_scode(Env, {funcall, Fun, Args}) -> to_scode1(Env, {funcall, Fun, Args}) ->
call_to_scode(Env, [to_scode(Env, Fun), local_call(Env, ?a)], Args); call_to_scode(Env, [to_scode(Env, Fun), local_call(Env, ?a)], Args);
to_scode(Env, {builtin, B, Args}) -> to_scode1(Env, {builtin, B, Args}) ->
builtin_to_scode(Env, B, Args); builtin_to_scode(Env, B, Args);
to_scode(Env, {remote, ArgsT, RetT, Ct, Fun, [Gas, Value | Args]}) -> to_scode1(Env, {remote, ArgsT, RetT, Ct, Fun, [Gas, Value | Args]}) ->
Lbl = make_function_id(Fun), Lbl = make_function_id(Fun),
{ArgTypes, RetType0} = typesig_to_scode([{"_", T} || T <- ArgsT], RetT), {ArgTypes, RetType0} = typesig_to_scode([{"_", T} || T <- ArgsT], RetT),
ArgType = ?i(aeb_fate_data:make_typerep({tuple, ArgTypes})), ArgType = ?i(aeb_fate_data:make_typerep({tuple, ArgTypes})),
@ -298,10 +316,16 @@ to_scode(Env, {remote, ArgsT, RetT, Ct, Fun, [Gas, Value | Args]}) ->
call_to_scode(Env, Call, [Ct, Value, Gas | Args]) call_to_scode(Env, Call, [Ct, Value, Gas | Args])
end; end;
to_scode(Env, {closure, Fun, FVs}) -> to_scode1(_Env, {get_state, Reg}) ->
[push(?s(Reg))];
to_scode1(Env, {set_state, Reg, Val}) ->
call_to_scode(Env, [{'STORE', ?s(Reg), ?a},
tuple(0)], [Val]);
to_scode1(Env, {closure, Fun, FVs}) ->
to_scode(Env, {tuple, [{lit, {string, make_function_id(Fun)}}, FVs]}); to_scode(Env, {tuple, [{lit, {string, make_function_id(Fun)}}, FVs]});
to_scode(Env, {switch, Case}) -> to_scode1(Env, {switch, Case}) ->
split_to_scode(Env, Case). split_to_scode(Env, Case).
local_call( Env, Fun) when Env#env.tailpos -> aeb_fate_ops:call_t(Fun); local_call( Env, Fun) when Env#env.tailpos -> aeb_fate_ops:call_t(Fun);
@ -420,11 +444,6 @@ call_to_scode(Env, CallCode, Args) ->
[[to_scode(notail(Env), A) || A <- lists:reverse(Args)], [[to_scode(notail(Env), A) || A <- lists:reverse(Args)],
CallCode]. CallCode].
builtin_to_scode(_Env, get_state, []) ->
[push(?s)];
builtin_to_scode(Env, set_state, [_] = Args) ->
call_to_scode(Env, [{'STORE', ?s, ?a},
tuple(0)], Args);
builtin_to_scode(Env, chain_event, Args) -> builtin_to_scode(Env, chain_event, Args) ->
call_to_scode(Env, [erlang:apply(aeb_fate_ops, log, lists:duplicate(length(Args), ?a)), call_to_scode(Env, [erlang:apply(aeb_fate_ops, log, lists:duplicate(length(Args), ?a)),
tuple(0)], Args); tuple(0)], Args);
@ -672,11 +691,11 @@ pp_op(loop) -> "LOOP";
pp_op(I) -> pp_op(I) ->
aeb_fate_pp:format_op(I, #{}). aeb_fate_pp:format_op(I, #{}).
pp_arg(?i(I)) -> io_lib:format("~w", [I]); pp_arg(?i(I)) -> io_lib:format("~w", [I]);
pp_arg({arg, N}) -> io_lib:format("arg~p", [N]); pp_arg({arg, N}) -> io_lib:format("arg~p", [N]);
pp_arg({store, N}) -> io_lib:format("store~p", [N]); pp_arg(?s(N)) -> io_lib:format("store~p", [N]);
pp_arg({var, N}) -> io_lib:format("var~p", [N]); pp_arg({var, N}) -> io_lib:format("var~p", [N]);
pp_arg(?a) -> "a". pp_arg(?a) -> "a".
%% -- Analysis -- %% -- Analysis --
@ -1419,7 +1438,7 @@ desugar_args(I) when is_tuple(I) ->
list_to_tuple([Op | lists:map(fun desugar_arg/1, Args)]); list_to_tuple([Op | lists:map(fun desugar_arg/1, Args)]);
desugar_args(I) -> I. desugar_args(I) -> I.
desugar_arg({store, N}) -> {var, -N}; desugar_arg(?s(N)) -> {var, -N};
desugar_arg(A) -> A. desugar_arg(A) -> A.
%% -- Phase III -------------------------------------------------------------- %% -- Phase III --------------------------------------------------------------
@ -1629,6 +1648,7 @@ tweak_returns(['RETURN', {'PUSH', A} | Code]) -> [{'RETURNR', A} | Code
tweak_returns(['RETURN' | Code = [{'CALL_T', _} | _]]) -> Code; tweak_returns(['RETURN' | Code = [{'CALL_T', _} | _]]) -> Code;
tweak_returns(['RETURN' | Code = [{'ABORT', _} | _]]) -> Code; tweak_returns(['RETURN' | Code = [{'ABORT', _} | _]]) -> Code;
tweak_returns(['RETURN' | Code = [{'EXIT', _} | _]]) -> Code; tweak_returns(['RETURN' | Code = [{'EXIT', _} | _]]) -> Code;
tweak_returns(['RETURN' | Code = [loop | _]]) -> Code;
tweak_returns(Code) -> Code. tweak_returns(Code) -> Code.
%% -- Split basic blocks at CALL instructions -- %% -- Split basic blocks at CALL instructions --
@ -1642,8 +1662,7 @@ split_calls(Ref, [], Acc, Blocks) ->
split_calls(Ref, [I | Code], Acc, Blocks) when element(1, I) == 'CALL'; split_calls(Ref, [I | Code], Acc, Blocks) when element(1, I) == 'CALL';
element(1, I) == 'CALL_R'; element(1, I) == 'CALL_R';
element(1, I) == 'CALL_GR'; element(1, I) == 'CALL_GR';
element(1, I) == 'jumpif'; element(1, I) == 'jumpif' ->
I == loop ->
split_calls(make_ref(), Code, [], [{Ref, lists:reverse([I | Acc])} | Blocks]); split_calls(make_ref(), Code, [], [{Ref, lists:reverse([I | Acc])} | Blocks]);
split_calls(Ref, [{'ABORT', _} = I | _Code], Acc, Blocks) -> split_calls(Ref, [{'ABORT', _} = I | _Code], Acc, Blocks) ->
lists:reverse([{Ref, lists:reverse([I | Acc])} | Blocks]); lists:reverse([{Ref, lists:reverse([I | Acc])} | Blocks]);

23
src/aeso_parser.erl
View File

@ -164,9 +164,7 @@ letdecl() ->
letdef() -> choice(valdef(), fundef()). letdef() -> choice(valdef(), fundef()).
valdef() -> valdef() ->
choice( ?RULE(pattern(), tok('='), body(), {letval, [], _1, _3}).
?RULE(id(), tok('='), body(), {letval, [], _1, type_wildcard(), _3}),
?RULE(id(), tok(':'), type(), tok('='), body(), {letval, [], _1, _3, _5})).
fundef() -> fundef() ->
choice( choice(
@ -238,7 +236,7 @@ branch() ->
?RULE(pattern(), keyword('=>'), body(), {'case', _2, _1, _3}). ?RULE(pattern(), keyword('=>'), body(), {'case', _2, _1, _3}).
pattern() -> pattern() ->
?LET_P(E, expr500(), parse_pattern(E)). ?LET_P(E, expr(), parse_pattern(E)).
%% -- Expressions ------------------------------------------------------------ %% -- Expressions ------------------------------------------------------------
@ -297,7 +295,7 @@ comprehension_if() ->
?RULE(keyword('if'), parens(expr()), {comprehension_if, _1, _2}). ?RULE(keyword('if'), parens(expr()), {comprehension_if, _1, _2}).
comprehension_bind() -> comprehension_bind() ->
?RULE(id(), tok('<-'), expr(), {comprehension_bind, _1, _3}). ?RULE(pattern(), tok('<-'), expr(), {comprehension_bind, _1, _3}).
arg_expr() -> arg_expr() ->
?LAZY_P( ?LAZY_P(
@ -349,7 +347,9 @@ record(Fs) ->
bad_expr_err("Cannot use '@' in map construction", infix({lvalue, FAnn, LV}, {'@', Ann}, Id)); bad_expr_err("Cannot use '@' in map construction", infix({lvalue, FAnn, LV}, {'@', Ann}, Id));
({field, FAnn, LV, _}) -> ({field, FAnn, LV, _}) ->
bad_expr_err("Cannot use nested fields or keys in map construction", {lvalue, FAnn, LV}) end, bad_expr_err("Cannot use nested fields or keys in map construction", {lvalue, FAnn, LV}) end,
{map, Ann, lists:map(KV, Fs)} {map, Ann, lists:map(KV, Fs)};
record_or_map_error ->
{record_or_map_error, get_ann(hd(Fs)), Fs}
end. end.
record_or_map(Fields) -> record_or_map(Fields) ->
@ -361,9 +361,7 @@ record_or_map(Fields) ->
case lists:usort(lists:map(Kind, Fields)) of case lists:usort(lists:map(Kind, Fields)) of
[proj] -> record; [proj] -> record;
[map_get] -> map; [map_get] -> map;
_ -> _ -> record_or_map_error %% Defer error until type checking
[{field, Ann, _, _} | _] = Fields,
bad_expr_err("Mixed record fields and map keys in", {record, Ann, Fields})
end. end.
field_assignment() -> field_assignment() ->
@ -545,7 +543,9 @@ list_comp_e(Ann, Expr, Binds) -> {list_comp, Ann, Expr, Binds}.
-spec parse_pattern(aeso_syntax:expr()) -> aeso_parse_lib:parser(aeso_syntax:pat()). -spec parse_pattern(aeso_syntax:expr()) -> aeso_parse_lib:parser(aeso_syntax:pat()).
parse_pattern({app, Ann, Con = {'::', _}, Es}) -> parse_pattern({app, Ann, Con = {'::', _}, Es}) ->
{app, Ann, Con, lists:map(fun parse_pattern/1, Es)}; {app, Ann, Con, lists:map(fun parse_pattern/1, Es)};
parse_pattern({app, Ann, Con = {con, _, _}, Es}) -> parse_pattern({app, Ann, {'-', _}, [{int, _, N}]}) ->
{int, Ann, -N};
parse_pattern({app, Ann, Con = {Tag, _, _}, Es}) when Tag == con; Tag == qcon ->
{app, Ann, Con, lists:map(fun parse_pattern/1, Es)}; {app, Ann, Con, lists:map(fun parse_pattern/1, Es)};
parse_pattern({tuple, Ann, Es}) -> parse_pattern({tuple, Ann, Es}) ->
{tuple, Ann, lists:map(fun parse_pattern/1, Es)}; {tuple, Ann, lists:map(fun parse_pattern/1, Es)};
@ -553,7 +553,10 @@ parse_pattern({list, Ann, Es}) ->
{list, Ann, lists:map(fun parse_pattern/1, Es)}; {list, Ann, lists:map(fun parse_pattern/1, Es)};
parse_pattern({record, Ann, Fs}) -> parse_pattern({record, Ann, Fs}) ->
{record, Ann, lists:map(fun parse_field_pattern/1, Fs)}; {record, Ann, lists:map(fun parse_field_pattern/1, Fs)};
parse_pattern({typed, Ann, E, Type}) ->
{typed, Ann, parse_pattern(E), Type};
parse_pattern(E = {con, _, _}) -> E; parse_pattern(E = {con, _, _}) -> E;
parse_pattern(E = {qcon, _, _}) -> E;
parse_pattern(E = {id, _, _}) -> E; parse_pattern(E = {id, _, _}) -> E;
parse_pattern(E = {int, _, _}) -> E; parse_pattern(E = {int, _, _}) -> E;
parse_pattern(E = {bool, _, _}) -> E; parse_pattern(E = {bool, _, _}) -> E;

19
src/aeso_pretty.erl
View File

@ -169,7 +169,7 @@ decl(D = {letfun, Attrs, _, _, _, _}) ->
false -> "function" false -> "function"
end, end,
hsep(lists:map(Mod, Attrs) ++ [letdecl(Fun, D)]); hsep(lists:map(Mod, Attrs) ++ [letdecl(Fun, D)]);
decl(D = {letval, _, _, _, _}) -> letdecl("let", D). decl(D = {letval, _, _, _}) -> letdecl("let", D).
-spec pragma(aeso_syntax:pragma()) -> doc(). -spec pragma(aeso_syntax:pragma()) -> doc().
pragma({compiler, Op, Ver}) -> pragma({compiler, Op, Ver}) ->
@ -193,8 +193,8 @@ name({tvar, _, Name}) -> text(Name);
name({typed, _, Name, _}) -> name(Name). name({typed, _, Name, _}) -> name(Name).
-spec letdecl(string(), aeso_syntax:letbind()) -> doc(). -spec letdecl(string(), aeso_syntax:letbind()) -> doc().
letdecl(Let, {letval, _, F, T, E}) -> letdecl(Let, {letval, _, P, E}) ->
block_expr(0, hsep([text(Let), typed(name(F), T), text("=")]), E); block_expr(0, hsep([text(Let), expr(P), text("=")]), E);
letdecl(Let, {letfun, _, F, Args, T, E}) -> letdecl(Let, {letfun, _, F, Args, T, E}) ->
block_expr(0, hsep([text(Let), typed(beside(name(F), args(Args)), T), text("=")]), E). block_expr(0, hsep([text(Let), typed(beside(name(F), args(Args)), T), text("=")]), E).
@ -305,6 +305,8 @@ expr_p(_, {tuple, _, Es}) ->
tuple(lists:map(fun expr/1, Es)); tuple(lists:map(fun expr/1, Es));
expr_p(_, {list, _, Es}) -> expr_p(_, {list, _, Es}) ->
list(lists:map(fun expr/1, Es)); list(lists:map(fun expr/1, Es));
expr_p(_, {list_comp, _, E, Binds}) ->
list([follow(expr(E), hsep(text("|"), par(punctuate(text(","), lists:map(fun lc_bind/1, Binds)), 0)), 0)]);
expr_p(_, {record, _, Fs}) -> expr_p(_, {record, _, Fs}) ->
record(lists:map(fun field/1, Fs)); record(lists:map(fun field/1, Fs));
expr_p(_, {map, Ann, KVs}) -> expr_p(_, {map, Ann, KVs}) ->
@ -387,6 +389,13 @@ stmt_p({else, Else}) ->
_ -> block_expr(200, text("else"), Else) _ -> block_expr(200, text("else"), Else)
end. end.
lc_bind({comprehension_bind, P, E}) ->
follow(hsep(expr(P), text("<-")), expr(E));
lc_bind({comprehension_if, _, E}) ->
beside([text("if("), expr(E), text(")")]);
lc_bind(Let) ->
letdecl("let", Let).
-spec bin_prec(aeso_syntax:bin_op()) -> {integer(), integer(), integer()}. -spec bin_prec(aeso_syntax:bin_op()) -> {integer(), integer(), integer()}.
bin_prec('..') -> { 0, 0, 0}; %% Always printed inside '[ ]' bin_prec('..') -> { 0, 0, 0}; %% Always printed inside '[ ]'
bin_prec('=') -> { 0, 0, 0}; %% Always printed inside '[ ]' bin_prec('=') -> { 0, 0, 0}; %% Always printed inside '[ ]'
@ -450,7 +459,7 @@ elim1(Get={map_get, _, _}) -> elim(Get);
elim1(Get={map_get, _, _, _}) -> elim(Get). elim1(Get={map_get, _, _, _}) -> elim(Get).
alt({'case', _, Pat, Body}) -> alt({'case', _, Pat, Body}) ->
block_expr(0, hsep(expr_p(500, Pat), text("=>")), Body). block_expr(0, hsep(expr(Pat), text("=>")), Body).
block_expr(_, Header, {block, _, Ss}) -> block_expr(_, Header, {block, _, Ss}) ->
block(Header, statements(Ss)); block(Header, statements(Ss));
@ -460,7 +469,7 @@ block_expr(P, Header, E) ->
statements(Stmts) -> statements(Stmts) ->
above([ statement(S) || S <- Stmts ]). above([ statement(S) || S <- Stmts ]).
statement(S = {letval, _, _, _, _}) -> letdecl("let", S); statement(S = {letval, _, _, _}) -> letdecl("let", S);
statement(S = {letfun, _, _, _, _, _}) -> letdecl("let", S); statement(S = {letfun, _, _, _, _, _}) -> letdecl("let", S);
statement(E) -> expr(E). statement(E) -> expr(E).

12
src/aeso_syntax.erl
View File

@ -47,7 +47,7 @@
-type pragma() :: {compiler, '==' | '<' | '>' | '=<' | '>=', compiler_version()}. -type pragma() :: {compiler, '==' | '<' | '>' | '=<' | '>=', compiler_version()}.
-type letbind() -type letbind()
:: {letval, ann(), id(), type(), expr()} :: {letval, ann(), pat(), expr()}
| {letfun, ann(), id(), [arg()], type(), expr()}. | {letfun, ann(), id(), [arg()], type(), expr()}.
-type arg() :: {arg, ann(), id(), type()}. -type arg() :: {arg, ann(), id(), type()}.
@ -100,9 +100,8 @@
| {list, ann(), [expr()]} | {list, ann(), [expr()]}
| {list_comp, ann(), expr(), [comprehension_exp()]} | {list_comp, ann(), expr(), [comprehension_exp()]}
| {typed, ann(), expr(), type()} | {typed, ann(), expr(), type()}
| {record, ann(), [field(expr())]} | {record_or_map(), ann(), [field(expr())]}
| {record, ann(), expr(), [field(expr())]} %% record update | {record_or_map(), ann(), expr(), [field(expr())]} %% record/map update
| {map, ann(), expr(), [field(expr())]} %% map update
| {map, ann(), [{expr(), expr()}]} | {map, ann(), [{expr(), expr()}]}
| {map_get, ann(), expr(), expr()} | {map_get, ann(), expr(), expr()}
| {map_get, ann(), expr(), expr(), expr()} | {map_get, ann(), expr(), expr(), expr()}
@ -111,7 +110,9 @@
| id() | qid() | con() | qcon() | id() | qid() | con() | qcon()
| constant(). | constant().
-type comprehension_exp() :: [ {comprehension_bind, id(), expr()} -type record_or_map() :: record | map | record_or_map_error.
-type comprehension_exp() :: [ {comprehension_bind, pat(), expr()}
| {comprehension_if, ann(), expr()} | {comprehension_if, ann(), expr()}
| letbind() ]. | letbind() ].
@ -139,6 +140,7 @@
-type pat() :: {app, ann(), con() | op(), [pat()]} -type pat() :: {app, ann(), con() | op(), [pat()]}
| {tuple, ann(), [pat()]} | {tuple, ann(), [pat()]}
| {list, ann(), [pat()]} | {list, ann(), [pat()]}
| {typed, ann(), pat(), type()}
| {record, ann(), [field(pat())]} | {record, ann(), [field(pat())]}
| constant() | constant()
| con() | con()

6
src/aeso_syntax_utils.erl
View File

@ -48,7 +48,7 @@ fold(Alg = #alg{zero = Zero, plus = Plus, scoped = Scoped}, Fun, K, X) ->
{type_decl, _, I, _} -> BindType(I); {type_decl, _, I, _} -> BindType(I);
{type_def, _, I, _, D} -> Plus(BindType(I), Decl(D)); {type_def, _, I, _, D} -> Plus(BindType(I), Decl(D));
{fun_decl, _, _, T} -> Type(T); {fun_decl, _, _, T} -> Type(T);
{letval, _, F, T, E} -> Sum([BindExpr(F), Type(T), Expr(E)]); {letval, _, P, E} -> Scoped(BindExpr(P), Expr(E));
{letfun, _, F, Xs, T, E} -> Sum([BindExpr(F), Type(T), Expr(Xs ++ [E])]); {letfun, _, F, Xs, T, E} -> Sum([BindExpr(F), Type(T), Expr(Xs ++ [E])]);
%% typedef() %% typedef()
{alias_t, T} -> Type(T); {alias_t, T} -> Type(T);
@ -76,8 +76,8 @@ fold(Alg = #alg{zero = Zero, plus = Plus, scoped = Scoped}, Fun, K, X) ->
Plus(Expr(E), Scoped(BindExpr(I), Expr({list_comp, A, Y, R}))); Plus(Expr(E), Scoped(BindExpr(I), Expr({list_comp, A, Y, R})));
{list_comp, A, Y, [{comprehension_if, _, E}|R]} -> {list_comp, A, Y, [{comprehension_if, _, E}|R]} ->
Plus(Expr(E), Expr({list_comp, A, Y, R})); Plus(Expr(E), Expr({list_comp, A, Y, R}));
{list_comp, A, Y, [D = {letval, _, F, _, _} | R]} -> {list_comp, A, Y, [D = {letval, _, Pat, _} | R]} ->
Plus(Decl(D), Scoped(BindExpr(F), Expr({list_comp, A, Y, R}))); Plus(Decl(D), Scoped(BindExpr(Pat), Expr({list_comp, A, Y, R})));
{list_comp, A, Y, [D = {letfun, _, F, _, _, _} | R]} -> {list_comp, A, Y, [D = {letfun, _, F, _, _, _} | R]} ->
Plus(Decl(D), Scoped(BindExpr(F), Expr({list_comp, A, Y, R}))); Plus(Decl(D), Scoped(BindExpr(F), Expr({list_comp, A, Y, R})));
{typed, _, E, T} -> Plus(Expr(E), Type(T)); {typed, _, E, T} -> Plus(Expr(E), Type(T));

10
test/aeso_aci_tests.erl
View File

@ -106,7 +106,7 @@ aci_test_contract(Name) ->
ok. ok.
check_stub(Stub, Options) -> check_stub(Stub, Options) ->
case aeso_parser:string(binary_to_list(Stub), Options) of try aeso_parser:string(binary_to_list(Stub), Options) of
Ast -> Ast ->
try try
%% io:format("AST: ~120p\n", [Ast]), %% io:format("AST: ~120p\n", [Ast]),
@ -117,9 +117,9 @@ check_stub(Stub, Options) ->
_:R -> _:R ->
io:format("Error: ~p\n", [R]), io:format("Error: ~p\n", [R]),
error(R) error(R)
end; end
{error, E} -> catch throw:{error, Errs} ->
io:format("Error: ~p\n", [E]), _ = [ io:format("~s\n", [aeso_errors:pp(E)]) || E <- Errs ],
error({parse_error, E}) error({parse_errors, Errs})
end. end.

16
test/aeso_compiler_tests.erl
View File

@ -138,6 +138,7 @@ compilable_contracts() ->
"test", "test",
"builtin_bug", "builtin_bug",
"builtin_map_get_bug", "builtin_map_get_bug",
"lc_record_bug",
"nodeadcode", "nodeadcode",
"deadcode", "deadcode",
"variant_types", "variant_types",
@ -162,7 +163,9 @@ compilable_contracts() ->
"payable", "payable",
"unapplied_builtins", "unapplied_builtins",
"underscore_number_literals", "underscore_number_literals",
"pairing_crypto" "pairing_crypto",
"qualified_constructor",
"let_patterns"
]. ].
not_yet_compilable(fate) -> []; not_yet_compilable(fate) -> [];
@ -596,6 +599,17 @@ failing_contracts() ->
[<<?Pos(5, 28) [<<?Pos(5, 28)
"Invalid call to contract entrypoint 'Foo.foo'.\n" "Invalid call to contract entrypoint 'Foo.foo'.\n"
"It must be called as 'c.foo' for some c : Foo.">>]) "It must be called as 'c.foo' for some c : Foo.">>])
, ?TYPE_ERROR(bad_records,
[<<?Pos(3, 16)
"Mixed record fields and map keys in\n"
" {x = 0, [0] = 1}">>,
<<?Pos(4, 6)
"Mixed record fields and map keys in\n"
" r {x = 0, [0] = 1}">>,
<<?Pos(5, 6)
"Empty record/map update\n"
" r {}">>
])
]. ].
-define(Path(File), "code_errors/" ??File). -define(Path(File), "code_errors/" ??File).

7
test/aeso_parser_tests.erl
View File

@ -4,6 +4,8 @@
-include_lib("eunit/include/eunit.hrl"). -include_lib("eunit/include/eunit.hrl").
id(X) -> X.
simple_contracts_test_() -> simple_contracts_test_() ->
{foreach, {foreach,
fun() -> ok end, fun() -> ok end,
@ -30,7 +32,7 @@ simple_contracts_test_() ->
end, end,
Parse = fun(S) -> Parse = fun(S) ->
try remove_line_numbers(parse_expr(S)) try remove_line_numbers(parse_expr(S))
catch _:_ -> ?assertMatch(ok, {parse_fail, S}) end catch _:_ -> ?assertMatch(ok, id({parse_fail, S})) end
end, end,
CheckParens = fun(Expr) -> CheckParens = fun(Expr) ->
?assertEqual(Parse(NoPar(Expr)), Parse(Par(Expr))) ?assertEqual(Parse(NoPar(Expr)), Parse(Par(Expr)))
@ -38,7 +40,6 @@ simple_contracts_test_() ->
LeftAssoc = fun(Op) -> CheckParens({{a, Op, b}, Op, c}) end, LeftAssoc = fun(Op) -> CheckParens({{a, Op, b}, Op, c}) end,
RightAssoc = fun(Op) -> CheckParens({a, Op, {b, Op, c}}) end, RightAssoc = fun(Op) -> CheckParens({a, Op, {b, Op, c}}) end,
NonAssoc = fun(Op) -> NonAssoc = fun(Op) ->
OpAtom = list_to_atom(Op),
?assertThrow({error, [_]}, ?assertThrow({error, [_]},
parse_expr(NoPar({a, Op, {b, Op, c}}))) end, parse_expr(NoPar({a, Op, {b, Op, c}}))) end,
Stronger = fun(Op1, Op2) -> Stronger = fun(Op1, Op2) ->
@ -77,7 +78,7 @@ parse_string(Text, Opts) ->
aeso_parser:string(Text, Opts). aeso_parser:string(Text, Opts).
parse_expr(Text) -> parse_expr(Text) ->
[{letval, _, _, _, Expr}] = [{letval, _, _, Expr}] =
parse_string("let _ = " ++ Text), parse_string("let _ = " ++ Text),
Expr. Expr.

5
test/contracts/bad_records.aes Normal file
View File

@ -0,0 +1,5 @@
contract BadRecord =
entrypoint foo() =
let r = {x = 0, [0] = 1}
r{x = 0, [0] = 1}
r{}

4
test/contracts/lc_record_bug.aes Normal file
View File

@ -0,0 +1,4 @@
contract Foo =
record r = {x : int}
// Crashed in the backend due to missing type annotation on the lc body.
entrypoint lc(xs) = [ {x = x} | x <- xs ]

15
test/contracts/let_patterns.aes Normal file
View File

@ -0,0 +1,15 @@
contract LetPatterns =
record r = {x : int, y : int, b : bool}
entrypoint test() = foo([1, 0], (2, 3), Some(4), {x = 5, y = 6, b = false})
entrypoint foo(xs : list(int), p : int * int, some : option(int), r : r) =
let x :: _ = xs
let (a, b) = p
let Some(n) = some
let {x = i, y = j} = r
x + a + b + n + i + j
entrypoint lc(xs : list(option(int))) : list(int) =
[ x | Some(x) <- xs ]

8
test/contracts/qualified_constructor.aes Normal file
View File

@ -0,0 +1,8 @@
namespace Foo =
datatype x = A | B(int)
contract Bar =
entrypoint f(a : Foo.x) =
switch(a)
Foo.A => 0
Foo.B(n) => n