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

Merge pull request #205 from aeternity/fate-flatten-store

Browse Source 
FATE backend optimisations
This commit is contained in:
Ulf Norell 2019-12-12 09:22:37 +01:00 committed by GitHub
commit b9f585ebaf
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 541 additions and 129 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

531
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 | '^' | '++' | '::' |
@ -61,6 +63,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.
@ -109,6 +113,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() }.
@ -130,12 +135,15 @@
| {namespace, string()} | {namespace, string()}
| {abstract_contract, string()}. | {abstract_contract, string()}.
-type state_layout() :: {tuple, [state_layout()]} | {reg, state_reg()}.
-type env() :: #{ type_env := type_env(), -type env() :: #{ type_env := type_env(),
fun_env := fun_env(), fun_env := fun_env(),
con_env := con_env(), con_env := con_env(),
event_type => aeso_syntax:typedef(), event_type => aeso_syntax:typedef(),
builtins := builtins(), builtins := builtins(),
options := [option()], options := [option()],
state_layout => state_layout(),
context => context(), context => context(),
vars => [var_name()], vars => [var_name()],
functions := #{ fun_name() => fun_def() } }. functions := #{ fun_name() => fun_def() } }.
@ -149,12 +157,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 ------------------------------------------------------------
@ -206,6 +216,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).
@ -221,7 +233,7 @@ init_type_env() ->
["hash"] => ?type(hash), ["hash"] => ?type(hash),
["signature"] => ?type(signature), ["signature"] => ?type(signature),
["oracle"] => ?type(Q, R, {oracle, Q, R}), ["oracle"] => ?type(Q, R, {oracle, Q, R}),
["oracle_query"] => ?type(_, _, oracle_query), %% TODO: not in Fate ["oracle_query"] => ?type(_, _, oracle_query),
["list"] => ?type(T, {list, T}), ["list"] => ?type(T, {list, T}),
["map"] => ?type(K, V, {map, K, V}), ["map"] => ?type(K, V, {map, K, V}),
["option"] => ?type(T, {variant, [[], [T]]}), ["option"] => ?type(T, {variant, [[], [T]]}),
@ -229,7 +241,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 ------------------------------------------------------------
@ -244,9 +262,11 @@ to_fcode(Env, [{contract, Attrs, MainCon = {con, _, Main}, Decls}]) ->
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),
StateLayout = state_layout(Env1),
Payable = proplists:get_value(payable, Attrs, false), 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,
@ -266,9 +286,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).
@ -304,14 +322,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,
@ -333,7 +352,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
@ -386,6 +432,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);
@ -446,7 +499,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}}) ->
@ -458,18 +511,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,
@ -556,8 +619,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 ->
@ -621,6 +684,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;
@ -708,10 +778,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()]}].
@ -834,7 +907,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};
@ -852,8 +925,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}).
@ -909,23 +982,40 @@ op_builtins() ->
crypto_ecverify_secp256k1, crypto_ecrecover_secp256k1 crypto_ecverify_secp256k1, crypto_ecrecover_secp256k1
]. ].
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}
@ -940,8 +1030,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) ->
@ -992,12 +1083,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').
@ -1010,8 +1099,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],
@ -1032,10 +1121,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;
@ -1044,40 +1133,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 ----------------------------------------------------------
@ -1095,7 +1186,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 ---
@ -1111,6 +1207,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().
@ -1232,10 +1568,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.
@ -1300,6 +1636,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);
@ -1329,6 +1667,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);
@ -1337,6 +1677,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,
@ -1371,6 +1755,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} ->
@ -1477,6 +1863,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) ->
@ -1579,9 +1969,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}) ->
@ -1594,6 +1993,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) ->
@ -1609,7 +2012,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}) ->

73
src/aeso_fcode_to_fate.erl
View File

@ -42,7 +42,7 @@
-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,42 +182,45 @@ 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}) ->
maps:get(X, Env);
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)}.
map_to_fate({op, map_set, [{var, _}, K, V]}) ->
#{term_to_fate(K) => term_to_fate(V)};
map_to_fate({op, map_set, [Set, K, V]}) ->
Map = map_to_fate(Set), Map#{term_to_fate(K) => term_to_fate(V)}.
to_scode(_Env, {lit, L}) -> to_scode(_Env, {lit, L}) ->
[push(?i(lit_to_fate(L)))]; [push(?i(lit_to_fate(L)))];
@ -298,6 +304,12 @@ 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, {get_state, Reg}) ->
[push(?s(Reg))];
to_scode(Env, {set_state, Reg, Val}) ->
call_to_scode(Env, [{'STORE', ?s(Reg), ?a},
tuple(0)], [Val]);
to_scode(Env, {closure, Fun, FVs}) -> to_scode(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]});
@ -420,11 +432,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);
@ -647,7 +654,7 @@ pp_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".
@ -1368,7 +1375,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 --------------------------------------------------------------
@ -1578,6 +1585,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 --
@ -1591,8 +1599,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]);

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.

5
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) ->