QPQ-AG/sophia
10
0
Fork 0
Code Issues 41 Pull Requests 5 Actions Packages Projects Releases 16 Wiki Activity
sophia/src/aeso_ast_to_fcode.erl
Gaith Hallak a027ac4f6a Add fann() to op
2023-06-09 13:17:04 +03:00

2273 lines
99 KiB
Erlang
Raw Blame History

%%%-------------------------------------------------------------------
%%% @author Ulf Norell
%%% @copyright (C) 2019, Aeternity Anstalt
%%% @doc
%%% Compiler from Aeterinty Sophia language to Fate intermediate code.
%%% @end
%%% Created : 26 Mar 2019
%%%
%%%-------------------------------------------------------------------
-module(aeso_ast_to_fcode).
-export([ast_to_fcode/2, format_fexpr/1]).
-export_type([fcode/0, fexpr/0, fun_def/0]).
-include("aeso_utils.hrl").
%% -- Type definitions -------------------------------------------------------
-type option() :: term().
-type attribute() :: stateful | payable | pure | private.
-type fun_name() :: {entrypoint, binary()}
| {local_fun, [string()]}
| event.
-type var_name() :: string().
-type sophia_name() :: [string()].
-type state_reg() :: pos_integer().
-type builtin() :: atom().
-type op() :: '+' | '-' | '*' | '/' | mod | '^' | '++' | '::' |
'<' | '>' | '=<' | '>=' | '==' | '!=' | '!' |
map_get | map_get_d | map_set | map_from_list | map_to_list |
map_delete | map_member | map_size | string_length |
string_concat | bits_set | bits_clear | bits_test | bits_sum |
bits_intersection | bits_union | bits_difference |
contract_to_address | address_to_contract | crypto_verify_sig | crypto_verify_sig_secp256k1 |
crypto_sha3 | crypto_sha256 | crypto_blake2b |
crypto_ecverify_secp256k1 | crypto_ecrecover_secp256k1 |
mcl_bls12_381_g1_neg | mcl_bls12_381_g1_norm | mcl_bls12_381_g1_valid |
mcl_bls12_381_g1_is_zero | mcl_bls12_381_g1_add | mcl_bls12_381_g1_mul |
mcl_bls12_381_g2_neg | mcl_bls12_381_g2_norm | mcl_bls12_381_g2_valid |
mcl_bls12_381_g2_is_zero | mcl_bls12_381_g2_add | mcl_bls12_381_g2_mul |
mcl_bls12_381_gt_inv | mcl_bls12_381_gt_add | mcl_bls12_381_gt_mul | mcl_bls12_381_gt_pow |
mcl_bls12_381_gt_is_one | mcl_bls12_381_pairing | mcl_bls12_381_miller_loop | mcl_bls12_381_final_exp |
mcl_bls12_381_int_to_fr | mcl_bls12_381_int_to_fp | mcl_bls12_381_fr_to_int | mcl_bls12_381_fp_to_int.
-type flit() :: {int, integer()}
| {string, binary()}
| {bytes, binary()}
| {account_pubkey, binary()}
| {contract_pubkey, binary()}
| {oracle_pubkey, binary()}
| {oracle_query_id, binary()}
| {bool, false | true}
| {contract_code, string()} %% for CREATE, by name
| {typerep, ftype()}.
-type fann() :: [ {line, aeso_syntax:ann_line()} ].
-type fexpr() :: {lit, flit()}
| nil
| {var, var_name()}
| {def, fann(), fun_name(), [fexpr()]}
| {remote, fann(), [ftype()], ftype(), fexpr(), fun_name(), [fexpr()]}
| {builtin, builtin(), [fexpr()]}
| {con, arities(), tag(), [fexpr()]}
| {tuple, [fexpr()]}
| {proj, fann(), fexpr(), integer()}
| {set_proj, fann(), fexpr(), integer(), fexpr()} %% tuple, field, new_value
| {op, fann(), op(), [fexpr()]}
| {'let', var_name(), fexpr(), fexpr()}
| {funcall, fann(), fexpr(), [fexpr()]} %% Call to unknown function
| {closure, fann(), fun_name(), fexpr()}
| {switch, fsplit()}
| {set_state, fann(), state_reg(), fexpr()}
| {get_state, state_reg()}
%% The following (unapplied top-level functions/builtins and
%% lambdas) are generated by the fcode compiler, but translated
%% to closures by the lambda lifter.
| {def_u, fann(), fun_name(), arity()}
| {remote_u, fann(), [ftype()], ftype(), fexpr(), fun_name()}
| {builtin_u, builtin(), arity()}
| {builtin_u, builtin(), arity(), [fexpr()]} %% Typerep arguments to be added after normal args.
| {lam, [var_name()], fexpr()}.
-type fsplit() :: {split, ftype(), var_name(), [fcase()]}
| {nosplit, fexpr()}.
-type fcase() :: {'case', fsplit_pat(), fsplit()}.
-type fsplit_pat() :: {var, var_name()}
| {bool, false | true}
| {int, integer()}
| {string, binary()}
| nil
| {'::', var_name(), var_name()}
| {con, arities(), tag(), [var_name()]}
| {tuple, [var_name()]}
| {assign, var_name(), var_name()}.
-type ftype() :: integer
| boolean
| string
| {list, ftype()}
| {map, ftype(), ftype()}
| {tuple, [ftype()]}
| address
| {bytes, non_neg_integer()}
| contract
| {oracle, ftype(), ftype()} %% Query type, Response type
| oracle_query
| name
| channel
| bits
| {variant, [[ftype()]]}
| {function, [ftype()], ftype()}
| any | {tvar, var_name()}.
-type fun_def() :: #{ attrs := [attribute()],
args := [{var_name(), ftype()}],
return := ftype(),
body := fexpr() }.
-type fcode() :: #{ contract_name := string(),
state_type := ftype(),
state_layout := state_layout(),
event_type := ftype() | none,
functions := #{ fun_name() => fun_def() },
payable := boolean() }.
-type type_def() :: fun(([ftype()]) -> ftype()).
-type tag() :: non_neg_integer().
-type arities() :: [arity()].
-record(con_tag, { tag :: tag(), arities :: arities() }).
-type con_tag() :: #con_tag{}.
-type type_env() :: #{ sophia_name() => type_def() }.
-type fun_env() :: #{ sophia_name() => {fun_name(), non_neg_integer()} }.
-type con_env() :: #{ sophia_name() => con_tag() }.
-type child_con_env() :: #{sophia_name() => fcode()}.
-type builtins() :: #{ sophia_name() => {builtin(), non_neg_integer() | none | variable} }.
-type context() :: {contract_def, string()}
| {namespace, string()}
| {abstract_contract, string()}.
-type state_layout() :: {tuple, [state_layout()]} | {reg, state_reg()}.
-type env() :: #{ type_env := type_env(),
fun_env := fun_env(),
con_env := con_env(),
child_con_env := child_con_env(),
event_type => aeso_syntax:typedef(),
builtins := builtins(),
options := [option()],
state_layout => state_layout(),
context => context(),
vars => [var_name()],
functions := #{ fun_name() => fun_def() },
consts := #{ var_name() => fexpr() },
saved_fresh_names => #{ var_name() => var_name() }
}.
-define(HASH_BYTES, 32).
%% -- Entrypoint -------------------------------------------------------------
%% Main entrypoint. Takes typed syntax produced by aeso_ast_infer_types:infer/1,2
%% and produces Fate intermediate code.
-spec ast_to_fcode(aeso_syntax:ast(), [option()]) -> {env(), fcode()}.
ast_to_fcode(Code, Options) ->
init_fresh_names(Options),
{Env1, FCode1} = to_fcode(init_env(Options), Code),
FCode2 = optimize(FCode1, Options),
Env2 = Env1#{ child_con_env :=
maps:map(
fun (_, FC) -> optimize(FC, Options) end,
maps:get(child_con_env, Env1)
)},
Env3 =
case proplists:get_value(debug_info, Options, false) of
true -> Env2#{ saved_fresh_names => get(saved_fresh_names) };
false -> Env2
end,
clear_fresh_names(Options),
{Env3, FCode2}.
optimize(FCode1, Options) ->
Verbose = lists:member(pp_fcode, Options),
[io:format("-- Before lambda lifting --\n~s\n\n", [format_fcode(FCode1)]) || Verbose],
FCode2 = optimize_fcode(FCode1, Options),
[ io:format("-- After optimization --\n~s\n\n", [format_fcode(FCode2)]) || Verbose, FCode2 /= FCode1 ],
FCode3 = lambda_lift(FCode2),
[ io:format("-- After lambda lifting --\n~s\n\n", [format_fcode(FCode3)]) || Verbose, FCode3 /= FCode2 ],
FCode3.
%% -- Environment ------------------------------------------------------------
-spec init_env([option()]) -> env().
init_env(Options) ->
ChainTxArities = [3, 0, 0, 0, 0, 0, 1, 1, 1, 2, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, 2, 0],
#{ type_env => init_type_env(),
fun_env => #{},
builtins => builtins(),
child_con_env => #{},
con_env => #{["None"] => #con_tag{ tag = 0, arities = [0, 1] },
["Some"] => #con_tag{ tag = 1, arities = [0, 1] },
["RelativeTTL"] => #con_tag{ tag = 0, arities = [1, 1] },
["FixedTTL"] => #con_tag{ tag = 1, arities = [1, 1] },
["AENS", "AccountPt"] => #con_tag{ tag = 0, arities = [1, 1, 1, 1] },
["AENS", "OraclePt"] => #con_tag{ tag = 1, arities = [1, 1, 1, 1] },
["AENS", "ContractPt"] => #con_tag{ tag = 2, arities = [1, 1, 1, 1] },
["AENS", "ChannelPt"] => #con_tag{ tag = 3, arities = [1, 1, 1, 1] },
["AENS", "Name"] => #con_tag{ tag = 0, arities = [3] },
["Chain", "GAMetaTx"] => #con_tag{ tag = 0, arities = [2] },
["Chain", "PayingForTx"] => #con_tag{ tag = 0, arities = [2] },
["Chain", "SpendTx"] => #con_tag{ tag = 0, arities = ChainTxArities },
["Chain", "OracleRegisterTx"] => #con_tag{ tag = 1, arities = ChainTxArities },
["Chain", "OracleQueryTx"] => #con_tag{ tag = 2, arities = ChainTxArities },
["Chain", "OracleResponseTx"] => #con_tag{ tag = 3, arities = ChainTxArities },
["Chain", "OracleExtendTx"] => #con_tag{ tag = 4, arities = ChainTxArities },
["Chain", "NamePreclaimTx"] => #con_tag{ tag = 5, arities = ChainTxArities },
["Chain", "NameClaimTx"] => #con_tag{ tag = 6, arities = ChainTxArities },
["Chain", "NameUpdateTx"] => #con_tag{ tag = 7, arities = ChainTxArities },
["Chain", "NameRevokeTx"] => #con_tag{ tag = 8, arities = ChainTxArities },
["Chain", "NameTransferTx"] => #con_tag{ tag = 9, arities = ChainTxArities },
["Chain", "ChannelCreateTx"] => #con_tag{ tag = 10, arities = ChainTxArities },
["Chain", "ChannelDepositTx"] => #con_tag{ tag = 11, arities = ChainTxArities },
["Chain", "ChannelWithdrawTx"] => #con_tag{ tag = 12, arities = ChainTxArities },
["Chain", "ChannelForceProgressTx"] => #con_tag{ tag = 13, arities = ChainTxArities },
["Chain", "ChannelCloseMutualTx"] => #con_tag{ tag = 14, arities = ChainTxArities },
["Chain", "ChannelCloseSoloTx"] => #con_tag{ tag = 15, arities = ChainTxArities },
["Chain", "ChannelSlashTx"] => #con_tag{ tag = 16, arities = ChainTxArities },
["Chain", "ChannelSettleTx"] => #con_tag{ tag = 17, arities = ChainTxArities },
["Chain", "ChannelSnapshotSoloTx"] => #con_tag{ tag = 18, arities = ChainTxArities },
["Chain", "ContractCreateTx"] => #con_tag{ tag = 19, arities = ChainTxArities },
["Chain", "ContractCallTx"] => #con_tag{ tag = 20, arities = ChainTxArities },
["Chain", "GAAttachTx"] => #con_tag{ tag = 21, arities = ChainTxArities }
},
options => Options,
functions => #{},
consts => #{}
}.
-spec builtins() -> builtins().
builtins() ->
MkName = fun(NS, Fun) ->
list_to_atom(string:to_lower(string:join(NS ++ [Fun], "_")))
end,
Scopes = [{[], [{"abort", 1}, {"require", 2}, {"exit", 1}]},
{["Chain"], [{"spend", 2}, {"balance", 1}, {"block_hash", 1}, {"coinbase", none},
{"timestamp", none}, {"block_height", none}, {"difficulty", none},
{"gas_limit", none}, {"bytecode_hash", 1}, {"create", variable}, {"clone", variable}]},
{["Contract"], [{"address", none}, {"balance", none}, {"creator", none}]},
{["Call"], [{"origin", none}, {"caller", none}, {"value", none}, {"gas_price", none}, {"fee", none},
{"gas_left", 0}]},
{["Oracle"], [{"register", 4}, {"expiry", 1}, {"query_fee", 1}, {"query", 5}, {"get_question", 2},
{"respond", 4}, {"extend", 3}, {"get_answer", 2},
{"check", 1}, {"check_query", 2}]},
{["AENS"], [{"resolve", 2}, {"preclaim", 3}, {"claim", 5}, {"transfer", 4},
{"revoke", 3}, {"update", 6}, {"lookup", 1}]},
{["Map"], [{"from_list", 1}, {"to_list", 1}, {"lookup", 2},
{"lookup_default", 3}, {"delete", 2}, {"member", 2}, {"size", 1}]},
{["Crypto"], [{"verify_sig", 3}, {"verify_sig_secp256k1", 3},
{"ecverify_secp256k1", 3}, {"ecrecover_secp256k1", 2},
{"sha3", 1}, {"sha256", 1}, {"blake2b", 1}]},
{["MCL_BLS12_381"], [{"g1_neg", 1}, {"g1_norm", 1}, {"g1_valid", 1}, {"g1_is_zero", 1}, {"g1_add", 2}, {"g1_mul", 2},
{"g2_neg", 1}, {"g2_norm", 1}, {"g2_valid", 1}, {"g2_is_zero", 1}, {"g2_add", 2}, {"g2_mul", 2},
{"gt_inv", 1}, {"gt_add", 2}, {"gt_mul", 2}, {"gt_pow", 2}, {"gt_is_one", 1},
{"pairing", 2}, {"miller_loop", 2}, {"final_exp", 1},
{"int_to_fr", 1}, {"int_to_fp", 1}, {"fr_to_int", 1}, {"fp_to_int", 1}]},
{["StringInternal"], [{"length", 1}, {"concat", 2}, {"to_list", 1}, {"from_list", 1},
{"sha3", 1}, {"sha256", 1}, {"blake2b", 1}, {"to_lower", 1}, {"to_upper", 1}]},
{["Char"], [{"to_int", 1}, {"from_int", 1}]},
{["Auth"], [{"tx_hash", none}, {"tx", none}]},
{["Bits"], [{"set", 2}, {"clear", 2}, {"test", 2}, {"sum", 1}, {"intersection", 2},
{"union", 2}, {"difference", 2}, {"none", none}, {"all", none}]},
{["Bytes"], [{"to_int", 1}, {"to_str", 1}, {"concat", 2}, {"split", 1}]},
{["Int"], [{"to_str", 1}]},
{["Address"], [{"to_str", 1}, {"to_contract", 1}, {"is_oracle", 1}, {"is_contract", 1}, {"is_payable", 1}]}
],
maps:from_list([ {NS ++ [Fun], {MkName(NS, Fun), Arity}}
|| {NS, Funs} <- Scopes,
{Fun, Arity} <- Funs ]).
state_layout(Env) -> maps:get(state_layout, Env, {reg, 1}).
-define(type(T), fun([]) -> T end).
-define(type(X, T), fun([X]) -> T end).
-define(type(X, Y, T), fun([X, Y]) -> T end).
-spec init_type_env() -> type_env().
init_type_env() ->
BaseTx = {variant, [[address, integer, string], [], [], [], [], [], [string],
[{bytes, 32}], [{bytes, 32}], [address, {bytes, 32}], [address],
[address, integer], [address, integer], [address],
[address], [address], [address], [address], [address],
[integer], [address, integer], []]},
#{ ["int"] => ?type(integer),
["bool"] => ?type(boolean),
["bits"] => ?type(bits),
["char"] => ?type(integer),
["string"] => ?type(string),
["address"] => ?type(address),
["hash"] => ?type(hash),
["signature"] => ?type(signature),
["oracle"] => ?type(Q, R, {oracle, Q, R}),
["oracle_query"] => ?type(_, _, oracle_query), %% TODO: not in Fate
["list"] => ?type(T, {list, T}),
["map"] => ?type(K, V, {map, K, V}),
["option"] => ?type(T, {variant, [[], [T]]}),
["Chain", "ttl"] => ?type({variant, [[integer], [integer]]}),
["AENS", "pointee"] => ?type({variant, [[address], [address], [address], [address]]}),
["AENS", "name"] => ?type({variant, [[address, {variant, [[integer], [integer]]}, {map, string, {variant, [[address], [address], [address], [address]]}}]]}),
["Chain", "ga_meta_tx"] => ?type({variant, [[address, integer]]}),
["Chain", "paying_for_tx"] => ?type({variant, [[address, integer]]}),
["Chain", "base_tx"] => ?type(BaseTx),
["MCL_BLS12_381", "fr"] => ?type({bytes, 32}),
["MCL_BLS12_381", "fp"] => ?type({bytes, 48})
}.
is_no_code(Env) ->
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 ------------------------------------------------------------
-spec to_fcode(env(), aeso_syntax:ast()) -> {env(), fcode()}.
to_fcode(Env, [{Contract, Attrs, {con, _, Name}, _Impls, Decls}|Rest])
when ?IS_CONTRACT_HEAD(Contract) ->
case Contract =:= contract_interface of
false ->
#{ builtins := Builtins } = Env,
ConEnv = maps:remove(state_layout,
Env#{ context => {contract_def, Name},
builtins => Builtins#{[Name, "state"] => {get_state, none},
[Name, "put"] => {set_state, 1},
[Name, "Chain", "event"] => {chain_event, 1}} }),
#{ functions := PrevFuns } = ConEnv,
#{ functions := Funs } = Env1 =
decls_to_fcode(ConEnv, Decls),
StateType = lookup_type(Env1, [Name, "state"], [], {tuple, []}),
EventType = lookup_type(Env1, [Name, "event"], [], none),
StateLayout = state_layout(Env1),
Payable = proplists:get_value(payable, Attrs, false),
ConFcode = #{ contract_name => Name,
state_type => StateType,
state_layout => StateLayout,
event_type => EventType,
payable => Payable,
functions => add_init_function(
Env1,
add_event_function(Env1, EventType, Funs)) },
case Contract of
contract_main -> [] = Rest, {Env1, ConFcode};
contract_child ->
Env2 = add_child_con(Env1, Name, ConFcode),
Env3 = Env2#{ functions := PrevFuns },
to_fcode(Env3, Rest)
end;
true ->
Env1 = decls_to_fcode(Env#{ context => {abstract_contract, Name} }, Decls),
to_fcode(Env1, Rest)
end;
to_fcode(Env, [{namespace, _, {con, _, Con}, Decls} | Code]) ->
Env1 = decls_to_fcode(Env#{ context => {namespace, Con} }, Decls),
to_fcode(Env1, Code).
-spec to_fann(aeso_syntax:ann()) -> fann().
to_fann(Ann) ->
proplists:lookup_all(line, Ann).
-spec get_fann(fexpr()) -> fann().
get_fann(FExpr) -> element(2, FExpr).
-spec decls_to_fcode(env(), [aeso_syntax:decl()]) -> env().
decls_to_fcode(Env, Decls) ->
%% First compute mapping from Sophia names to fun_names and add it to the
%% environment.
Env1 = add_fun_env(Env, Decls),
lists:foldl(fun(D, E) -> decl_to_fcode(E, D)
end, Env1, Decls).
-spec decl_to_fcode(env(), aeso_syntax:decl()) -> env().
decl_to_fcode(Env, {fun_decl, _, _, _}) -> Env;
decl_to_fcode(Env, {type_def, _Ann, Name, Args, Def}) ->
typedef_to_fcode(Env, Name, Args, Def);
decl_to_fcode(Env = #{ functions := Funs }, {letfun, Ann, {id, _, Name}, Args, Ret, [{guarded, _, [], Body}]}) ->
Attrs = get_attributes(Ann),
FName = lookup_fun(Env, qname(Env, Name)),
FArgs = args_to_fcode(Env, Args),
FRet = type_to_fcode(Env, Ret),
FBody = expr_to_fcode(Env#{ vars => [X || {X, _} <- FArgs] }, Body),
Def = #{ attrs => Attrs,
args => FArgs,
return => FRet,
body => FBody },
NewFuns = Funs#{ FName => Def },
Env#{ functions := NewFuns };
decl_to_fcode(Env = #{ consts := Consts }, {letval, _, {typed, _, {id, _, X}, _}, Val}) ->
FVal = expr_to_fcode(Env, Val),
NewConsts = Consts#{ qname(Env, X) => FVal },
Env#{ consts := NewConsts }.
-spec typedef_to_fcode(env(), aeso_syntax:id(), [aeso_syntax:tvar()], aeso_syntax:typedef()) -> env().
typedef_to_fcode(Env, {id, _, Name}, Xs, Def) ->
Q = qname(Env, Name),
FDef = fun(Args) when length(Args) == length(Xs) ->
Sub = maps:from_list(lists:zip([X || {tvar, _, X} <- Xs], Args)),
case Def of
{record_t, Fields} ->
{tuple, [type_to_fcode(Env, Sub, T) || {field_t, _, _, T} <- Fields]};
{variant_t, Cons} ->
FCons = [ begin
{constr_t, _, _, Ts} = Con,
[type_to_fcode(Env, Sub, T) || T <- Ts]
end || Con <- Cons ],
{variant, FCons};
{alias_t, Type} -> type_to_fcode(Env, Sub, Type)
end;
(Args) -> internal_error({type_arity_mismatch, Name, length(Args), length(Xs)})
end,
Constructors =
case Def of
{variant_t, Cons} ->
Arities = [ begin
{constr_t, _, _, Args} = Con,
length(Args)
end || Con <- Cons ],
Tags = [ #con_tag{ tag = I, arities = Arities } || I <- lists:seq(0, length(Cons) - 1) ],
GetName = fun({constr_t, _, {con, _, C}, _}) -> C end,
QName = fun(Con) -> qname(Env, GetName(Con)) end,
maps:from_list([ {QName(Con), Tag} || {Tag, Con} <- lists:zip(Tags, Cons) ]);
_ -> #{}
end,
Env1 = bind_constructors(Env, Constructors),
Env2 = case Name of
"event" -> Env1#{ event_type => Def };
_ -> Env1
end,
Env3 = compute_state_layout(Env2, Name, FDef),
bind_type(Env3, Q, FDef).
compute_state_layout(Env = #{ context := {contract_def, _} }, "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}}.
-spec type_to_fcode(env(), aeso_syntax:type()) -> ftype().
type_to_fcode(Env, Type) ->
type_to_fcode(Env, #{}, Type).
-spec type_to_fcode(env(), #{var_name() => ftype()}, aeso_syntax:type()) -> ftype().
type_to_fcode(_Env, _Sub, {con, _, _}) -> contract;
type_to_fcode(Env, Sub, {app_t, _, T = {Id, _, _}, Types}) when Id == id; Id == qid ->
lookup_type(Env, T, [type_to_fcode(Env, Sub, Type) || Type <- Types]);
type_to_fcode(Env, _Sub, T = {Id, _, _}) when Id == id; Id == qid ->
lookup_type(Env, T, []);
type_to_fcode(Env, Sub, {tuple_t, _, Types}) ->
{tuple, [type_to_fcode(Env, Sub, T) || T <- Types]};
type_to_fcode(Env, Sub, {record_t, Fields}) ->
FieldType = fun({field_t, _, _, Ty}) -> Ty end,
type_to_fcode(Env, Sub, {tuple_t, [], lists:map(FieldType, Fields)});
type_to_fcode(_Env, _Sub, {bytes_t, _, N}) ->
{bytes, N};
type_to_fcode(_Env, Sub, {tvar, _, X}) ->
maps:get(X, Sub, {tvar, X});
type_to_fcode(_Env, _Sub, {fun_t, Ann, _, var_args, _}) ->
fcode_error({var_args_not_set, {id, Ann, "a very suspicious function"}});
type_to_fcode(Env, Sub, {fun_t, _, Named, Args, Res}) ->
FNamed = [type_to_fcode(Env, Sub, Arg) || {named_arg_t, _, _, Arg, _} <- Named],
FArgs = [type_to_fcode(Env, Sub, Arg) || Arg <- Args],
{function, FNamed ++ FArgs, type_to_fcode(Env, Sub, Res)};
type_to_fcode(Env, Sub, {if_t, _, _, _, Else}) ->
type_to_fcode(Env, Sub, Else); %% Hacky: this is only for remote calls, in which case we want the unprotected type
type_to_fcode(_Env, _Sub, Type) ->
error({todo, Type}).
-spec args_to_fcode(env(), [aeso_syntax:pat()]) -> [{var_name(), ftype()}].
args_to_fcode(Env, Args) ->
[ case Arg of
{id, _, Name} -> {Name, type_to_fcode(Env, Type)};
_ -> internal_error({bad_arg, Arg}) %% Pattern matching has been moved to the rhs at this point
end || {typed, _, Arg, Type} <- Args ].
-define(make_let(X, Expr, Body),
make_let(Expr, fun(X) -> Body end)).
make_let(Expr, Body) ->
case Expr of
{var, _} -> Body(Expr);
{lit, {int, _}} -> Body(Expr);
{lit, {bool, _}} -> Body(Expr);
_ ->
X = fresh_name(),
{'let', X, Expr, Body({var, X})}
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().
expr_to_fcode(Env, {typed, _, Expr, Type}) ->
expr_to_fcode(Env, Type, Expr);
expr_to_fcode(Env, Expr) ->
expr_to_fcode(Env, no_type, Expr).
-spec expr_to_fcode(env(), aeso_syntax:type() | no_type, aeso_syntax:expr()) -> fexpr().
%% Literals
expr_to_fcode(_Env, _Type, {int, _, N}) -> {lit, {int, N}};
expr_to_fcode(_Env, _Type, {char, _, N}) -> {lit, {int, N}};
expr_to_fcode(_Env, _Type, {bool, _, B}) -> {lit, {bool, B}};
expr_to_fcode(_Env, _Type, {string, _, S}) -> {lit, {string, S}};
expr_to_fcode(_Env, _Type, {account_pubkey, _, K}) -> {lit, {account_pubkey, K}};
expr_to_fcode(_Env, _Type, {contract_pubkey, _, K}) -> {lit, {contract_pubkey, K}};
expr_to_fcode(_Env, _Type, {oracle_pubkey, _, K}) -> {lit, {oracle_pubkey, K}};
expr_to_fcode(_Env, _Type, {oracle_query_id, _, K}) -> {lit, {oracle_query_id, K}};
expr_to_fcode(_Env, _Type, {bytes, _, B}) -> {lit, {bytes, B}};
%% Variables
expr_to_fcode(Env, _Type, {id, _, X}) -> resolve_var(Env, [X]);
expr_to_fcode(Env, Type, {qid, _, X}) ->
case resolve_var(Env, X) of
{builtin_u, B, Ar} when B =:= oracle_query;
B =:= oracle_get_question;
B =:= oracle_get_answer;
B =:= oracle_respond;
B =:= oracle_register;
B =:= oracle_check;
B =:= oracle_check_query ->
OType = get_oracle_type(B, Type),
{oracle, QType, RType} = type_to_fcode(Env, OType),
TypeArgs = [{lit, {typerep, QType}}, {lit, {typerep, RType}}],
{builtin_u, B, Ar, TypeArgs};
{builtin_u, B = aens_resolve, Ar} ->
{fun_t, _, _, _, ResType} = Type,
AensType = type_to_fcode(Env, ResType),
TypeArgs = [{lit, {typerep, AensType}}],
{builtin_u, B, Ar, TypeArgs};
{builtin_u, B = bytes_split, Ar} ->
{fun_t, _, _, _, {tuple_t, _, [{bytes_t, _, N}, _]}} = Type,
{builtin_u, B, Ar, [{lit, {int, N}}]};
Other -> Other
end;
%% Constructors
expr_to_fcode(Env, Type, {C, _, _} = Con) when C == con; C == qcon ->
expr_to_fcode(Env, Type, {app, [], {typed, [], Con, Type}, []});
expr_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Args}) when C == con; C == qcon ->
#con_tag{ tag = I, arities = Arities } = lookup_con(Env, Con),
Arity = lists:nth(I + 1, Arities),
case length(Args) == Arity of
true -> {con, Arities, I, [expr_to_fcode(Env, Arg) || Arg <- Args]};
false -> internal_error({constructor_arity_mismatch, Con, length(Args), Arity})
end;
%% Tuples
expr_to_fcode(Env, _Type, {tuple, _, Es}) ->
make_tuple([expr_to_fcode(Env, E) || E <- Es]);
%% Records
expr_to_fcode(Env, Type, {proj, Ann, Rec = {typed, _, _, RecType}, {id, _, X}}) ->
case RecType of
{con, _, _} when X == "address" ->
{op, to_fann(Ann), contract_to_address, [expr_to_fcode(Env, Rec)]};
{con, _, _} ->
{fun_t, _, _, Args, Ret} = Type,
FArgs = [type_to_fcode(Env, Arg) || Arg <- Args],
{remote_u, to_fann(Ann), FArgs, type_to_fcode(Env, Ret), expr_to_fcode(Env, Rec),
{entrypoint, list_to_binary(X)}};
{record_t, [_]} -> expr_to_fcode(Env, Rec); %% Singleton record
{record_t, _} ->
{proj, to_fann(Ann), expr_to_fcode(Env, Rec), field_index(Rec, X)}
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}) ->
FVal = fun(F) ->
%% All fields are present and no updates
{set, E} = field_value(F, Fields),
expr_to_fcode(Env, E)
end,
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}) ->
X = fresh_name(),
Proj = fun(I) -> {proj, to_fann(Ann), {var, X}, I - 1} end,
Comp = fun({I, false}) -> Proj(I);
({_, {set, E}}) -> expr_to_fcode(Env, E);
({I, {upd, Z, E}}) -> {'let', Z, Proj(I), expr_to_fcode(bind_var(Env, Z), E)}
end,
Set = fun({_, false}, R) -> R;
({I, {set, E}}, R) -> {set_proj, to_fann(Ann), R, I - 1, expr_to_fcode(Env, E)};
({I, {upd, Z, E}}, R) -> {set_proj, to_fann(Ann), R, I - 1,
{'let', Z, Proj(I), expr_to_fcode(bind_var(Env, Z), E)}}
end,
Expand = length(Fields) == length(FieldTypes),
Updates = [ {I, field_value(FT, Fields)} || {I, FT} <- indexed(FieldTypes) ],
Body = case Expand of
true -> {tuple, lists:map(Comp, Updates)};
false -> lists:foldr(Set, {var, X}, Updates)
end,
{'let', X, expr_to_fcode(Env, Rec), Body};
%% Lists
expr_to_fcode(Env, _Type, {list, _, Es}) ->
lists:foldr(fun(E, L) -> {op, to_fann(aeso_syntax:get_ann(E)), '::', [expr_to_fcode(Env, E), L]} end,
nil, Es);
expr_to_fcode(Env, _Type, {app, _, {'..', _}, [A, B]}) ->
{def_u, Ann, FromTo, _} = resolve_fun(Env, ["ListInternal", "from_to"]),
{def, Ann, FromTo, [expr_to_fcode(Env, A), expr_to_fcode(Env, B)]};
expr_to_fcode(Env, _Type, {list_comp, As, Yield, []}) ->
{op, to_fann(As), '::', [expr_to_fcode(Env, Yield), nil]};
expr_to_fcode(Env, _Type, {list_comp, As, Yield, [{comprehension_bind, Pat = {typed, _, _, PatType}, BindExpr}|Rest]}) ->
Arg = fresh_name(),
Env1 = bind_var(Env, Arg),
Bind = {lam, [Arg], expr_to_fcode(Env1, {switch, As, {typed, As, {id, As, Arg}, PatType},
[{'case', As, Pat, [{guarded, As, [], {list_comp, As, Yield, Rest}}]},
{'case', As, {id, As, "_"}, [{guarded, As, [], {list, As, []}}]}]})},
{def_u, Ann, FlatMap, _} = resolve_fun(Env, ["ListInternal", "flat_map"]),
{def, Ann, FlatMap, [Bind, expr_to_fcode(Env, BindExpr)]};
expr_to_fcode(Env, Type, {list_comp, As, Yield, [{comprehension_if, _, Cond}|Rest]}) ->
make_if(expr_to_fcode(Env, Cond),
expr_to_fcode(Env, Type, {list_comp, As, Yield, Rest}),
nil
);
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, {list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}) ->
expr_to_fcode(Env, Type, {block, As, [LF, {list_comp, As, Yield, Rest}]});
%% Conditionals
expr_to_fcode(Env, _Type, {'if', _, Cond, Then, Else}) ->
make_if(expr_to_fcode(Env, Cond),
expr_to_fcode(Env, Then),
expr_to_fcode(Env, Else));
%% Switch
expr_to_fcode(Env, _, S = {switch, _, Expr = {typed, _, E, Type}, Alts}) ->
Switch = fun(X) ->
{switch, alts_to_fcode(Env, type_to_fcode(Env, Type), X, Alts, S)}
end,
case E of
{id, _, X} -> Switch(X);
_ ->
X = fresh_name(),
{'let', X, expr_to_fcode(Env, Expr),
Switch(X)}
end;
%% Blocks
expr_to_fcode(Env, _Type, {block, _, Stmts}) ->
stmts_to_fcode(Env, Stmts);
%% Binary operator
expr_to_fcode(Env, _Type, Expr = {app, _, {Op, _}, [_, _]}) when Op == '&&'; Op == '||' ->
Tree = expr_to_decision_tree(Env, Expr),
decision_tree_to_fcode(Tree);
expr_to_fcode(Env, Type, {app, Ann, {Op, _}, [A, B]}) when is_atom(Op) ->
case Op of
'|>' -> expr_to_fcode(Env, Type, {app, Ann, B, [A]});
_ -> {op, to_fann(Ann), Op, [expr_to_fcode(Env, A), expr_to_fcode(Env, B)]}
end;
expr_to_fcode(Env, _Type, {app, Ann, {Op, _}, [A]}) when is_atom(Op) ->
FAnn = to_fann(Ann),
case Op of
'-' -> {op, FAnn, '-', [{lit, {int, 0}}, expr_to_fcode(Env, A)]};
'!' -> {op, FAnn, '!', [expr_to_fcode(Env, A)]}
end;
%% Function calls
expr_to_fcode(Env, _, {app, _, Fun = {typed, Ann, FunE, {fun_t, _, NamedArgsT, ArgsT, Type}}, Args}) ->
Args1 = get_named_args(NamedArgsT, Args),
FArgs = [expr_to_fcode(Env, Arg) || Arg <- Args1],
case expr_to_fcode(Env, Fun) of
{builtin_u, B, _Ar, TypeArgs} -> builtin_to_fcode(state_layout(Env), B, FArgs ++ TypeArgs);
{builtin_u, chain_clone, _Ar} ->
case ArgsT of
var_args -> fcode_error({var_args_not_set, FunE});
_ ->
%% Here we little cheat on the typechecker, but this inconsistency
%% is to be solved in `aeso_fcode_to_fate:type_to_scode/1`
FInitArgsT = aeb_fate_data:make_typerep([type_to_fcode(Env, T) || T <- ArgsT]),
builtin_to_fcode(state_layout(Env), chain_clone, [{lit, FInitArgsT}|FArgs])
end;
{builtin_u, chain_create, _Ar} ->
case {ArgsT, Type} of
{var_args, _} -> fcode_error({var_args_not_set, FunE});
{_, {con, _, Contract}} ->
FInitArgsT = aeb_fate_data:make_typerep([type_to_fcode(Env, T) || T <- ArgsT]),
builtin_to_fcode(state_layout(Env), chain_create, [{lit, {contract_code, Contract}}, {lit, FInitArgsT}|FArgs]);
{_, _} -> fcode_error({not_a_contract_type, Type})
end;
{builtin_u, B, _Ar} -> builtin_to_fcode(state_layout(Env), B, FArgs);
{def_u, Ann, F, _Ar} -> {def, Ann, F, FArgs};
{remote_u, Ann, RArgsT, RRetT, Ct, RFun} -> {remote, Ann, RArgsT, RRetT, Ct, RFun, FArgs};
FFun ->
%% FFun is a closure, with first component the function name and
%% second component the environment
FAnn = to_fann(Ann),
Call = fun(X) -> {funcall, FAnn, {proj, FAnn, {var, X}, 0}, [{proj, FAnn, {var, X}, 1} | FArgs]} end,
case FFun of
{var, X} -> Call(X);
_ -> X = fresh_name(),
{'let', X, FFun, Call(X)}
end
end;
%% Maps
expr_to_fcode(_Env, _Type, {map, _, []}) ->
{builtin, map_empty, []};
expr_to_fcode(Env, Type, {map, Ann, KVs}) ->
%% Cheaper to do incremental map_update than building the list and doing
%% map_from_list (I think).
Fields = [{field, Ann, [{map_get, Ann, K}], V} || {K, V} <- KVs],
expr_to_fcode(Env, Type, {map, Ann, {map, Ann, []}, Fields});
expr_to_fcode(Env, _Type, {map, _, Map, KVs}) ->
?make_let(Map1, expr_to_fcode(Env, Map),
lists:foldr(fun(Fld, M) ->
case Fld of
{field, Ann, [{map_get, _, K}], V} ->
{op, to_fann(Ann), map_set, [M, expr_to_fcode(Env, K), expr_to_fcode(Env, V)]};
{field_upd, Ann, [MapGet], {typed, _, {lam, _, [{arg, _, {id, _, Z}, _}], V}, _}} when element(1, MapGet) == map_get ->
[map_get, _, K | Default] = tuple_to_list(MapGet),
?make_let(Key, expr_to_fcode(Env, K),
begin
%% Z might shadow Map1 or Key
Z1 = fresh_name(),
FAnn = to_fann(Ann),
GetExpr =
case Default of
[] -> {op, FAnn, map_get, [Map1, Key]};
[D] -> {op, FAnn, map_get_d, [Map1, Key, expr_to_fcode(Env, D)]}
end,
{'let', Z1, GetExpr,
{op, FAnn, map_set, [M, Key, rename([{Z, Z1}], expr_to_fcode(bind_var(Env, Z), V))]}}
end)
end end, Map1, KVs));
expr_to_fcode(Env, _Type, {map_get, Ann, Map, Key}) ->
{op, to_fann(Ann), map_get, [expr_to_fcode(Env, Map), expr_to_fcode(Env, Key)]};
expr_to_fcode(Env, _Type, {map_get, Ann, Map, Key, Def}) ->
{op, to_fann(Ann), map_get_d, [expr_to_fcode(Env, Map), expr_to_fcode(Env, Key), expr_to_fcode(Env, Def)]};
expr_to_fcode(Env, _Type, {lam, _, Args, Body}) ->
GetArg = fun({arg, _, {id, _, X}, _}) -> X end,
Xs = lists:map(GetArg, Args),
{lam, Xs, expr_to_fcode(bind_vars(Env, Xs), Body)};
expr_to_fcode(_Env, Type, Expr) ->
error({todo, {Expr, ':', Type}}).
make_if({var, X}, Then, Else) ->
{switch, {split, boolean, X,
[{'case', {bool, false}, {nosplit, Else}},
{'case', {bool, true}, {nosplit, Then}}]}};
make_if(Cond, Then, Else) ->
X = fresh_name(),
{'let', X, Cond, make_if({var, X}, Then, Else)}.
make_if_no_else({var, X}, Then) ->
{switch, {split, boolean, X,
[{'case', {bool, true}, {nosplit, Then}}]}};
make_if_no_else(Cond, Then) ->
X = fresh_name(),
{'let', X, Cond, make_if_no_else({var, X}, Then)}.
-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_query, {fun_t, _, _, [OType | _], _}) -> OType;
get_oracle_type(oracle_get_question, {fun_t, _, _, [OType | _], _}) -> OType;
get_oracle_type(oracle_get_answer, {fun_t, _, _, [OType | _], _}) -> OType;
get_oracle_type(oracle_check, {fun_t, _, _, [OType | _], _}) -> OType;
get_oracle_type(oracle_check_query, {fun_t, _, _, [OType | _], _}) -> OType;
get_oracle_type(oracle_respond, {fun_t, _, _, [OType | _], _}) -> OType.
%% -- Pattern matching --
-spec alts_to_fcode(env(), ftype(), var_name(), [aeso_syntax:alt()], aeso_syntax:expr()) -> fsplit().
alts_to_fcode(Env, Type, X, Alts, Switch) ->
FAlts = remove_guards(Env, Alts, Switch),
split_tree(Env, [{X, Type}], FAlts).
%% Intermediate format before case trees (fcase() and fsplit()).
-type falt() :: {'case', [fpat()], fexpr()}.
-type fpat() :: {var, var_name()}
| {bool, false | true}
| {int, integer()}
| {string, binary()}
| nil | {'::', fpat(), fpat()}
| {tuple, [fpat()]}
| {con, arities(), tag(), [fpat()]}
| {assign, fpat(), fpat()}.
remove_guards(_Env, [], _Switch) ->
[];
remove_guards(Env, [Alt = {'case', _, _, [{guarded, _, [], _Expr}]} | Rest], Switch) ->
[alt_to_fcode(Env, Alt) | remove_guards(Env, Rest, Switch)];
remove_guards(Env, [{'case', AnnC, Pat, [{guarded, AnnG, [Guard | Guards], Body} | GuardedBodies]} | Rest], Switch = {switch, Ann, Expr, _}) ->
FPat = pat_to_fcode(Env, Pat),
FGuard = expr_to_fcode(bind_vars(Env, pat_vars(FPat)), Guard),
FBody = expr_to_fcode(bind_vars(Env, pat_vars(FPat)), Body),
case Guards of
[] ->
R = case GuardedBodies of
[] -> Rest;
_ -> [{'case', AnnC, Pat, GuardedBodies} | Rest]
end,
case R of
[] ->
[{'case', [FPat], make_if_no_else(FGuard, FBody)} | remove_guards(Env, Rest, Switch)];
_ ->
FSwitch = expr_to_fcode(Env, {switch, Ann, Expr, R}),
[{'case', [FPat], make_if(FGuard, FBody, FSwitch)} | remove_guards(Env, Rest, Switch)]
end;
_ ->
R1 = case GuardedBodies of
[] -> [{'case', AnnC, Pat, [{guarded, AnnG, Guards, Body}]} | Rest];
_ -> [{'case', AnnC, Pat, [{guarded, AnnG, Guards, Body} | GuardedBodies]} | Rest]
end,
R2 = case GuardedBodies of
[] -> Rest;
_ -> [{'case', AnnC, Pat, GuardedBodies} | Rest]
end,
FSwitch1 = expr_to_fcode(Env, {switch, Ann, Expr, R1}),
FSwitch2 = expr_to_fcode(Env, {switch, Ann, Expr, R2}),
[{'case', [FPat], make_if(FGuard, FSwitch1, FSwitch2)} | remove_guards(Env, Rest, Switch)]
end.
%% %% Invariant: the number of variables matches the number of patterns in each falt.
-spec split_tree(env(), [{var_name(), ftype()}], [falt()]) -> fsplit().
split_tree(_Env, _Vars, []) ->
error(non_exhaustive_patterns); %% TODO: nice error
split_tree(Env, Vars, Alts = [{'case', Pats, Body} | _]) ->
case next_split(Pats) of
false ->
Xs = [ X || {X, _} <- Vars ],
Ys = [ Y || {var, Y} <- Pats ],
Ren = [ {Y, X} || {Y, X} <- lists:zip(Ys, Xs), X /= Y, Y /= "_" ],
%% TODO: Unreachable clauses error
{nosplit, rename(Ren, Body)};
I when is_integer(I) ->
{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 ]),
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 ],
{split, Type1, X, Cases}
end.
-spec merge_alts(integer(), var_name(), [{fsplit_pat(), falt()}]) -> [{fsplit_pat(), [falt()]}].
merge_alts(I, X, Alts) ->
merge_alts(I, X, Alts, []).
merge_alts(I, X, Alts, Alts1) ->
lists:foldr(fun(A, As) -> merge_alt(I, X, A, As) end,
Alts1, Alts).
-spec merge_alt(integer(), var_name(), {fsplit_pat(), falt()}, Alts) -> Alts
when Alts :: [{fsplit_pat(), [falt()]}].
merge_alt(_, _, {P, A}, []) -> [{P, [A]}];
merge_alt(I, X, {P, A}, [{Q, As} | Rest]) ->
Match = fun({var, _}, {var, _}) -> match;
({tuple, _}, {tuple, _}) -> match;
({bool, B}, {bool, B}) -> match;
({int, N}, {int, N}) -> match;
({string, S}, {string, S}) -> match;
(nil, nil) -> match;
({'::', _, _}, {'::', _, _}) -> match;
({con, _, C, _}, {con, _, C, _}) -> match;
({con, _, _, _}, {con, _, _, _}) -> mismatch;
({var, _}, _) -> expand;
(_, {var, _}) -> insert;
(_, _) -> mismatch
end,
case Match(P, Q) of
match -> [{Q, [A | As]} | Rest];
mismatch -> [{Q, As} | merge_alt(I, X, {P, A}, Rest)];
expand ->
{Before, After} = expand(I, X, P, Q, A),
merge_alts(I, X, Before, [{Q, As} | merge_alts(I, X, After, Rest)]);
insert -> [{P, [A]}, {Q, As} | Rest]
end.
expand(I, X, P, Q, Case = {'case', Ps, E}) ->
{Ps0, [{var, Y} | Ps1]} = lists:split(I - 1, Ps),
{Ps0r, Ren1} = rename_fpats([{Y, X} || Y /= X], Ps0),
{Ps1r, Ren2} = rename_fpats(Ren1, Ps1),
E1 = rename(Ren2, E),
Splice = fun(N) -> Ps0r ++ lists:duplicate(N, {var, "_"}) ++ Ps1r end,
Type = fun({tuple, Xs}) -> {tuple, length(Xs)};
({bool, _}) -> bool;
({int, _}) -> int;
({string, _}) -> string;
(nil) -> list;
({'::', _, _}) -> list;
({con, As, _, _}) -> {variant, As}
end,
MkCase = fun(Pat, Vars) -> {Pat, {'case', Splice(Vars), E1}} end,
case Type(Q) of
{tuple, N} -> {[MkCase(Q, N)], []};
bool -> {[MkCase({bool, B}, 0) || B <- [false, true]], []};
int -> {[MkCase(Q, 0)], [{P, Case}]};
string -> {[MkCase(Q, 0)], [{P, Case}]};
list -> {[MkCase(nil, 0), MkCase({'::', fresh_name(), fresh_name()}, 2)], []};
{variant, As} -> {[MkCase({con, As, C - 1, [fresh_name() || _ <- lists:seq(1, Ar)]}, Ar)
|| {C, Ar} <- indexed(As)], []}
end.
-spec split_alt(integer(), falt()) -> {fsplit_pat(), falt()}.
split_alt(I, {'case', Pats, Body}) ->
{Pats0, [Pat | Pats1]} = lists:split(I - 1, Pats),
{SPat, InnerPats} = split_pat(Pat),
{SPat, {'case', Pats0 ++ InnerPats ++ Pats1, Body}}.
-spec split_pat(fpat()) -> {fsplit_pat(), [fpat()]}.
split_pat(P = {var, _}) -> {{var, fresh_name()}, [P]};
split_pat({bool, B}) -> {{bool, B}, []};
split_pat({int, N}) -> {{int, N}, []};
split_pat({string, N}) -> {{string, N}, []};
split_pat(nil) -> {nil, []};
split_pat({'::', P, Q}) -> {{'::', fresh_name(), fresh_name()}, [P, Q]};
split_pat({con, As, I, Pats}) ->
Xs = [fresh_name() || _ <- Pats],
{{con, As, I, Xs}, Pats};
split_pat({assign, X = {var, _}, P}) ->
{{assign, fresh_name(), fresh_name()}, [X, P]};
split_pat({tuple, Pats}) ->
Xs = [fresh_name() || _ <- Pats],
{{tuple, Xs}, Pats}.
-spec split_vars(fsplit_pat(), ftype()) -> [{var_name(), ftype()}].
split_vars({bool, _}, boolean) -> [];
split_vars({int, _}, integer) -> [];
split_vars({string, _}, string) -> [];
split_vars(nil, {list, _}) -> [];
split_vars({'::', X, Xs}, {list, T}) -> [{X, T}, {Xs, {list, T}}];
split_vars({assign, X, P}, T) -> [{X, T}, {P, T}];
split_vars({con, _, I, Xs}, {variant, Cons}) ->
lists:zip(Xs, lists:nth(I + 1, Cons));
split_vars({tuple, Xs}, {tuple, Ts}) ->
lists:zip(Xs, Ts);
split_vars({var, X}, T) -> [{X, T}].
-spec next_split([fpat()]) -> integer() | false.
next_split(Pats) ->
IsVar = fun({var, _}) -> true; (_) -> false end,
case [ I || {I, P} <- indexed(Pats), not IsVar(P) ] of
[] -> false;
[I | _] -> I
end.
-spec alt_to_fcode(env(), aeso_syntax:alt()) -> falt().
alt_to_fcode(Env, {'case', _, Pat, [{guarded, _, [], Expr}]}) ->
FPat = pat_to_fcode(Env, Pat),
FExpr = expr_to_fcode(bind_vars(Env, pat_vars(FPat)), Expr),
{'case', [FPat], FExpr}.
-spec pat_to_fcode(env(), aeso_syntax:pat()) -> fpat().
pat_to_fcode(Env, {typed, _, Pat, Type}) ->
pat_to_fcode(Env, Type, Pat);
pat_to_fcode(Env, Pat) ->
pat_to_fcode(Env, no_type, Pat).
-spec pat_to_fcode(env(), aeso_syntax:type() | no_type, aeso_syntax:pat()) -> fpat().
pat_to_fcode(_Env, _Type, {id, _, X}) -> {var, X};
pat_to_fcode(Env, _Type, {C, _, _} = Con) when C == con; C == qcon ->
#con_tag{tag = I, arities = As} = lookup_con(Env, Con),
{con, As, I, []};
pat_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Pats}) when C == con; C == qcon ->
#con_tag{tag = I, arities = As} = lookup_con(Env, Con),
{con, As, I, [pat_to_fcode(Env, Pat) || Pat <- Pats]};
pat_to_fcode(Env, _Type, {tuple, _, Pats}) ->
make_tuple([ pat_to_fcode(Env, Pat) || Pat <- Pats ]);
pat_to_fcode(_Env, _Type, {bool, _, B}) -> {bool, B};
pat_to_fcode(_Env, _Type, {int, _, N}) -> {int, N};
pat_to_fcode(_Env, _Type, {char, _, N}) -> {int, N};
pat_to_fcode(_Env, _Type, {string, _, N}) -> {string, N};
pat_to_fcode(Env, _Type, {list, _, Ps}) ->
lists:foldr(fun(P, Qs) ->
{'::', pat_to_fcode(Env, P), Qs}
end, nil, Ps);
pat_to_fcode(Env, _Type, {app, _, {'::', _}, [P, Q]}) ->
{'::', pat_to_fcode(Env, P), pat_to_fcode(Env, Q)};
pat_to_fcode(Env, {record_t, Fields}, {record, _, FieldPats}) ->
FieldPat = fun(F) ->
case field_value(F, FieldPats) of
false -> {id, [], "_"};
{set, Pat} -> Pat
%% {upd, _, _} is impossible in patterns
end end,
make_tuple([pat_to_fcode(Env, FieldPat(Field))
|| Field <- Fields]);
pat_to_fcode(Env, _Type, {letpat, _, Id = {typed, _, {id, _, _}, _}, Pattern}) ->
{assign, pat_to_fcode(Env, Id), pat_to_fcode(Env, Pattern)};
pat_to_fcode(_Env, Type, Pat) ->
error({todo, Pat, ':', Type}).
%% -- Decision trees for boolean operators --
decision_op('&&', {atom, A}, B) -> {'if', A, B, false};
decision_op('&&', false, _) -> false;
decision_op('&&', true, B) -> B;
decision_op('||', {atom, A}, B) -> {'if', A, true, B};
decision_op('||', false, B) -> B;
decision_op('||', true, _) -> true;
decision_op(Op, {'if', A, Then, Else}, B) ->
{'if', A, decision_op(Op, Then, B), decision_op(Op, Else, B)}.
expr_to_decision_tree(Env, {app, _Ann, {Op, _}, [A, B]}) when Op == '&&'; Op == '||' ->
decision_op(Op, expr_to_decision_tree(Env, A), expr_to_decision_tree(Env, B));
expr_to_decision_tree(Env, {typed, _, Expr, _}) -> expr_to_decision_tree(Env, Expr);
expr_to_decision_tree(Env, Expr) ->
{atom, expr_to_fcode(Env, Expr)}.
decision_tree_to_fcode(false) -> {lit, {bool, false}};
decision_tree_to_fcode(true) -> {lit, {bool, true}};
decision_tree_to_fcode({atom, B}) -> B;
decision_tree_to_fcode({'if', A, Then, Else}) ->
X = fresh_name(),
{'let', X, A,
{switch, {split, boolean, X, [{'case', {bool, false}, {nosplit, decision_tree_to_fcode(Else)}},
{'case', {bool, true}, {nosplit, decision_tree_to_fcode(Then)}}]}}}.
%% -- Statements --
-spec stmts_to_fcode(env(), [aeso_syntax:stmt()]) -> fexpr().
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)};
stmts_to_fcode(Env, [{letval, Ann, Pat, Expr} | Stmts]) ->
expr_to_fcode(Env, {switch, Ann, Expr, [{'case', Ann, Pat, [{guarded, Ann, [], {block, Ann, Stmts}}]}]});
stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, [{guarded, _, [], Expr}]} | Stmts]) ->
LamArgs = [ case Arg of
{typed, Ann1, Id, T} -> {arg, Ann1, Id, T};
_ -> internal_error({bad_arg, Arg}) %% pattern matching has been desugared
end || Arg <- Args ],
{'let', X, expr_to_fcode(Env, {lam, Ann, LamArgs, Expr}),
stmts_to_fcode(bind_var(Env, X), Stmts)};
stmts_to_fcode(Env, [Expr]) ->
expr_to_fcode(Env, Expr);
stmts_to_fcode(Env, [Expr | Stmts]) ->
{'let', "_", expr_to_fcode(Env, Expr), stmts_to_fcode(Env, Stmts)}.
%% -- Builtins --
op_builtins() ->
[map_from_list, map_to_list, map_delete, map_member, map_size,
stringinternal_length, stringinternal_concat, stringinternal_to_list, stringinternal_from_list,
stringinternal_sha3, stringinternal_sha256, stringinternal_blake2b,
char_to_int, char_from_int, stringinternal_to_lower, stringinternal_to_upper,
bits_set, bits_clear, bits_test, bits_sum, bits_intersection, bits_union,
bits_difference, int_to_str, address_to_str, crypto_verify_sig,
address_to_contract,
crypto_verify_sig_secp256k1, crypto_sha3, crypto_sha256, crypto_blake2b,
crypto_ecverify_secp256k1, crypto_ecrecover_secp256k1,
mcl_bls12_381_g1_neg, mcl_bls12_381_g1_norm, mcl_bls12_381_g1_valid,
mcl_bls12_381_g1_is_zero, mcl_bls12_381_g1_add, mcl_bls12_381_g1_mul,
mcl_bls12_381_g2_neg, mcl_bls12_381_g2_norm, mcl_bls12_381_g2_valid,
mcl_bls12_381_g2_is_zero, mcl_bls12_381_g2_add, mcl_bls12_381_g2_mul,
mcl_bls12_381_gt_inv, mcl_bls12_381_gt_add, mcl_bls12_381_gt_mul, mcl_bls12_381_gt_pow,
mcl_bls12_381_gt_is_one, mcl_bls12_381_pairing, mcl_bls12_381_miller_loop, mcl_bls12_381_final_exp,
mcl_bls12_381_int_to_fr, mcl_bls12_381_int_to_fp, mcl_bls12_381_fr_to_int, mcl_bls12_381_fp_to_int
].
set_state({reg, R}, Val) ->
{set_state, get_fann(Val), R, Val};
set_state({tuple, Ls}, Val) ->
?make_let(X, Val,
lists:foldr(fun({I, L}, Code) ->
{'let', "_", set_state(L, {proj, get_fann(Val), 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]});
builtin_to_fcode(_Layout, chain_event, [Event]) ->
{def, [], event, [Event]};
builtin_to_fcode(_Layout, map_delete, [Key, Map]) ->
{op, get_fann(Map), map_delete, [Map, Key]};
builtin_to_fcode(_Layout, map_member, [Key, Map]) ->
{op, get_fann(Map), map_member, [Map, Key]};
builtin_to_fcode(_Layout, map_lookup, [Key0, Map0]) ->
?make_let(Key, Key0,
?make_let(Map, Map0,
make_if({op, get_fann(Map), map_member, [Map, Key]},
{con, [0, 1], 1, [{op, get_fann(Map), map_get, [Map, Key]}]},
{con, [0, 1], 0, []})));
builtin_to_fcode(_Layout, map_lookup_default, [Key, Map, Def]) ->
{op, get_fann(Map), map_get_d, [Map, Key, Def]};
builtin_to_fcode(_Layout, Builtin, Args) ->
FAnn = case Args of
[Arg | _] -> to_fann(aeso_syntax:get_ann(Arg));
_ -> []
end,
case lists:member(Builtin, op_builtins()) of
true -> {op, FAnn, Builtin, Args};
false -> {builtin, Builtin, Args}
end.
%% -- Init function --
add_init_function(Env, Funs0) ->
case is_no_code(Env) of
true -> Funs0;
false ->
Funs = add_default_init_function(Env, Funs0),
InitName = {entrypoint, <<"init">>},
InitFun = #{ body := InitBody} = maps:get(InitName, Funs),
Funs1 = Funs#{ InitName => InitFun#{ return => {tuple, []},
body => builtin_to_fcode(state_layout(Env), set_state, [InitBody]) } },
Funs1
end.
add_default_init_function(_Env, Funs) ->
InitName = {entrypoint, <<"init">>},
case maps:get(InitName, Funs, none) of
none ->
Funs#{ InitName => #{attrs => [],
args => [],
return => {tuple, []},
body => {tuple, []}} };
_ -> Funs
end.
%% -- Event function --
add_event_function(_Env, none, Funs) -> Funs;
add_event_function(Env, EventFType, Funs) ->
Funs#{ event => event_function(Env, EventFType) }.
event_function(_Env = #{event_type := {variant_t, EventCons}}, EventType = {variant, FCons}) ->
Cons = [ {Name, I - 1, proplists:get_value(indices, Ann)}
|| {I, {constr_t, Ann, {con, _, Name}, _}} <- indexed(EventCons) ],
Arities = [length(Ts) || Ts <- FCons],
Case = fun({Name, Tag, Ixs}) ->
{ok, HashValue} = eblake2:blake2b(?HASH_BYTES, list_to_binary(Name)),
Hash = {lit, {bytes, HashValue}},
Vars = [ "arg" ++ integer_to_list(I) || I <- lists:seq(1, length(Ixs)) ],
IVars = lists:zip(Ixs, Vars),
Payload =
case [ V || {notindexed, V} <- IVars ] of
[] -> {lit, {string, <<>>}};
[V] -> {var, V}
end,
Indices = [ {var, V} || {indexed, V} <- IVars ],
Body = {builtin, chain_event, [Payload, Hash | Indices]},
{'case', {con, Arities, Tag, Vars}, {nosplit, Body}}
end,
#{ attrs => [private],
args => [{"e", EventType}],
return => {tuple, []},
body => {switch, {split, EventType, "e", lists:map(Case, Cons)}} }.
%% -- Lambda lifting ---------------------------------------------------------
%% The expr_to_fcode compiler lambda expressions to {lam, Xs, Body}, but in
%% FATE we can only call top-level functions, so we need to lift the lambda to
%% the top-level and replace it with a closure.
-spec lambda_lift(fcode()) -> fcode().
lambda_lift(FCode = #{ functions := Funs, state_layout := StateLayout }) ->
init_lambda_funs(),
Funs1 = maps:map(fun(_, Body) -> lambda_lift_fun(StateLayout, Body) end, Funs),
NewFuns = get_lambda_funs(),
FCode#{ functions := maps:merge(Funs1, NewFuns) }.
-define(lambda_key, '%lambdalifted').
init_lambda_funs() -> put(?lambda_key, #{}).
get_lambda_funs() -> erase(?lambda_key).
add_lambda_fun(Def) ->
Name = fresh_fun(),
Funs = get(?lambda_key),
put(?lambda_key, Funs#{ Name => Def }),
Name.
lambda_lift_fun(Layout, Def = #{ body := Body }) ->
Def#{ body := lambda_lift_expr(Layout, Body) }.
lifted_fun([Z], Xs, Body) ->
#{ attrs => [private],
args => [{Z, any} | [{X, any} || X <- Xs]],
return => any,
body => Body };
lifted_fun(FVs, Xs, Body) ->
Z = "%env",
Proj = fun({I, Y}, E) -> {'let', Y, {proj, get_fann(Body), {var, Z}, I - 1}, E} end,
#{ attrs => [private],
args => [{Z, any} | [{X, any} || X <- Xs]],
return => any,
body => lists:foldr(Proj, Body, indexed(FVs))
}.
make_closure(FVs, Xs, Body) ->
Fun = add_lambda_fun(lifted_fun(FVs, Xs, Body)),
Tup = fun([Y]) -> Y; (Ys) -> {tuple, Ys} end,
{closure, get_fann(Body), Fun, Tup([{var, Y} || Y <- FVs])}.
lambda_lift_expr(Layout, {lam, Xs, Body}) ->
FVs = free_vars({lam, Xs, Body}),
make_closure(FVs, Xs, lambda_lift_expr(Layout, Body));
lambda_lift_expr(Layout, UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == builtin_u ->
[Tag, _, F, Ar | _] = tuple_to_list(UExpr),
ExtraArgs = case UExpr of
{builtin_u, _, _, TypeArgs} -> TypeArgs;
_ -> []
end,
Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, Ar) ],
Args = [{var, X} || X <- Xs] ++ ExtraArgs,
Body = case Tag of
builtin_u -> builtin_to_fcode(Layout, F, Args);
def_u -> {def, [], F, Args}
end,
make_closure([], Xs, Body);
lambda_lift_expr(Layout, {remote_u, Ann, ArgsT, RetT, Ct, F}) ->
FVs = free_vars(Ct),
Ct1 = lambda_lift_expr(Layout, Ct),
NamedArgCount = 3,
Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, length(ArgsT) + NamedArgCount) ],
Args = [{var, X} || X <- Xs],
make_closure(FVs, Xs, {remote, Ann, ArgsT, RetT, Ct1, F, Args});
lambda_lift_expr(Layout, Expr) ->
case Expr of
{lit, _} -> Expr;
nil -> Expr;
{var, _} -> Expr;
{closure, _, _, _} -> Expr;
{def, Ann, D, As} -> {def, Ann, D, lambda_lift_exprs(Layout, As)};
{builtin, B, As} -> {builtin, B, lambda_lift_exprs(Layout, As)};
{remote, Ann, ArgsT, RetT, Ct, F, As} -> {remote, Ann, ArgsT, RetT, lambda_lift_expr(Layout, Ct), F, lambda_lift_exprs(Layout, As)};
{con, Ar, C, As} -> {con, Ar, C, lambda_lift_exprs(Layout, As)};
{tuple, As} -> {tuple, lambda_lift_exprs(Layout, As)};
{proj, Ann, A, I} -> {proj, Ann, lambda_lift_expr(Layout, A), I};
{set_proj, Ann, A, I, B} -> {set_proj, Ann, lambda_lift_expr(Layout, A), I, lambda_lift_expr(Layout, B)};
{op, Ann, Op, As} -> {op, Ann, Op, lambda_lift_exprs(Layout, As)};
{'let', X, A, B} -> {'let', X, lambda_lift_expr(Layout, A), lambda_lift_expr(Layout, B)};
{funcall, Ann, A, Bs} -> {funcall, Ann, lambda_lift_expr(Layout, A), lambda_lift_exprs(Layout, Bs)};
{set_state, Ann, R, A} -> {set_state, Ann, R, lambda_lift_expr(Layout, A)};
{get_state, _} -> Expr;
{switch, S} -> {switch, lambda_lift_expr(Layout, 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.
lambda_lift_exprs(Layout, As) -> [lambda_lift_expr(Layout, A) || A <- As].
%% -- Optimisations ----------------------------------------------------------
%% - Deadcode elimination
%% - Unused variable analysis (replace by _)
%% - Case specialization
%% - Constant propagation
%% - Inlining
-spec optimize_fcode(fcode(), [option()]) -> fcode().
optimize_fcode(Code = #{ functions := Funs }, Options) ->
Code1 = Code#{ functions := maps:map(fun(Name, Def) -> optimize_fun(Code, Name, Def, Options) end, Funs) },
eliminate_dead_code(Code1).
-spec optimize_fun(fcode(), fun_name(), fun_def(), [option()]) -> fun_def().
optimize_fun(Fcode, Fun, Def = #{ body := Body0 }, Options) ->
Inliner = proplists:get_value(optimize_inliner, Options, true),
InlineLocalFunctions = proplists:get_value(optimize_inline_local_functions, Options, true),
BindSubexpressions = proplists:get_value(optimize_bind_subexpressions, Options, true),
LetFloating = proplists:get_value(optimize_let_floating, Options, true),
Simplifier = proplists:get_value(optimize_simplifier, Options, true),
DropUnusedLets = proplists:get_value(optimize_drop_unused_lets, Options, true),
Body1 = if Inliner -> inliner (Fcode, Fun, Body0); true -> Body0 end,
Body2 = if InlineLocalFunctions -> inline_local_functions(Body1); true -> Body1 end,
Body3 = if BindSubexpressions -> bind_subexpressions (Body2); true -> Body2 end,
Body4 = if LetFloating -> let_floating (Body3); true -> Body3 end,
Body5 = if Simplifier -> simplifier (Body4); true -> Body4 end,
Body6 = if DropUnusedLets -> drop_unused_lets (Body5); true -> Body5 end,
Def#{ body := Body6 }.
%% --- Inlining ---
-spec inliner(fcode(), fun_name(), fexpr()) -> fexpr().
inliner(Fcode, Fun, {def, _, Fun1, Args} = E) when Fun1 /= Fun ->
case should_inline(Fcode, Fun1) of
false -> E;
true -> inline(Fcode, Fun1, Args)
end;
inliner(_Fcode, _Fun, E) -> E.
should_inline(_Fcode, _Fun1) -> false == list_to_atom("true"). %% Dialyzer
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, Ann, A, I, B}) ->
?make_lets([X, Y], [A, B], {set_proj, Ann, 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, Ann, E, I}) ->
pull_out_let({proj, Ann, {here, E}, I});
let_float(_, {set_proj, Ann, E, I, V}) ->
pull_out_let({set_proj, Ann, {here, E}, I, {here, V}});
let_float(_, {op, Ann, Op, Es}) ->
{Lets, Es1} = pull_out_let([{here, E} || E <- Es]),
let_bind(Lets, {op, Ann, 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.
get_catchalls(Alts) ->
[ C || C = {'case', {var, _}, _} <- Alts ].
%% The scode compiler can't handle multiple catch-alls, so we need to nest them
%% inside each other. Instead of
%% _ => switch(x) ..
%% _ => e
%% we do
%% _ => switch(x)
%% ..
%% _ => e
add_catchalls(Alts, []) -> Alts;
add_catchalls(Alts, Catchalls) ->
case lists:splitwith(fun({'case', {var, _}, _}) -> false; (_) -> true end,
Alts) of
{Alts1, [C]} -> Alts1 ++ [nest_catchalls([C | Catchalls])];
{_, []} -> Alts ++ [nest_catchalls(Catchalls)]
%% NOTE: relies on catchalls always being at the end
end.
nest_catchalls([C = {'case', {var, _}, {nosplit, _}} | _]) -> C;
nest_catchalls([{'case', P = {var, _}, {split, Type, X, Alts}} | Catchalls]) ->
{'case', P, {split, Type, X, add_catchalls(Alts, Catchalls)}}.
simpl_switch(_Env, _, {nosplit, E}) -> E;
simpl_switch(Env, Catchalls, {split, Type, X, Alts}) ->
Alts1 = add_catchalls(Alts, Catchalls),
Stuck = {switch, {split, Type, X, Alts1}},
case constructor_form(Env, {var, X}) of
false -> Stuck;
E ->
case simpl_case(Env, E, Alts1) of
stuck -> Stuck;
Res -> Res
end
end.
simpl_case(_, _, []) -> nomatch;
simpl_case(Env, E, [{'case', Pat, Body} | Alts]) ->
case match_pat(Pat, E) of
false -> simpl_case(Env, E, Alts);
Binds ->
Env1 = maps:merge(Env, maps:from_list(Binds)),
case simpl_switch(Env1, get_catchalls(Alts), Body) of
nomatch -> simpl_case(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({assign, X, P}, E) -> [{X, E}, {P, 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 ---
-spec eliminate_dead_code(fcode()) -> fcode().
eliminate_dead_code(Code = #{ functions := Funs }) ->
UsedFuns = used_functions(Funs),
Code#{ functions := maps:filter(fun(Name, _) -> maps:is_key(Name, UsedFuns) end,
Funs) }.
-spec used_functions(#{ fun_name() => fun_def() }) -> #{ fun_name() => true }.
used_functions(Funs) ->
Exported = [ Fun || {Fun, #{ attrs := Attrs }} <- maps:to_list(Funs),
not lists:member(private, Attrs) ],
used_functions(#{}, Exported, Funs).
used_functions(Used, [], _) -> Used;
used_functions(Used, [Name | Rest], Defs) ->
case maps:is_key(Name, Used) of
true -> used_functions(Used, Rest, Defs);
false ->
New =
case maps:get(Name, Defs, undef) of
undef -> []; %% We might be compiling a stub
#{ body := Body } -> used_defs(Body)
end,
used_functions(Used#{ Name => true }, New ++ Rest, Defs)
end.
%% -- Helper functions -------------------------------------------------------
%% -- Types --
-spec lookup_type(env(), aeso_syntax:id() | aeso_syntax:qid() | sophia_name(), [ftype()]) -> ftype().
lookup_type(Env, {id, _, Name}, Args) ->
lookup_type(Env, [Name], Args);
lookup_type(Env, {qid, _, Name}, Args) ->
lookup_type(Env, Name, Args);
lookup_type(Env, Name, Args) ->
case lookup_type(Env, Name, Args, not_found) of
not_found -> internal_error({unknown_type, Name});
Type -> Type
end.
-spec lookup_type(env(), sophia_name(), [ftype()], ftype() | A) -> ftype() | A.
lookup_type(#{ type_env := TypeEnv }, Name, Args, Default) ->
case maps:get(Name, TypeEnv, false) of
false -> Default;
Fun -> Fun(Args)
end.
-spec bind_type(env(), sophia_name(), type_def()) -> env().
bind_type(Env = #{type_env := TEnv}, Q, FDef) ->
Env#{ type_env := TEnv#{ Q => FDef } }.
-spec bind_constructors(env(), con_env()) -> env().
bind_constructors(Env = #{ con_env := ConEnv }, NewCons) ->
Env#{ con_env := maps:merge(ConEnv, NewCons) }.
%% -- Names --
-spec add_child_con(env(), sophia_name(), fcode()) -> env().
add_child_con(Env = #{child_con_env := CEnv}, Name, Fcode) ->
Env#{ child_con_env := CEnv#{Name => Fcode} }.
-spec add_fun_env(env(), [aeso_syntax:decl()]) -> env().
add_fun_env(Env = #{ context := {abstract_contract, _} }, _) -> Env; %% no functions from abstract contracts
add_fun_env(Env = #{ fun_env := FunEnv }, Decls) ->
Entry = fun({letfun, Ann, {id, _, Name}, Args, _, _}) ->
[{qname(Env, Name), {make_fun_name(Env, Ann, Name), length(Args)}}];
({fun_decl, Ann, {id, _, Name}, {fun_t, _, _, ArgTypes, _}}) ->
[{qname(Env, Name), {make_fun_name(Env, Ann, Name), length(ArgTypes)}}];
(_) -> [] end,
FunEnv1 = maps:from_list(lists:flatmap(Entry, Decls)),
Env#{ fun_env := maps:merge(FunEnv, FunEnv1) }.
make_fun_name(#{ context := Context }, Ann, Name) ->
Entrypoint = proplists:get_value(entrypoint, Ann, false),
case Context of
{contract_def, Main} ->
if Entrypoint -> {entrypoint, list_to_binary(Name)};
true -> {local_fun, [Main, Name]}
end;
{namespace, Lib} ->
{local_fun, [Lib, Name]}
end.
-spec current_namespace(env()) -> string().
current_namespace(#{ context := Cxt }) ->
case Cxt of
{abstract_contract, Con} -> Con;
{contract_def, Con} -> Con;
{namespace, NS} -> NS
end.
-spec qname(env(), string()) -> sophia_name().
qname(Env, Name) ->
[current_namespace(Env), Name].
-spec lookup_fun(env(), sophia_name()) -> fun_name().
lookup_fun(#{ fun_env := FunEnv }, Name) ->
case maps:get(Name, FunEnv, false) of
false -> error({unbound_name, Name});
{FName, _} -> FName
end.
-spec lookup_con(env(), aeso_syntax:con() | aeso_syntax:qcon() | sophia_name()) -> con_tag().
lookup_con(Env, {con, _, Con}) -> lookup_con(Env, [Con]);
lookup_con(Env, {qcon, _, Con}) -> lookup_con(Env, Con);
lookup_con(#{ con_env := ConEnv }, Con) ->
case maps:get(Con, ConEnv, false) of
false -> error({unbound_constructor, Con});
Tag -> Tag
end.
bind_vars(Env, Xs) ->
lists:foldl(fun(X, E) -> bind_var(E, X) end, Env, Xs).
bind_var(Env = #{ vars := Vars }, X) -> Env#{ vars := [X | Vars] }.
resolve_var(#{ vars := Vars } = Env, [X]) ->
case lists:member(X, Vars) of
true -> {var, X};
false ->
case resolve_const(Env, [X]) of
false -> resolve_fun(Env, [X]);
Const -> Const
end
end;
resolve_var(Env, Q) ->
case resolve_const(Env, Q) of
false -> resolve_fun(Env, Q);
Const -> Const
end.
resolve_const(#{ consts := Consts }, Q) ->
case maps:get(Q, Consts, not_found) of
not_found -> false;
Val -> Val
end.
resolve_fun(#{ fun_env := Funs, builtins := Builtin } = Env, Q) ->
case {maps:get(Q, Funs, not_found), maps:get(Q, Builtin, not_found)} of
{not_found, not_found} -> internal_error({unbound_variable, Q});
{_, {B, none}} -> builtin_to_fcode(state_layout(Env), B, []);
{_, {B, Ar}} -> {builtin_u, B, Ar};
{{Fun, Ar}, _} -> {def_u, [], Fun, Ar}
end.
init_fresh_names(Options) ->
proplists:get_value(debug_info, Options, false) andalso init_saved_fresh_names(),
put('%fresh', 0).
clear_fresh_names(Options) ->
proplists:get_value(debug_info, Options, false) andalso clear_saved_fresh_names(),
erase('%fresh').
init_saved_fresh_names() ->
put(saved_fresh_names, #{}).
clear_saved_fresh_names() ->
erase(saved_fresh_names).
-spec fresh_name_save(string()) -> var_name().
fresh_name_save(Name) ->
Fresh = fresh_name(),
case get(saved_fresh_names) of
undefined -> ok;
Old -> put(saved_fresh_names, Old#{Fresh => Name})
end,
Fresh.
-spec fresh_name() -> var_name().
fresh_name() -> fresh_name("%").
-spec fresh_fun() -> fun_name().
fresh_fun() -> {local_fun, [fresh_name("^")]}.
-spec fresh_name(string()) -> var_name().
fresh_name(Prefix) ->
N = get('%fresh'),
put('%fresh', N + 1),
lists:concat([Prefix, N]).
-spec pat_vars(fpat()) -> [var_name()].
pat_vars({var, X}) -> [X || X /= "_"];
pat_vars({bool, _}) -> [];
pat_vars({int, _}) -> [];
pat_vars({string, _}) -> [];
pat_vars(nil) -> [];
pat_vars({'::', P, Q}) -> pat_vars(P) ++ pat_vars(Q);
pat_vars({tuple, Ps}) -> pat_vars(Ps);
pat_vars({con, _, _, Ps}) -> pat_vars(Ps);
pat_vars({assign, X, P}) -> pat_vars(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()].
fsplit_pat_vars({var, X}) -> [X || X /= "_"];
fsplit_pat_vars({bool, _}) -> [];
fsplit_pat_vars({int, _}) -> [];
fsplit_pat_vars({string, _}) -> [];
fsplit_pat_vars(nil) -> [];
fsplit_pat_vars({'::', P, Q}) -> [P, Q];
fsplit_pat_vars({tuple, Ps}) -> Ps;
fsplit_pat_vars({con, _, _, Ps}) -> Ps.
free_vars(Xs) when is_list(Xs) ->
lists:umerge([ free_vars(X) || X <- Xs ]);
free_vars(Expr) ->
case Expr of
{var, X} -> [X];
{lit, _} -> [];
nil -> [];
{def, _, _, As} -> free_vars(As);
{def_u, _, _, _} -> [];
{remote, _, _, _, Ct, _, As} -> free_vars([Ct | As]);
{remote_u, _, _, _, Ct, _} -> free_vars(Ct);
{builtin, _, As} -> free_vars(As);
{builtin_u, _, _} -> [];
{builtin_u, _, _, _} -> []; %% Typereps are always literals
{con, _, _, As} -> free_vars(As);
{tuple, As} -> free_vars(As);
{proj, _, A, _} -> free_vars(A);
{set_proj, _, A, _, B} -> free_vars([A, B]);
{op, _, _, As} -> free_vars(As);
{'let', X, A, B} -> free_vars([A, {lam, [X], B}]);
{funcall, _, A, Bs} -> free_vars([A | Bs]);
{set_state, _, _, A} -> free_vars(A);
{get_state, _} -> [];
{lam, Xs, B} -> free_vars(B) -- lists:sort(Xs);
{closure, _, _, A} -> free_vars(A);
{switch, A} -> free_vars(A);
{split, _, X, As} -> free_vars([{var, X} | As]);
{nosplit, A} -> free_vars(A);
{'case', P, A} -> free_vars(A) -- lists:sort(fsplit_pat_vars(P))
end.
used_defs(Xs) when is_list(Xs) ->
lists:umerge([ used_defs(X) || X <- Xs ]);
used_defs(Expr) ->
case Expr of
{var, _} -> [];
{lit, _} -> [];
nil -> [];
{def, _, F, As} -> lists:umerge([F], used_defs(As));
{def_u, _, F, _} -> [F];
{remote, _, _, _, Ct, _, As} -> used_defs([Ct | As]);
{remote_u, _, _, _, Ct, _} -> used_defs(Ct);
{builtin, _, As} -> used_defs(As);
{builtin_u, _, _} -> [];
{builtin_u, _, _, _} -> [];
{con, _, _, As} -> used_defs(As);
{tuple, As} -> used_defs(As);
{proj, _, A, _} -> used_defs(A);
{set_proj, _, A, _, B} -> used_defs([A, B]);
{op, _, _, As} -> used_defs(As);
{'let', _, A, B} -> used_defs([A, B]);
{funcall, _, A, Bs} -> used_defs([A | Bs]);
{set_state, _, _, A} -> used_defs(A);
{get_state, _} -> [];
{lam, _, B} -> used_defs(B);
{closure, _, F, A} -> lists:umerge([F], used_defs(A));
{switch, A} -> used_defs(A);
{split, _, _, As} -> used_defs(As);
{nosplit, A} -> used_defs(A);
{'case', _, A} -> used_defs(A)
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, Ann, D, Es} -> {def, Ann, 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, Ann, ArgsT, RetT, Ct, Fun, Es} -> {remote, Ann, ArgsT, RetT, bottom_up(F, Env, Ct), Fun, [bottom_up(F, Env, E) || E <- Es]};
{remote_u, Ann, ArgsT, RetT, Ct, Fun} -> {remote_u, Ann, 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, Ann, E, I} -> {proj, Ann, bottom_up(F, Env, E), I};
{set_proj, Ann, R, I, E} -> {set_proj, Ann, bottom_up(F, Env, R), I, bottom_up(F, Env, E)};
{op, Ann, Op, Es} -> {op, Ann, Op, [bottom_up(F, Env, E) || E <- Es]};
{funcall, Ann, Fun, Es} -> {funcall, Ann, bottom_up(F, Env, Fun), [bottom_up(F, Env, E) || E <- Es]};
{set_state, Ann, R, E} -> {set_state, Ann, R, bottom_up(F, Env, E)};
{get_state, _} -> Expr;
{closure, Ann, F, CEnv} -> {closure, Ann, 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_save(X),
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) ->
IsNamed = fun({named_arg, _, _, _}) -> true;
(_) -> false end,
{Named, NotNamed} = lists:partition(IsNamed, Args),
NamedArgs = [get_named_arg(NamedArg, Named) || NamedArg <- NamedArgsT],
NamedArgs ++ NotNamed.
get_named_arg({named_arg_t, _, {id, _, Name}, _, Default}, Args) ->
case [ Val || {named_arg, _, {id, _, X}, Val} <- Args, X == Name ] of
[Val] -> Val;
[] -> Default
end.
%% -- Renaming --
-spec rename([{var_name(), var_name()}], fexpr()) -> fexpr().
rename(Ren, Expr) ->
case Expr of
{lit, _} -> Expr;
nil -> nil;
{var, X} -> {var, rename_var(Ren, X)};
{def, Ann, D, Es} -> {def, Ann, D, [rename(Ren, E) || E <- Es]};
{def_u, _, _, _} -> Expr;
{builtin, B, Es} -> {builtin, B, [rename(Ren, E) || E <- Es]};
{builtin_u, _, _} -> Expr;
{builtin_u, _, _, _} -> Expr;
{remote, Ann, ArgsT, RetT, Ct, F, Es} -> {remote, Ann, ArgsT, RetT, rename(Ren, Ct), F, [rename(Ren, E) || E <- Es]};
{remote_u, Ann, ArgsT, RetT, Ct, F} -> {remote_u, Ann, ArgsT, RetT, rename(Ren, Ct), F};
{con, Ar, I, Es} -> {con, Ar, I, [rename(Ren, E) || E <- Es]};
{tuple, Es} -> {tuple, [rename(Ren, E) || E <- Es]};
{proj, Ann, E, I} -> {proj, Ann, rename(Ren, E), I};
{set_proj, Ann, R, I, E} -> {set_proj, Ann, rename(Ren, R), I, rename(Ren, E)};
{op, Ann, Op, Es} -> {op, Ann, Op, [rename(Ren, E) || E <- Es]};
{funcall, Ann, Fun, Es} -> {funcall, Ann, rename(Ren, Fun), [rename(Ren, E) || E <- Es]};
{set_state, Ann, R, E} -> {set_state, Ann, R, rename(Ren, E)};
{get_state, _} -> Expr;
{closure, Ann, F, Env} -> {closure, Ann, F, rename(Ren, Env)};
{switch, Split} -> {switch, rename_split(Ren, Split)};
{lam, Xs, B} ->
{Zs, Ren1} = rename_bindings(Ren, Xs),
{lam, Zs, rename(Ren1, B)};
{'let', X, E, Body} ->
{Z, Ren1} = rename_binding(Ren, X),
{'let', Z, rename(Ren, E), rename(Ren1, Body)}
end.
rename_var(Ren, X) -> proplists:get_value(X, Ren, X).
rename_binding(Ren, X) ->
Ren1 = lists:keydelete(X, 1, Ren),
case lists:keymember(X, 2, Ren) of
false -> {X, Ren1};
true ->
Z = fresh_name(),
{Z, [{X, Z} | Ren1]}
end.
rename_bindings(Ren, []) -> {[], Ren};
rename_bindings(Ren, [X | Xs]) ->
{Z, Ren1} = rename_binding(Ren, X),
{Zs, Ren2} = rename_bindings(Ren1, Xs),
{[Z | Zs], Ren2}.
rename_fpats(Ren, []) -> {[], Ren};
rename_fpats(Ren, [P | Ps]) ->
{Q, Ren1} = rename_fpat(Ren, P),
{Qs, Ren2} = rename_fpats(Ren1, Ps),
{[Q | Qs], Ren2}.
rename_fpat(Ren, P = {bool, _}) -> {P, Ren};
rename_fpat(Ren, P = {int, _}) -> {P, Ren};
rename_fpat(Ren, P = {string, _}) -> {P, Ren};
rename_fpat(Ren, P = nil) -> {P, Ren};
rename_fpat(Ren, {'::', P, Q}) ->
{P1, Ren1} = rename_fpat(Ren, P),
{Q1, Ren2} = rename_fpat(Ren1, Q),
{{'::', P1, Q1}, Ren2};
rename_fpat(Ren, {var, X}) ->
{Z, Ren1} = rename_binding(Ren, X),
{{var, Z}, Ren1};
rename_fpat(Ren, {con, Ar, C, Ps}) ->
{Ps1, Ren1} = rename_fpats(Ren, Ps),
{{con, Ar, C, Ps1}, Ren1};
rename_fpat(Ren, {tuple, Ps}) ->
{Ps1, Ren1} = rename_fpats(Ren, Ps),
{{tuple, Ps1}, Ren1}.
rename_spat(Ren, P = {bool, _}) -> {P, Ren};
rename_spat(Ren, P = {int, _}) -> {P, Ren};
rename_spat(Ren, P = {string, _}) -> {P, Ren};
rename_spat(Ren, P = nil) -> {P, Ren};
rename_spat(Ren, {'::', X, Y}) ->
{X1, Ren1} = rename_binding(Ren, X),
{Y1, Ren2} = rename_binding(Ren1, Y),
{{'::', X1, Y1}, Ren2};
rename_spat(Ren, {var, X}) ->
{Z, Ren1} = rename_binding(Ren, X),
{{var, Z}, Ren1};
rename_spat(Ren, {con, Ar, C, Xs}) ->
{Zs, Ren1} = rename_bindings(Ren, Xs),
{{con, Ar, C, Zs}, Ren1};
rename_spat(Ren, {tuple, Xs}) ->
{Zs, Ren1} = rename_bindings(Ren, Xs),
{{tuple, Zs}, Ren1};
rename_spat(Ren, {assign, X, P}) ->
{X1, Ren1} = rename_binding(Ren, X),
{P1, Ren2} = rename_binding(Ren1, P),
{{assign, X1, P1}, Ren2}.
rename_split(Ren, {split, Type, X, Cases}) ->
{split, Type, rename_var(Ren, X), [rename_case(Ren, C) || C <- Cases]};
rename_split(Ren, {nosplit, E}) -> {nosplit, rename(Ren, E)}.
rename_case(Ren, {'case', Pat, Split}) ->
{Pat1, Ren1} = rename_spat(Ren, Pat),
{'case', Pat1, rename_split(Ren1, Split)}.
%% -- Records --
field_index({typed, _, _, RecTy}, X) ->
field_index(RecTy, X);
field_index({record_t, Fields}, X) ->
IsX = fun({field_t, _, {id, _, Y}, _}) -> X == Y end,
[I] = [ I || {I, Field} <- indexed(Fields), IsX(Field) ],
I - 1. %% Tuples are 0-indexed
field_value({field_t, _, {id, _, X}, _}, Fields) ->
View = fun({field, _, [{proj, _, {id, _, Y}}], E}) -> {Y, {set, E}};
({field_upd, _, [{proj, _, {id, _, Y}}],
{typed, _, {lam, _, [{arg, _, {id, _, Z}, _}], E}, _}}) -> {Y, {upd, Z, E}} end,
case [Upd || {Y, Upd} <- lists:map(View, Fields), X == Y] of
[Upd] -> Upd;
[] -> false
end.
%% -- Attributes --
get_attributes(Ann) ->
[stateful || proplists:get_value(stateful, Ann, false)] ++
[payable || proplists:get_value(payable, Ann, false)] ++
[private || not proplists:get_value(entrypoint, Ann, false)].
%% -- Basic utilities --
indexed(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]}).
fcode_error(Error) ->
Pos = aeso_errors:pos(0, 0),
Msg = lists:flatten(io_lib:format("Unknown error: ~p\n", [Error])),
aeso_errors:throw(aeso_errors:new(code_error, Pos, Msg)).
internal_error(Error) ->
Msg = lists:flatten(io_lib:format("~p\n", [Error])),
aeso_errors:throw(aeso_errors:new(internal_error, aeso_errors:pos(0, 0), Msg)).
%% -- Pretty printing --------------------------------------------------------
format_fcode(#{ functions := Funs }) ->
prettypr:format(format_funs(Funs)).
format_funs(Funs) ->
pp_above(
[ pp_fun(Name, Def) || {Name, Def} <- maps:to_list(Funs) ]).
format_fexpr(E) ->
prettypr:format(pp_fexpr(E)).
pp_fun(Name, #{ args := Args, return := Return, body := Body }) ->
PPArg = fun({X, T}) -> pp_beside([pp_text(X), pp_text(" : "), pp_ftype(T)]) end,
pp_above(pp_beside([pp_text("function "), pp_fun_name(Name),
pp_parens(pp_par(pp_punctuate(pp_text(","), [PPArg(Arg) || Arg <- Args]))),
pp_text(" : "), pp_ftype(Return), pp_text(" =")]),
prettypr:nest(2, pp_fexpr(Body))).
pp_fun_name(event) -> pp_text(event);
pp_fun_name({entrypoint, E}) -> pp_text(binary_to_list(E));
pp_fun_name({local_fun, Q}) -> pp_text(string:join(Q, ".")).
pp_text(<<>>) -> prettypr:text("\"\"");
pp_text(Bin) when is_binary(Bin) -> prettypr:text(lists:flatten(io_lib:format("~p", [binary_to_list(Bin)])));
pp_text(S) when is_list(S) -> prettypr:text(lists:concat([S]));
pp_text(A) when is_atom(A) -> prettypr:text(atom_to_list(A));
pp_text(N) when is_integer(N) -> prettypr:text(integer_to_list(N)).
pp_int(I) -> prettypr:text(integer_to_list(I)).
pp_beside([]) -> prettypr:empty();
pp_beside([X]) -> X;
pp_beside([X | Xs]) -> pp_beside(X, pp_beside(Xs)).
pp_beside(A, B) -> prettypr:beside(A, B).
pp_above([]) -> prettypr:empty();
pp_above([X]) -> X;
pp_above([X | Xs]) -> pp_above(X, pp_above(Xs)).
pp_above(A, B) -> prettypr:above(A, B).
pp_parens(Doc) -> pp_beside([pp_text("("), Doc, pp_text(")")]).
pp_braces(Doc) -> pp_beside([pp_text("{"), Doc, pp_text("}")]).
pp_punctuate(_Sep, []) -> [];
pp_punctuate(_Sep, [X]) -> [X];
pp_punctuate(Sep, [X | Xs]) -> [pp_beside(X, Sep) | pp_punctuate(Sep, Xs)].
pp_par([]) -> prettypr:empty();
pp_par(Xs) -> prettypr:par(Xs).
pp_fexpr({lit, {typerep, T}}) ->
pp_ftype(T);
pp_fexpr({lit, {Tag, Lit}}) ->
aeso_pretty:expr({Tag, [], Lit});
pp_fexpr(nil) ->
pp_text("[]");
pp_fexpr({var, X}) -> pp_text(X);
pp_fexpr({def, Fun}) -> pp_fun_name(Fun);
pp_fexpr({def_u, _, Fun, Ar}) ->
pp_beside([pp_fun_name(Fun), pp_text("/"), pp_int(Ar)]);
pp_fexpr({def, _, Fun, Args}) ->
pp_call(pp_fun_name(Fun), Args);
pp_fexpr({con, _, I, []}) ->
pp_beside(pp_text("C"), pp_int(I));
pp_fexpr({con, _, I, Es}) ->
pp_beside(pp_fexpr({con, [], I, []}),
pp_fexpr({tuple, Es}));
pp_fexpr({tuple, Es}) ->
pp_parens(pp_par(pp_punctuate(pp_text(","), [pp_fexpr(E) || E <- Es])));
pp_fexpr({proj, _, E, I}) ->
pp_beside([pp_fexpr(E), pp_text("."), pp_int(I)]);
pp_fexpr({lam, Xs, A}) ->
pp_par([pp_fexpr({tuple, [{var, X} || X <- Xs]}), pp_text("=>"),
prettypr:nest(2, pp_fexpr(A))]);
pp_fexpr({closure, _, Fun, ClEnv}) ->
FVs = case ClEnv of
{tuple, Xs} -> Xs;
{var, _} -> [ClEnv]
end,
pp_call(pp_text("__CLOSURE__"), [{def, Fun} | FVs]);
pp_fexpr({set_proj, _, E, I, A}) ->
pp_beside(pp_fexpr(E), pp_braces(pp_beside([pp_int(I), pp_text(" = "), pp_fexpr(A)])));
pp_fexpr({op, _, Op, [A, B] = Args}) ->
case is_infix(Op) of
false -> pp_call(pp_text(Op), Args);
true -> pp_parens(pp_par([pp_fexpr(A), pp_text(Op), pp_fexpr(B)]))
end;
pp_fexpr({op, _, Op, [A] = Args}) ->
case is_infix(Op) of
false -> pp_call(pp_text(Op), Args);
true -> pp_parens(pp_par([pp_text(Op), pp_fexpr(A)]))
end;
pp_fexpr({op, _, Op, As}) ->
pp_beside(pp_text(Op), pp_fexpr({tuple, As}));
pp_fexpr({'let', _, _, _} = Expr) ->
Lets = fun Lets({'let', Y, C, D}) ->
{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_beside([pp_text(B), pp_text("/"), pp_text(N)]);
pp_fexpr({builtin_u, B, N, TypeArgs}) ->
pp_beside([pp_text(B), pp_text("@"), pp_fexpr({tuple, TypeArgs}), pp_text("/"), pp_text(N)]);
pp_fexpr({builtin, B, As}) ->
pp_call(pp_text(B), As);
pp_fexpr({remote_u, _, ArgsT, RetT, Ct, Fun}) ->
pp_beside([pp_fexpr(Ct), pp_text("."), pp_fun_name(Fun), pp_text(" : "), pp_ftype({function, ArgsT, RetT})]);
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_fexpr({funcall, _, 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({contract_code, Contract}) ->
pp_beside(pp_text("contract "), pp_text(Contract)).
pp_call(Fun, Args) ->
pp_beside(Fun, pp_fexpr({tuple, Args})).
pp_call_t(Fun, Args) ->
pp_beside(pp_text(Fun), pp_ftype({tuple, Args})).
-spec pp_ftype(ftype()) -> any().
pp_ftype(T) when is_atom(T) -> pp_text(T);
pp_ftype(any) -> pp_text("_");
pp_ftype({tvar, X}) -> pp_text(X);
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({tuple, Ts}) ->
pp_parens(pp_par(pp_punctuate(pp_text(" *"), [pp_ftype(T) || T <- Ts])));
pp_ftype({list, T}) ->
pp_call_t("list", [T]);
pp_ftype({function, Args, Res}) ->
pp_par([pp_ftype({tuple, Args}), pp_text("=>"), pp_ftype(Res)]);
pp_ftype({map, Key, Val}) ->
pp_call_t("map", [Key, Val]);
pp_ftype({variant, Cons}) ->
pp_par(
pp_punctuate(pp_text(" |"),
[ case Args of
[] -> pp_fexpr({con, [], I - 1, []});
_ -> pp_beside(pp_fexpr({con, [], I - 1, []}), pp_ftype({tuple, Args}))
end || {I, Args} <- indexed(Cons)])).
pp_split({nosplit, E}) -> pp_fexpr(E);
pp_split({split, Type, X, Alts}) ->
pp_above([pp_beside([pp_text("switch("), pp_text(X), pp_text(" : "), pp_ftype(Type), pp_text(")")])] ++
[prettypr:nest(2, pp_case(Alt)) || Alt <- Alts]).
pp_case({'case', Pat, Split}) ->
prettypr:sep([pp_beside(pp_pat(Pat), pp_text(" =>")),
prettypr:nest(2, pp_split(Split))]).
pp_pat({tuple, Xs}) -> pp_fexpr({tuple, [{var, X} || X <- Xs]});
pp_pat({'::', X, Xs}) -> pp_fexpr({op, [], '::', [{var, X}, {var, Xs}]});
pp_pat({con, As, I, Xs}) -> pp_fexpr({con, As, I, [{var, X} || X <- Xs]});
pp_pat({var, X}) -> pp_fexpr({var, X});
pp_pat(P = {Tag, _}) when Tag == bool; Tag == int; Tag == string
-> pp_fexpr({lit, P});
pp_pat(Pat) -> pp_fexpr(Pat).
is_infix(Op) ->
C = hd(atom_to_list(Op)),
C < $a orelse C > $z.
Reference in New Issue View Git Blame Copy Permalink