%%%------------------------------------------------------------------- %%% @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]). %% -- 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. -type flit() :: {int, integer()} | {string, binary()} | {bytes, binary()} | {account_pubkey, binary()} | {contract_pubkey, binary()} | {oracle_pubkey, binary()} | {oracle_query_id, binary()} | {bool, false | true} | {typerep, ftype()}. -type fexpr() :: {lit, flit()} | nil | {var, var_name()} | {def, fun_name(), [fexpr()]} | {remote, [ftype()], ftype(), fexpr(), fun_name(), [fexpr()]} | {builtin, builtin(), [fexpr()]} | {con, arities(), tag(), [fexpr()]} | {tuple, [fexpr()]} | {proj, fexpr(), integer()} | {set_proj, fexpr(), integer(), fexpr()} %% tuple, field, new_value | {op, op(), [fexpr()]} | {'let', var_name(), fexpr(), fexpr()} | {funcall, fexpr(), [fexpr()]} %% Call to unknown function | {closure, fun_name(), fexpr()} | {switch, fsplit()} | {set_state, 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, fun_name(), arity()} | {remote_u, [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()]}. -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 builtins() :: #{ sophia_name() => {builtin(), non_neg_integer() | none} }. -type context() :: {main_contract, 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(), event_type => aeso_syntax:typedef(), builtins := builtins(), options := [option()], state_layout => state_layout(), context => context(), vars => [var_name()], functions := #{ fun_name() => fun_def() } }. -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()]) -> fcode(). ast_to_fcode(Code, Options) -> Verbose = lists:member(pp_fcode, Options), init_fresh_names(), FCode1 = to_fcode(init_env(Options), Code), [io:format("-- Before lambda lifting --\n~s\n\n", [format_fcode(FCode1)]) || Verbose], FCode2 = optimize_fcode(FCode1), [ 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 ], clear_fresh_names(), FCode3. %% -- Environment ------------------------------------------------------------ -spec init_env([option()]) -> env(). init_env(Options) -> #{ type_env => init_type_env(), fun_env => #{}, builtins => builtins(), 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] } }, options => Options, functions => #{} }. -spec builtins() -> builtins(). builtins() -> MkName = fun(NS, Fun) -> list_to_atom(string:to_lower(string:join(NS ++ [Fun], "_"))) end, Scopes = [{[], [{"abort", 1}, {"require", 2}]}, {["Chain"], [{"spend", 2}, {"balance", 1}, {"block_hash", 1}, {"coinbase", none}, {"timestamp", none}, {"block_height", none}, {"difficulty", none}, {"gas_limit", none}]}, {["Contract"], [{"address", none}, {"balance", none}, {"creator", none}]}, {["Call"], [{"origin", none}, {"caller", none}, {"value", none}, {"gas_price", none}, {"gas_left", 0}]}, {["Oracle"], [{"register", 4}, {"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}]}, {["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}]}, {["Auth"], [{"tx_hash", none}]}, {["String"], [{"length", 1}, {"concat", 2}, {"sha3", 1}, {"sha256", 1}, {"blake2b", 1}]}, {["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() -> #{ ["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), ["list"] => ?type(T, {list, T}), ["map"] => ?type(K, V, {map, K, V}), ["option"] => ?type(T, {variant, [[], [T]]}), ["Chain", "ttl"] => ?type({variant, [[integer], [integer]]}) }. 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()) -> fcode(). to_fcode(Env, [{contract, Attrs, MainCon = {con, _, Main}, Decls}]) -> #{ builtins := Builtins } = Env, MainEnv = Env#{ context => {main_contract, Main}, builtins => Builtins#{[Main, "state"] => {get_state, none}, [Main, "put"] => {set_state, 1}, [Main, "Chain", "event"] => {chain_event, 1}} }, #{ functions := Funs } = Env1 = decls_to_fcode(MainEnv, Decls), StateType = lookup_type(Env1, [Main, "state"], [], {tuple, []}), EventType = lookup_type(Env1, [Main, "event"], [], none), StateLayout = state_layout(Env1), Payable = proplists:get_value(payable, Attrs, false), #{ contract_name => Main, state_type => StateType, state_layout => StateLayout, event_type => EventType, payable => Payable, functions => add_init_function(Env1, MainCon, StateType, add_event_function(Env1, EventType, Funs)) }; to_fcode(_Env, [NotContract]) -> fcode_error({last_declaration_must_be_contract, NotContract}); to_fcode(Env, [{contract, _, {con, _, Con}, Decls} | Code]) -> Env1 = decls_to_fcode(Env#{ context => {abstract_contract, Con} }, Decls), to_fcode(Env1, Code); to_fcode(Env, [{namespace, _, {con, _, Con}, Decls} | Code]) -> Env1 = decls_to_fcode(Env#{ context => {namespace, Con} }, Decls), to_fcode(Env1, Code). -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) -> R = decl_to_fcode(E, D), R end, Env1, Decls). -spec decl_to_fcode(env(), aeso_syntax:decl()) -> env(). decl_to_fcode(Env, {type_decl, _, _, _}) -> Env; decl_to_fcode(Env = #{context := {main_contract, _}}, {fun_decl, _, Id, _}) -> case is_no_code(Env) of false -> fcode_error({missing_definition, Id}); true -> Env end; 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 = {id, _, Name}, Args, Ret, 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), [ ensure_first_order_entrypoint(Ann, Id, Args, Ret, FArgs, FRet) || aeso_syntax:get_ann(entrypoint, Ann, false) ], Def = #{ attrs => Attrs, args => FArgs, return => FRet, body => FBody }, NewFuns = Funs#{ FName => Def }, Env#{ functions := NewFuns }. -spec typedef_to_fcode(env(), aeso_syntax:id(), [aeso_syntax:tvar()], aeso_syntax:typedef()) -> env(). typedef_to_fcode(Env, Id = {id, _, Name}, Xs, Def) -> check_state_and_event_types(Env, Id, Xs), 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 := {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, [_ | _]) -> case Id of {id, _, "state"} -> fcode_error({parameterized_state, Id}); {id, _, "event"} -> fcode_error({parameterized_event, Id}); _ -> ok end; check_state_and_event_types(_, _, _) -> ok. -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, _, 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, 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, Ann, 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), validate_oracle_type(Ann, OType, QType, RType), 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), validate_aens_resolve_type(Ann, ResType, AensType), 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, contract_to_address, [expr_to_fcode(Env, Rec)]}; {con, _, _} -> {fun_t, _, _, Args, Ret} = Type, FArgs = [type_to_fcode(Env, Arg) || Arg <- Args], {remote_u, 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, 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, {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, R, I - 1, expr_to_fcode(Env, E)}; ({I, {upd, Z, E}}, R) -> {set_proj, 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, '::', [expr_to_fcode(Env, E), L]} end, nil, Es); expr_to_fcode(Env, _Type, {app, _, {'..', _}, [A, B]}) -> {def_u, FromTo, _} = resolve_fun(Env, ["ListInternal", "from_to"]), {def, FromTo, [expr_to_fcode(Env, A), expr_to_fcode(Env, B)]}; expr_to_fcode(Env, _Type, {list_comp, _, Yield, []}) -> {op, '::', [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, {list_comp, As, Yield, Rest}}, {'case', As, {id, As, "_"}, {list, As, []}}]})}, {def_u, FlatMap, _} = resolve_fun(Env, ["ListInternal", "flat_map"]), {def, 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, _, {switch, _, Expr = {typed, _, E, Type}, Alts}) -> Switch = fun(X) -> {switch, alts_to_fcode(Env, type_to_fcode(Env, Type), X, Alts)} 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) -> {op, Op, [expr_to_fcode(Env, A), expr_to_fcode(Env, B)]}; expr_to_fcode(Env, _Type, {app, _Ann, {Op, _}, [A]}) when is_atom(Op) -> case Op of '-' -> {op, '-', [{lit, {int, 0}}, expr_to_fcode(Env, A)]}; '!' -> {op, '!', [expr_to_fcode(Env, A)]} end; %% Function calls expr_to_fcode(Env, _Type, {app, _, Fun = {typed, _, _, {fun_t, _, NamedArgsT, _, _}}, 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, B, _Ar} -> builtin_to_fcode(state_layout(Env), B, FArgs); {def_u, F, _Ar} -> {def, F, FArgs}; {remote_u, ArgsT, RetT, Ct, RFun} -> {remote, ArgsT, RetT, Ct, RFun, FArgs}; FFun -> %% FFun is a closure, with first component the function name and %% second component the environment Call = fun(X) -> {funcall, {proj, {var, X}, 0}, [{proj, {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, _, [{map_get, _, K}], V} -> {op, map_set, [M, expr_to_fcode(Env, K), expr_to_fcode(Env, V)]}; {field_upd, _, [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(), GetExpr = case Default of [] -> {op, map_get, [Map1, Key]}; [D] -> {op, map_get_d, [Map1, Key, expr_to_fcode(Env, D)]} end, {'let', Z1, GetExpr, {op, 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, _, Map, Key}) -> {op, map_get, [expr_to_fcode(Env, Map), expr_to_fcode(Env, Key)]}; expr_to_fcode(Env, _Type, {map_get, _, Map, Key, Def}) -> {op, 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)}. -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. validate_oracle_type(Ann, Type, QType, RType) -> ensure_monomorphic(QType, {invalid_oracle_type, polymorphic, query, Ann, Type}), ensure_monomorphic(RType, {invalid_oracle_type, polymorphic, response, Ann, Type}), ensure_first_order(QType, {invalid_oracle_type, higher_order, query, Ann, Type}), ensure_first_order(RType, {invalid_oracle_type, higher_order, response, Ann, Type}), ok. validate_aens_resolve_type(Ann, {app_t, _, _, [Type]}, {variant, [[], [FType]]}) -> case FType of string -> ok; address -> ok; contract -> ok; {oracle, _, _} -> ok; oracle_query -> ok; _ -> fcode_error({invalid_aens_resolve_type, Ann, Type}) end. ensure_first_order_entrypoint(Ann, Id = {id, _, Name}, Args, Ret, FArgs, FRet) -> [ ensure_first_order(FT, {invalid_entrypoint, higher_order, Ann1, Id, {argument, X, T}}) || {{typed, Ann1, X, T}, {_, FT}} <- lists:zip(Args, FArgs) ], [ ensure_first_order(FRet, {invalid_entrypoint, higher_order, Ann, Id, {result, Ret}}) || Name /= "init" ], %% init can return higher-order values, since they're written to the store %% rather than being returned. ok. ensure_monomorphic(Type, Err) -> case is_monomorphic(Type) of true -> ok; false -> fcode_error(Err) end. ensure_first_order(Type, Err) -> case is_first_order(Type) of true -> ok; false -> fcode_error(Err) end. is_monomorphic({tvar, _}) -> false; is_monomorphic(Ts) when is_list(Ts) -> lists:all(fun is_monomorphic/1, Ts); is_monomorphic(Tup) when is_tuple(Tup) -> is_monomorphic(tuple_to_list(Tup)); is_monomorphic(_) -> true. is_first_order({function, _, _}) -> false; is_first_order(Ts) when is_list(Ts) -> lists:all(fun is_first_order/1, Ts); is_first_order(Tup) when is_tuple(Tup) -> is_first_order(tuple_to_list(Tup)); is_first_order(_) -> true. %% -- Pattern matching -- -spec alts_to_fcode(env(), ftype(), var_name(), [aeso_syntax:alt()]) -> fsplit(). alts_to_fcode(Env, Type, X, Alts) -> FAlts = [alt_to_fcode(Env, Alt) || Alt <- Alts], 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()]}. %% %% 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({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({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, 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, 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, {block, Ann, Stmts}}]}); stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, 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, string_length, string_concat, string_sha3, string_sha256, string_blake2b, 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 ]. 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]}); builtin_to_fcode(_Layout, chain_event, [Event]) -> {def, event, [Event]}; builtin_to_fcode(_Layout, map_delete, [Key, Map]) -> {op, map_delete, [Map, Key]}; builtin_to_fcode(_Layout, map_member, [Key, Map]) -> {op, map_member, [Map, Key]}; builtin_to_fcode(_Layout, map_lookup, [Key0, Map0]) -> ?make_let(Key, Key0, ?make_let(Map, Map0, make_if({op, map_member, [Map, Key]}, {con, [0, 1], 1, [{op, map_get, [Map, Key]}]}, {con, [0, 1], 0, []}))); builtin_to_fcode(_Layout, map_lookup_default, [Key, Map, Def]) -> {op, map_get_d, [Map, Key, Def]}; builtin_to_fcode(_Layout, Builtin, Args) -> case lists:member(Builtin, op_builtins()) of true -> {op, Builtin, Args}; false -> {builtin, Builtin, Args} end. %% -- Init function -- add_init_function(Env, Main, StateType, Funs0) -> case is_no_code(Env) of true -> Funs0; false -> Funs = add_default_init_function(Env, Main, StateType, 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, Main, StateType, Funs) -> InitName = {entrypoint, <<"init">>}, case maps:get(InitName, Funs, none) of %% Only add default init function if state is unit. none when StateType == {tuple, []} -> Funs#{ InitName => #{attrs => [], args => [], return => {tuple, []}, body => {tuple, []}} }; none -> fcode_error({missing_init_function, Main}); _ -> 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, {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, 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, ArgsT, RetT, Ct, F}) -> FVs = free_vars(Ct), Ct1 = lambda_lift_expr(Layout, Ct), GasAndValueArgs = 2, Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, length(ArgsT) + GasAndValueArgs) ], Args = [{var, X} || X <- Xs], make_closure(FVs, Xs, {remote, ArgsT, RetT, Ct1, F, Args}); lambda_lift_expr(Layout, Expr) -> case Expr of {lit, _} -> Expr; nil -> Expr; {var, _} -> Expr; {closure, _, _} -> Expr; {def, D, As} -> {def, D, lambda_lift_exprs(Layout, As)}; {builtin, B, As} -> {builtin, B, lambda_lift_exprs(Layout, 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(Layout, As)}; {tuple, As} -> {tuple, lambda_lift_exprs(Layout, As)}; {proj, A, I} -> {proj, lambda_lift_expr(Layout, A), I}; {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(Layout, As)}; {'let', X, A, B} -> {'let', X, lambda_lift_expr(Layout, A), lambda_lift_expr(Layout, B)}; {funcall, A, Bs} -> {funcall, lambda_lift_expr(Layout, A), lambda_lift_exprs(Layout, Bs)}; {set_state, R, A} -> {set_state, 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()) -> fcode(). optimize_fcode(Code = #{ functions := Funs }) -> Code1 = Code#{ functions := maps:map(fun(Name, Def) -> optimize_fun(Code, Name, Def) end, Funs) }, eliminate_dead_code(Code1). -spec optimize_fun(fcode(), fun_name(), fun_def()) -> fun_def(). optimize_fun(Fcode, Fun, Def = #{ body := Body }) -> %% io:format("Optimizing ~p =\n~s\n", [_Fun, prettypr:format(pp_fexpr(_Body))]), Def#{ body := drop_unused_lets( simplifier( let_floating( bind_subexpressions( inline_local_functions( inliner(Fcode, Fun, Body)))))) }. %% --- 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, 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. 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(_, _) -> 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_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 {main_contract, 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; {main_contract, 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 -> resolve_fun(Env, [X]) end; resolve_var(Env, Q) -> resolve_fun(Env, Q). 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() -> put('%fresh', 0). clear_fresh_names() -> erase('%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(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, 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) -> 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, D, Es} -> {def, 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, ArgsT, RetT, Ct, F, Es} -> {remote, ArgsT, RetT, rename(Ren, Ct), F, [rename(Ren, E) || E <- Es]}; {remote_u, ArgsT, RetT, Ct, F} -> {remote_u, 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, E, I} -> {proj, rename(Ren, E), I}; {set_proj, R, I, E} -> {set_proj, rename(Ren, R), I, rename(Ren, E)}; {op, Op, Es} -> {op, Op, [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)}; {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_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) -> aeso_errors:throw(aeso_code_errors:format(Error)). 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(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_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.