From c3958496842aa89e63264900359055ff51cec09f Mon Sep 17 00:00:00 2001 From: Gaith Hallak Date: Tue, 13 Jun 2023 14:36:48 +0300 Subject: [PATCH] Introduce debugging symbols (#424) * Add fann type and to_fann fun * Add fann() to funcall * Add fann() to closure * Add fann() to set_state * Add fann() to remote_u * Add fann() to remote * Add fann() to proj * Add fann() to set_proj * Add fann() to def and def_u * Add fann() to op * Add fann() to let * Add fann() to lam * Add fann() to builtin_u * Add missing functions specs * Dead code removal * Fix the spec for compute_state_layout * Add fann() to var * Add fann() to switch * Add fann() to lit and get_state * Add fann() to builtin * Add fann() to con * Add fann() to tuple * Add fann() to nil * Fix missing fann() in tuple fexpr() * Add dbgloc instruction to fate * Add instructions lines to the debugging result * Fix compiler tests * Fix calldata tests * Rname Ann to FAnn when the type is fann() * Add line to fann() * Change attributes for DBGLOC instruction * Add file to fann() * Add file to aeso_syntax:ann() * Fix dialyzer warning * Remove fann() from fsplit_pat() and fpat() * Fill out empty fann() when possible * Save debug locations for child contracts * Include DBGLOC instructions in the compiler output * Return an empty string instead of no_file atom * Wrap args of DBGLOC in immediate tuple * Upgrade aebytecode ref in rebar.config * Add DBG_DEF and DBG_UNDEF * Do not DBG_DEF vars with % prefix * Do not use DBG_DEF and DBG_UNDEF on args * Fix dbg_undef for args * Rename DBGLOC to DBG_LOC * Remove column from DBG_LOC * Add missing dbg_loc in to_scode1 * Keep a single DBG_LOC instruction per line * Remove col from fann * Add DBG_LOC op to step at function sig * Remove the variable-register map from debug output * Use get_value/3 to handle default * Use lookup instead of lookup_all * List only needed attributes * Make debug ops impure * Split complicated code and add comment * Fix annotations * Fix indenting * Remove dbg_loc before closure * Add dbg_loc in to_scode * Add DBG_CALL and DBG_RETURN * Separate the split at CALL_T and loop * Revert "Separate the split at CALL_T and loop" This reverts commit 4ea823a7ca798c756b20cee32f928f41092c4959. * Revert "Add DBG_CALL and DBG_RETURN" This reverts commit c406c6feb09b6a5bb859c38d634f08208c901e5a. * Disable tail call optimization for better debug call stack * Rename env.debug to env.debug_info * Upgrade aebytecode: Add DBG_CONTRACT * Add DBG_CONTRACT instruction * Check if a var name is fresh in separate function * Add DBG_CONTRACT and DBG_LOC before DBG_DEF * Save fresh names of pattern variables * Implement fsplit_pat_vars for assign * Set fann for switches * Revert "Save fresh names of pattern variables" This reverts commit d2473f982996336131477df2b2115c04a55a62cb. * Add DBG_DEF for switch pattern vars * Fix the inability to pattern match constructors * Upgrade aebytecode dep * Upgrade aebytecode dep * Update the lock file * Add annotations to fexpr var * Fix issues with pretty-printing of fexprs * Use FAnn instead of get_fann(Body) * Upgrade aebytecode version * Fix pp_fpat * Fix pattern matching on fpat * Update rename when a new rename comes up * Upgrade aebytecode * Remove the getopt dep * Fix calldata tests * Remove file committed by mistake * Remove location anns from contract call type --- CHANGELOG.md | 1 + docs/aeso_compiler.md | 2 - rebar.config | 3 +- rebar.lock | 6 +- src/aeso_ast_infer_types.erl | 4 +- src/aeso_ast_to_fcode.erl | 1193 ++++++++++++++++++++-------------- src/aeso_compiler.erl | 14 +- src/aeso_fcode_to_fate.erl | 310 +++++---- src/aeso_syntax.erl | 5 +- 9 files changed, 896 insertions(+), 642 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 25b0b4c..c5cf36f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - API functions for encoding/decoding Sophia values to/from FATE. ### Changed ### Removed +- Remove the mapping from variables to FATE registers from the compilation output. ### Fixed - Warning about unused include when there is no include. diff --git a/docs/aeso_compiler.md b/docs/aeso_compiler.md index 61ee7aa..4798ad4 100644 --- a/docs/aeso_compiler.md +++ b/docs/aeso_compiler.md @@ -53,8 +53,6 @@ The **pp_** options all print to standard output the following: The option `include_child_contract_symbols` includes the symbols of child contracts functions in the generated fate code. It is turned off by default to avoid making contracts bigger on chain. -The option `debug_info` includes information related to debugging in the compiler output. Currently this option only includes the mapping from variables to registers. - #### Options to control which compiler optimizations should run: By default all optimizations are turned on, to disable an optimization, it should be diff --git a/rebar.config b/rebar.config index d22de4b..e07433a 100644 --- a/rebar.config +++ b/rebar.config @@ -2,8 +2,7 @@ {erl_opts, [debug_info]}. -{deps, [ {aebytecode, {git, "https://github.com/aeternity/aebytecode.git", {tag, "v3.2.0"}}} - , {getopt, "1.0.1"} +{deps, [ {aebytecode, {git, "https://github.com/aeternity/aebytecode.git", {tag, "v3.3.0"}}} , {eblake2, "1.0.0"} , {jsx, {git, "https://github.com/talentdeficit/jsx.git", {tag, "2.8.0"}}} ]}. diff --git a/rebar.lock b/rebar.lock index 85a9709..7f13b93 100644 --- a/rebar.lock +++ b/rebar.lock @@ -1,11 +1,11 @@ {"1.2.0", [{<<"aebytecode">>, {git,"https://github.com/aeternity/aebytecode.git", - {ref,"2a0a397afad6b45da52572170f718194018bf33c"}}, + {ref,"b38349274fc2bed98d7fe86877e6e1a2df302109"}}, 0}, {<<"aeserialization">>, {git,"https://github.com/aeternity/aeserialization.git", - {ref,"eb68fe331bd476910394966b7f5ede7a74d37e35"}}, + {ref,"177bf604b2a05e940f92cf00e96e6e269e708245"}}, 1}, {<<"base58">>, {git,"https://github.com/aeternity/erl-base58.git", @@ -16,7 +16,7 @@ {git,"https://github.com/aeternity/enacl.git", {ref,"793ddb502f7fe081302e1c42227dca70b09f8e17"}}, 2}, - {<<"getopt">>,{pkg,<<"getopt">>,<<"1.0.1">>},0}, + {<<"getopt">>,{pkg,<<"getopt">>,<<"1.0.1">>},1}, {<<"jsx">>, {git,"https://github.com/talentdeficit/jsx.git", {ref,"3074d4865b3385a050badf7828ad31490d860df5"}}, diff --git a/src/aeso_ast_infer_types.erl b/src/aeso_ast_infer_types.erl index 9514dea..6a71813 100644 --- a/src/aeso_ast_infer_types.erl +++ b/src/aeso_ast_infer_types.erl @@ -351,11 +351,11 @@ bind_contract(Typing, {Contract, Ann, Id, _Impls, Contents}, Env) Sys = [{origin, system}], TypeOrFresh = fun({typed, _, _, Type}) -> Type; (_) -> fresh_uvar(Sys) end, Fields = - [ {field_t, AnnF, Entrypoint, contract_call_type(Type)} + [ {field_t, AnnF, Entrypoint, contract_call_type(aeso_syntax:set_ann(Sys, Type))} || {fun_decl, AnnF, Entrypoint, Type = {fun_t, _, _, _, _}} <- Contents ] ++ [ {field_t, AnnF, Entrypoint, contract_call_type( - {fun_t, AnnF, [], [TypeOrFresh(Arg) || Arg <- Args], TypeOrFresh(Ret)}) + {fun_t, Sys, [], [TypeOrFresh(Arg) || Arg <- Args], TypeOrFresh(Ret)}) } || {letfun, AnnF, Entrypoint = {id, _, Name}, Args, _Type, [{guarded, _, [], Ret}]} <- Contents, Name =/= "init" diff --git a/src/aeso_ast_to_fcode.erl b/src/aeso_ast_to_fcode.erl index c83d01a..6890926 100644 --- a/src/aeso_ast_to_fcode.erl +++ b/src/aeso_ast_to_fcode.erl @@ -58,34 +58,36 @@ | {contract_code, string()} %% for CREATE, by name | {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()} +-type fann() :: [ {file, aeso_syntax:ann_file()} | {line, aeso_syntax:ann_line()} ]. + +-type fexpr() :: {lit, fann(), flit()} + | {nil, fann()} + | {var, fann(), var_name()} + | {def, fann(), fun_name(), [fexpr()]} + | {remote, fann(), [ftype()], ftype(), fexpr(), fun_name(), [fexpr()]} + | {builtin, fann(), builtin(), [fexpr()]} + | {con, fann(), arities(), tag(), [fexpr()]} + | {tuple, fann(), [fexpr()]} + | {proj, fann(), fexpr(), integer()} + | {set_proj, fann(), fexpr(), integer(), fexpr()} %% tuple, field, new_value + | {op, fann(), op(), [fexpr()]} + | {'let', fann(), var_name(), fexpr(), fexpr()} + | {funcall, fann(), fexpr(), [fexpr()]} %% Call to unknown function + | {closure, fann(), fun_name(), fexpr()} + | {switch, fann(), fsplit()} + | {set_state, fann(), state_reg(), fexpr()} + | {get_state, fann(), 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()}. + | {def_u, fann(), fun_name(), arity()} + | {remote_u, fann(), [ftype()], ftype(), fexpr(), fun_name()} + | {builtin_u, fann(), builtin(), arity()} + | {builtin_u, fann(), builtin(), arity(), [fexpr()]} %% Typerep arguments to be added after normal args. + | {lam, fann(), [var_name()], fexpr()}. -type fsplit() :: {split, ftype(), var_name(), [fcase()]} - | {nosplit, fexpr()}. + | {nosplit, [rename()], fexpr()}. %% Renames are needed to add DBG_DEF for switch pattern vars -type fcase() :: {'case', fsplit_pat(), fsplit()}. @@ -115,18 +117,21 @@ | bits | {variant, [[ftype()]]} | {function, [ftype()], ftype()} - | any | {tvar, var_name()}. + | any + | {tvar, var_name()}. --type fun_def() :: #{ attrs := [attribute()], +-type fun_def() :: #{ attrs := [attribute() | fann()], args := [{var_name(), ftype()}], return := ftype(), body := fexpr() }. +-type functions() :: #{ fun_name() => fun_def() }. + -type fcode() :: #{ contract_name := string(), state_type := ftype(), state_layout := state_layout(), event_type := ftype() | none, - functions := #{ fun_name() => fun_def() }, + functions := functions(), payable := boolean() }. -type type_def() :: fun(([ftype()]) -> ftype()). @@ -137,11 +142,14 @@ -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 expr_env() :: #{ var_name() => fexpr() }. +-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 rename() :: [{var_name(), var_name()}]. -type context() :: {contract_def, string()} | {namespace, string()} @@ -188,6 +196,7 @@ ast_to_fcode(Code, Options) -> clear_fresh_names(Options), {Env3, FCode2}. +-spec optimize(fcode(), [option()]) -> fcode(). optimize(FCode1, Options) -> Verbose = lists:member(pp_fcode, Options), [io:format("-- Before lambda lifting --\n~s\n\n", [format_fcode(FCode1)]) || Verbose], @@ -286,6 +295,7 @@ builtins() -> || {NS, Funs} <- Scopes, {Fun, Arity} <- Funs ]). +-spec state_layout(env()) -> state_layout(). state_layout(Env) -> maps:get(state_layout, Env, {reg, 1}). -define(type(T), fun([]) -> T end). @@ -322,12 +332,15 @@ init_type_env() -> ["MCL_BLS12_381", "fp"] => ?type({bytes, 48}) }. +-spec is_no_code(env()) -> boolean(). is_no_code(Env) -> get_option(no_code, Env). +-spec get_option(atom(), env()) -> option(). get_option(Opt, Env) -> get_option(Opt, Env, false). +-spec get_option(atom(), env(), option()) -> option(). get_option(Opt, Env, Default) -> proplists:get_value(Opt, maps:get(options, Env, []), Default). @@ -374,6 +387,15 @@ 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) -> + File = proplists:lookup(file, Ann), + Line = proplists:lookup(line, Ann), + [ X || X <- [File, Line], X =/= none ]. + +-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 @@ -386,8 +408,11 @@ decls_to_fcode(Env, Decls) -> 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), +decl_to_fcode(Env = #{ functions := Funs, options := Options }, {letfun, Ann, {id, _, Name}, Args, Ret, [{guarded, _, [], Body}]}) -> + Attrs = case proplists:get_value(debug_info, Options, false) of + true -> get_attributes_debug(Ann); + false -> get_attributes(Ann) + end, FName = lookup_fun(Env, qname(Env, Name)), FArgs = args_to_fcode(Env, Args), FRet = type_to_fcode(Env, Ret), @@ -442,6 +467,7 @@ typedef_to_fcode(Env, {id, _, Name}, Xs, Def) -> Env3 = compute_state_layout(Env2, Name, FDef), bind_type(Env3, Q, FDef). +-spec compute_state_layout(env(), string(), type_def()) -> env(). compute_state_layout(Env = #{ context := {contract_def, _} }, "state", Type) -> NoLayout = get_option(no_flatten_state, Env), Layout = @@ -454,6 +480,7 @@ compute_state_layout(Env = #{ context := {contract_def, _} }, "state", Type) -> Env#{ state_layout => Layout }; compute_state_layout(Env, _, _) -> Env. +-spec compute_state_layout(state_reg(), ftype() | [ftype()]) -> {state_reg(), state_layout() | [state_layout()]}. compute_state_layout(R, {tuple, [T]}) -> compute_state_layout(R, T); compute_state_layout(R, {tuple, Ts}) -> @@ -508,19 +535,23 @@ args_to_fcode(Env, Args) -> -define(make_let(X, Expr, Body), make_let(Expr, fun(X) -> Body end)). +-spec make_let(fexpr(), fun((fexpr()) -> fexpr())) -> fexpr(). make_let(Expr, Body) -> case Expr of - {var, _} -> Body(Expr); - {lit, {int, _}} -> Body(Expr); - {lit, {bool, _}} -> Body(Expr); + {var, _, _} -> Body(Expr); + {lit, _, {int, _}} -> Body(Expr); + {lit, _, {bool, _}} -> Body(Expr); _ -> X = fresh_name(), - {'let', X, Expr, Body({var, X})} + FAnn = get_fann(Expr), + {'let', FAnn, X, Expr, Body({var, FAnn, X})} end. -let_bind(X, {var, Y}, Body) -> rename([{X, Y}], Body); -let_bind(X, Expr, Body) -> {'let', X, Expr, Body}. +-spec let_bind(var_name(), fexpr(), fexpr()) -> fexpr(). +let_bind(X, {var, _, Y}, Body) -> rename([{X, Y}], Body); +let_bind(X, Expr, Body) -> {'let', get_fann(Expr), X, Expr, Body}. +-spec let_bind([{var_name(), fexpr()}], fexpr()) -> fexpr(). let_bind(Binds, Body) -> lists:foldr(fun({X, E}, Rest) -> let_bind(X, E, Rest) end, Body, Binds). @@ -534,50 +565,50 @@ expr_to_fcode(Env, 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}}; +expr_to_fcode(_Env, _Type, {int, Ann, N}) -> {lit, to_fann(Ann), {int, N}}; +expr_to_fcode(_Env, _Type, {char, Ann, N}) -> {lit, to_fann(Ann), {int, N}}; +expr_to_fcode(_Env, _Type, {bool, Ann, B}) -> {lit, to_fann(Ann), {bool, B}}; +expr_to_fcode(_Env, _Type, {string, Ann, S}) -> {lit, to_fann(Ann), {string, S}}; +expr_to_fcode(_Env, _Type, {account_pubkey, Ann, K}) -> {lit, to_fann(Ann), {account_pubkey, K}}; +expr_to_fcode(_Env, _Type, {contract_pubkey, Ann, K}) -> {lit, to_fann(Ann), {contract_pubkey, K}}; +expr_to_fcode(_Env, _Type, {oracle_pubkey, Ann, K}) -> {lit, to_fann(Ann), {oracle_pubkey, K}}; +expr_to_fcode(_Env, _Type, {oracle_query_id, Ann, K}) -> {lit, to_fann(Ann), {oracle_query_id, K}}; +expr_to_fcode(_Env, _Type, {bytes, Ann, B}) -> {lit, to_fann(Ann), {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 -> +expr_to_fcode(Env, _Type, {id, Ann, X}) -> resolve_var(Env, Ann, [X]); +expr_to_fcode(Env, Type, {qid, Ann, X}) -> + case resolve_var(Env, Ann, X) of + {builtin_u, FAnn, 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} -> + TypeArgs = [{lit, FAnn, {typerep, QType}}, {lit, FAnn, {typerep, RType}}], + {builtin_u, FAnn, B, Ar, TypeArgs}; + {builtin_u, FAnn, 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} -> + TypeArgs = [{lit, FAnn, {typerep, AensType}}], + {builtin_u, FAnn, B, Ar, TypeArgs}; + {builtin_u, FAnn, B = bytes_split, Ar} -> {fun_t, _, _, _, {tuple_t, _, [{bytes_t, _, N}, _]}} = Type, - {builtin_u, B, Ar, [{lit, {int, N}}]}; + {builtin_u, FAnn, B, Ar, [{lit, FAnn, {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 -> +expr_to_fcode(Env, _Type, {app, _, {typed, _, {C, Ann, _} = 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]}; + true -> {con, to_fann(Ann), Arities, I, [expr_to_fcode(Env, Arg) || Arg <- Args]}; false -> internal_error({constructor_arity_mismatch, Con, length(Args), Arity}) end; @@ -586,18 +617,18 @@ 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}}) -> +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)]}; + {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, FArgs, type_to_fcode(Env, Ret), expr_to_fcode(Env, Rec), + {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, expr_to_fcode(Env, Rec), field_index(Rec, X)} + {proj, to_fann(Ann), expr_to_fcode(Env, Rec), field_index(RecType, X)} end; expr_to_fcode(Env, {record_t, [FieldT]}, {record, _Ann, [_] = Fields}) -> @@ -611,55 +642,56 @@ expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Fields}) -> end, make_tuple(lists:map(FVal, FieldTypes)); -expr_to_fcode(Env, {record_t, [FieldT]}, {record, _Ann, Rec, Fields}) -> +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)} + {upd, Z, E} -> {'let', to_fann(Ann), Z, expr_to_fcode(Env, Rec), expr_to_fcode(bind_var(Env, Z), E)} end; -expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Rec, Fields}) -> +expr_to_fcode(Env, {record_t, FieldTypes}, {record, Ann, Rec, Fields}) -> X = fresh_name(), - Proj = fun(I) -> {proj, {var, X}, I - 1} end, + FAnn = to_fann(Ann), + Proj = fun(I) -> {proj, FAnn, {var, FAnn, 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)} + ({I, {upd, Z, E}}) -> {'let', FAnn, 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)}} + ({I, {set, E}}, R) -> {set_proj, FAnn, R, I - 1, expr_to_fcode(Env, E)}; + ({I, {upd, Z, E}}, R) -> {set_proj, FAnn, R, I - 1, + {'let', FAnn, 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) + true -> {tuple, FAnn, lists:map(Comp, Updates)}; + false -> lists:foldr(Set, {var, FAnn, X}, Updates) end, - {'let', X, expr_to_fcode(Env, Rec), Body}; + {'let', FAnn, 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, {list, Ann, Es}) -> + lists:foldr(fun(E, L) -> {op, to_fann(aeso_syntax:get_ann(E)), '::', [expr_to_fcode(Env, E), L]} end, + {nil, to_fann(Ann)}, 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, {app, As, {'..', _}, [A, B]}) -> + {def_u, FAnn, FromTo, _} = resolve_fun(Env, As, ["ListInternal", "from_to"]), + {def, FAnn, 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, []}) -> + {op, to_fann(As), '::', [expr_to_fcode(Env, Yield), {nil, to_fann(As)}]}; 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, FlatMap, _} = resolve_fun(Env, ["ListInternal", "flat_map"]), - {def, FlatMap, [Bind, expr_to_fcode(Env, BindExpr)]}; + Bind = {lam, to_fann(As), [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, FAnn, FlatMap, _} = resolve_fun(Env, As, ["ListInternal", "flat_map"]), + {def, FAnn, 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 + {nil, to_fann(As)} ); 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}]}); @@ -673,15 +705,15 @@ expr_to_fcode(Env, _Type, {'if', _, Cond, Then, Else}) -> expr_to_fcode(Env, Else)); %% Switch -expr_to_fcode(Env, _, S = {switch, _, Expr = {typed, _, E, Type}, Alts}) -> +expr_to_fcode(Env, _, S = {switch, Ann, Expr = {typed, _, E, Type}, Alts}) -> Switch = fun(X) -> - {switch, alts_to_fcode(Env, type_to_fcode(Env, Type), X, Alts, S)} + {switch, to_fann(Ann), 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), + {'let', to_fann(Ann), X, expr_to_fcode(Env, Expr), Switch(X)} end; @@ -696,54 +728,56 @@ expr_to_fcode(Env, _Type, Expr = {app, _, {Op, _}, [_, _]}) when Op == '&&'; Op 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, Op, [expr_to_fcode(Env, A), expr_to_fcode(Env, B)]} + _ -> {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) -> +expr_to_fcode(Env, _Type, {app, Ann, {Op, _}, [A]}) when is_atom(Op) -> + FAnn = to_fann(Ann), case Op of - '-' -> {op, '-', [{lit, {int, 0}}, expr_to_fcode(Env, A)]}; - '!' -> {op, '!', [expr_to_fcode(Env, A)]} + '-' -> {op, FAnn, '-', [{lit, FAnn, {int, 0}}, expr_to_fcode(Env, A)]}; + '!' -> {op, FAnn, '!', [expr_to_fcode(Env, A)]} end; %% Function calls -expr_to_fcode(Env, _, {app, _, Fun = {typed, _, FunE, {fun_t, _, NamedArgsT, ArgsT, Type}}, Args}) -> +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} -> + {builtin_u, FAnn, B, _Ar, TypeArgs} -> builtin_to_fcode(state_layout(Env), FAnn, B, FArgs ++ TypeArgs); + {builtin_u, FAnn, 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]) + builtin_to_fcode(state_layout(Env), FAnn, chain_clone, [{lit, FAnn, FInitArgsT}|FArgs]) end; - {builtin_u, chain_create, _Ar} -> + {builtin_u, FAnn, 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]); + builtin_to_fcode(state_layout(Env), FAnn, chain_create, [{lit, FAnn, {contract_code, Contract}}, {lit, FAnn, FInitArgsT}|FArgs]); {_, _} -> fcode_error({not_a_contract_type, Type}) end; - {builtin_u, B, _Ar} -> builtin_to_fcode(state_layout(Env), B, FArgs); - {def_u, F, _Ar} -> {def, F, FArgs}; - {remote_u, RArgsT, RRetT, Ct, RFun} -> {remote, RArgsT, RRetT, Ct, RFun, FArgs}; + {builtin_u, FAnn, B, _Ar} -> builtin_to_fcode(state_layout(Env), FAnn, B, FArgs); + {def_u, FAnn, F, _Ar} -> {def, FAnn, F, FArgs}; + {remote_u, FAnn, RArgsT, RRetT, Ct, RFun} -> {remote, FAnn, RArgsT, RRetT, 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, + FAnn = to_fann(Ann), + Call = fun(X) -> {funcall, FAnn, {proj, FAnn, {var, FAnn, X}, 0}, [{proj, FAnn, {var, FAnn, X}, 1} | FArgs]} end, case FFun of - {var, X} -> Call(X); - _ -> X = fresh_name(), - {'let', X, FFun, Call(X)} + {var, _, X} -> Call(X); + _ -> X = fresh_name(), + {'let', FAnn, X, FFun, Call(X)} end end; %% Maps -expr_to_fcode(_Env, _Type, {map, _, []}) -> - {builtin, map_empty, []}; +expr_to_fcode(_Env, _Type, {map, Ann, []}) -> + {builtin, to_fann(Ann), 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). @@ -753,59 +787,72 @@ 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 -> + {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, map_get, [Map1, Key]}; - [D] -> {op, map_get_d, [Map1, Key, expr_to_fcode(Env, D)]} + [] -> {op, FAnn, map_get, [Map1, Key]}; + [D] -> {op, FAnn, 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))]}} + {'let', FAnn, 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, _, 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, {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}) -> +expr_to_fcode(Env, _Type, {lam, Ann, Args, Body}) -> GetArg = fun({arg, _, {id, _, X}, _}) -> X end, Xs = lists:map(GetArg, Args), - {lam, Xs, expr_to_fcode(bind_vars(Env, Xs), Body)}; + {lam, to_fann(Ann), 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}}]}}; +-spec make_if(fexpr(), fexpr(), fexpr()) -> fexpr(). +make_if({var, FAnn, X}, Then, Else) -> + {switch, FAnn, {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)}. + FAnn = get_fann(Cond), + {'let', FAnn, X, Cond, make_if({var, FAnn, X}, Then, Else)}. -make_if_no_else({var, X}, Then) -> - {switch, {split, boolean, X, - [{'case', {bool, true}, {nosplit, Then}}]}}; +-spec make_if_no_else(fexpr(), fexpr()) -> fexpr(). +make_if_no_else({var, FAnn, X}, Then) -> + {switch, FAnn, {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)}. + FAnn = get_fann(Cond), + {'let', FAnn, X, Cond, make_if_no_else({var, FAnn, X}, Then)}. -spec make_tuple([fexpr()]) -> fexpr(). make_tuple([E]) -> E; -make_tuple(Es) -> {tuple, Es}. +make_tuple(Es) -> {tuple, [], Es}. + +-spec make_tuple_fpat([fpat()]) -> fpat(). +make_tuple_fpat([P]) -> P; +make_tuple_fpat(Ps) -> {tuple, Ps}. -spec strip_singleton_tuples(ftype()) -> ftype(). -strip_singleton_tuples({tuple, [T]}) -> strip_singleton_tuples(T); +strip_singleton_tuples({tuple, _, [T]}) -> strip_singleton_tuples(T); strip_singleton_tuples(T) -> T. +-spec get_oracle_type(OracleFun, FunT) -> OracleType when + OracleFun :: atom(), + FunT :: aeso_syntax:type(), + OracleType :: aeso_syntax:type(). 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; @@ -827,11 +874,13 @@ alts_to_fcode(Env, Type, X, Alts, Switch) -> | {bool, false | true} | {int, integer()} | {string, binary()} - | nil | {'::', fpat(), fpat()} + | nil + | {'::', fpat(), fpat()} | {tuple, [fpat()]} | {con, arities(), tag(), [fpat()]} | {assign, fpat(), fpat()}. +-spec remove_guards(env(), [aeso_syntax:alt()], aeso_syntax:expr()) -> [falt()]. remove_guards(_Env, [], _Switch) -> []; remove_guards(Env, [Alt = {'case', _, _, [{guarded, _, [], _Expr}]} | Rest], Switch) -> @@ -878,7 +927,7 @@ split_tree(Env, Vars, Alts = [{'case', Pats, Body} | _]) -> 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)}; + {nosplit, Ren, rename(Ren, Body)}; I when is_integer(I) -> {Vars0, [{X, Type} | Vars1]} = lists:split(I - 1, Vars), Type1 = strip_singleton_tuples(Type), @@ -890,10 +939,13 @@ split_tree(Env, Vars, Alts = [{'case', Pats, Body} | _]) -> {split, Type1, X, Cases} end. --spec merge_alts(integer(), var_name(), [{fsplit_pat(), falt()}]) -> [{fsplit_pat(), [falt()]}]. +-spec merge_alts(integer(), var_name(), Alts) -> [{fsplit_pat(), [falt()]}] when + Alts :: [{fsplit_pat(), falt()}]. merge_alts(I, X, Alts) -> merge_alts(I, X, Alts, []). +-spec merge_alts(integer(), var_name(), Alts, Alts) -> [{fsplit_pat(), [falt()]}] when + Alts :: [{fsplit_pat(), falt()}]. merge_alts(I, X, Alts, Alts1) -> lists:foldr(fun(A, As) -> merge_alt(I, X, A, As) end, Alts1, Alts). @@ -907,7 +959,7 @@ merge_alt(I, X, {P, A}, [{Q, As} | Rest]) -> ({bool, B}, {bool, B}) -> match; ({int, N}, {int, N}) -> match; ({string, S}, {string, S}) -> match; - (nil, nil) -> match; + (nil, nil) -> match; ({'::', _, _}, {'::', _, _}) -> match; ({con, _, C, _}, {con, _, C, _}) -> match; ({con, _, _, _}, {con, _, _, _}) -> mismatch; @@ -924,6 +976,7 @@ merge_alt(I, X, {P, A}, [{Q, As} | Rest]) -> insert -> [{P, [A]}, {Q, As} | Rest] end. +-spec expand(integer(), var_name(), fsplit_pat(), fsplit_pat(), falt()) -> term(). 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), @@ -956,11 +1009,11 @@ split_alt(I, {'case', Pats, Body}) -> {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 = {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], @@ -975,7 +1028,7 @@ split_pat({tuple, Pats}) -> split_vars({bool, _}, boolean) -> []; split_vars({int, _}, integer) -> []; split_vars({string, _}, string) -> []; -split_vars(nil, {list, _}) -> []; +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}) -> @@ -1013,7 +1066,7 @@ pat_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Pats}) when C #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 ]); + make_tuple_fpat([ 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}; @@ -1031,7 +1084,7 @@ pat_to_fcode(Env, {record_t, Fields}, {record, _, FieldPats}) -> {set, Pat} -> Pat %% {upd, _, _} is impossible in patterns end end, - make_tuple([pat_to_fcode(Env, FieldPat(Field)) + make_tuple_fpat([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)}; @@ -1041,6 +1094,12 @@ pat_to_fcode(_Env, Type, Pat) -> %% -- Decision trees for boolean operators -- +-type decision_tree() :: false + | true + | {atom, fexpr()} + | {'if', fexpr(), decision_tree(), decision_tree()}. + +-spec decision_op(aeso_syntax:op(), decision_tree(), decision_tree()) -> decision_tree(). decision_op('&&', {atom, A}, B) -> {'if', A, B, false}; decision_op('&&', false, _) -> false; decision_op('&&', true, B) -> B; @@ -1050,26 +1109,28 @@ decision_op('||', true, _) -> true; decision_op(Op, {'if', A, Then, Else}, B) -> {'if', A, decision_op(Op, Then, B), decision_op(Op, Else, B)}. +-spec expr_to_decision_tree(env(), aeso_syntax:expr()) -> decision_tree(). 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}}; +-spec decision_tree_to_fcode(decision_tree()) -> fexpr(). +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)}}]}}}. + {'let', get_fann(A), X, A, + {switch, get_fann(A), {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, {typed, _, {id, _, X}, _}, Expr} | Stmts]) -> + {'let', to_fann(Ann), 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]) -> @@ -1077,15 +1138,17 @@ stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, [{guarded, _, [], Ex {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}), + {'let', to_fann(Ann), 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)}. + {'let', to_fann(aeso_syntax:get_ann(Expr)), "_", expr_to_fcode(Env, Expr), stmts_to_fcode(Env, Stmts)}. %% -- Builtins -- +-spec op_builtins() -> [BuiltinFun] when + BuiltinFun :: atom(). op_builtins() -> [map_from_list, map_to_list, map_delete, map_member, map_size, stringinternal_length, stringinternal_concat, stringinternal_to_list, stringinternal_from_list, @@ -1105,47 +1168,52 @@ op_builtins() -> mcl_bls12_381_int_to_fr, mcl_bls12_381_int_to_fp, mcl_bls12_381_fr_to_int, mcl_bls12_381_fp_to_int ]. -set_state({reg, R}, Val) -> - {set_state, R, Val}; -set_state({tuple, Ls}, Val) -> +-spec set_state(state_layout(), fann(), fexpr()) -> fexpr(). +set_state({reg, R}, FAnn, Val) -> + {set_state, FAnn, R, Val}; +set_state({tuple, Ls}, FAnn, Val) -> ?make_let(X, Val, lists:foldr(fun({I, L}, Code) -> - {'let', "_", set_state(L, {proj, X, I - 1}), Code} - end, {tuple, []}, indexed(Ls))). + {'let', FAnn, "_", set_state(L, FAnn, {proj, FAnn, X, I - 1}), Code} + end, {tuple, FAnn, []}, indexed(Ls))). -get_state({reg, R}) -> - {get_state, R}; -get_state({tuple, Ls}) -> - {tuple, [get_state(L) || L <- Ls]}. +-spec get_state(state_layout(), fann()) -> fexpr(). +get_state({reg, R}, FAnn) -> + {get_state, FAnn, R}; +get_state({tuple, Ls}, FAnn) -> + {tuple, FAnn, [get_state(L, FAnn) || 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]) -> +-spec builtin_to_fcode(state_layout(), fann(), BuiltinFun, [fexpr()]) -> fexpr() when + BuiltinFun :: atom(). %% No need to mention all of them +builtin_to_fcode(Layout, FAnn, set_state, [Val]) -> + set_state(Layout, FAnn, Val); +builtin_to_fcode(Layout, FAnn, get_state, []) -> + get_state(Layout, FAnn); +builtin_to_fcode(_Layout, FAnn, require, [Cond, Msg]) -> + make_if(Cond, {tuple, FAnn, []}, {builtin, FAnn, abort, [Msg]}); +builtin_to_fcode(_Layout, FAnn, chain_event, [Event]) -> + {def, FAnn, event, [Event]}; +builtin_to_fcode(_Layout, FAnn, map_delete, [Key, Map]) -> + {op, FAnn, map_delete, [Map, Key]}; +builtin_to_fcode(_Layout, FAnn, map_member, [Key, Map]) -> + {op, FAnn, map_member, [Map, Key]}; +builtin_to_fcode(_Layout, FAnn, 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) -> + make_if({op, FAnn, map_member, [Map, Key]}, + {con, FAnn, [0, 1], 1, [{op, FAnn, map_get, [Map, Key]}]}, + {con, FAnn, [0, 1], 0, []}))); +builtin_to_fcode(_Layout, FAnn, map_lookup_default, [Key, Map, Def]) -> + {op, FAnn, map_get_d, [Map, Key, Def]}; +builtin_to_fcode(_Layout, FAnn, Builtin, Args) -> case lists:member(Builtin, op_builtins()) of - true -> {op, Builtin, Args}; - false -> {builtin, Builtin, Args} + true -> {op, FAnn, Builtin, Args}; + false -> {builtin, FAnn, Builtin, Args} end. %% -- Init function -- +-spec add_init_function(env(), functions()) -> functions(). add_init_function(Env, Funs0) -> case is_no_code(Env) of true -> Funs0; @@ -1154,10 +1222,11 @@ add_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]) } }, + body => builtin_to_fcode(state_layout(Env), [], set_state, [InitBody]) } }, Funs1 end. +-spec add_default_init_function(env(), functions()) -> functions(). add_default_init_function(_Env, Funs) -> InitName = {entrypoint, <<"init">>}, case maps:get(InitName, Funs, none) of @@ -1165,38 +1234,40 @@ add_default_init_function(_Env, Funs) -> Funs#{ InitName => #{attrs => [], args => [], return => {tuple, []}, - body => {tuple, []}} }; + body => {tuple, [], []}} }; _ -> Funs end. %% -- Event function -- +-spec add_event_function(env(), ftype() | none, functions()) -> functions(). add_event_function(_Env, none, Funs) -> Funs; add_event_function(Env, EventFType, Funs) -> Funs#{ event => event_function(Env, EventFType) }. +-spec event_function(env(), ftype()) -> fun_def(). 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}}, + 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} + [] -> {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}} + 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)}} }. + body => {switch, [], {split, EventType, "e", lists:map(Case, Cons)}} }. %% -- Lambda lifting --------------------------------------------------------- %% The expr_to_fcode compiler lambda expressions to {lam, Xs, Body}, but in @@ -1211,18 +1282,25 @@ lambda_lift(FCode = #{ functions := Funs, state_layout := StateLayout }) -> FCode#{ functions := maps:merge(Funs1, NewFuns) }. -define(lambda_key, '%lambdalifted'). + +-spec init_lambda_funs() -> term(). init_lambda_funs() -> put(?lambda_key, #{}). + +-spec get_lambda_funs() -> term(). get_lambda_funs() -> erase(?lambda_key). +-spec add_lambda_fun(fun_def()) -> fun_name(). add_lambda_fun(Def) -> Name = fresh_fun(), Funs = get(?lambda_key), put(?lambda_key, Funs#{ Name => Def }), Name. +-spec lambda_lift_fun(state_layout(), fun_def()) -> fun_def(). lambda_lift_fun(Layout, Def = #{ body := Body }) -> Def#{ body := lambda_lift_expr(Layout, Body) }. +-spec lifted_fun([var_name()], [var_name()], fexpr()) -> fun_def(). lifted_fun([Z], Xs, Body) -> #{ attrs => [private], args => [{Z, any} | [{X, any} || X <- Xs]], @@ -1230,65 +1308,73 @@ lifted_fun([Z], Xs, Body) -> body => Body }; lifted_fun(FVs, Xs, Body) -> Z = "%env", - Proj = fun({I, Y}, E) -> {'let', Y, {proj, {var, Z}, I - 1}, E} end, + FAnn = get_fann(Body), + Proj = fun({I, Y}, E) -> {'let', FAnn, Y, {proj, FAnn, {var, FAnn, Z}, I - 1}, E} end, #{ attrs => [private], args => [{Z, any} | [{X, any} || X <- Xs]], return => any, body => lists:foldr(Proj, Body, indexed(FVs)) }. +-spec make_closure([var_name()], [var_name()], fexpr()) -> Closure when + Closure :: fexpr(). 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])}. + FAnn = get_fann(Body), + Tup = fun([Y]) -> Y; (Ys) -> {tuple, FAnn, Ys} end, + {closure, FAnn, Fun, Tup([{var, FAnn, Y} || Y <- FVs])}. -lambda_lift_expr(Layout, {lam, Xs, Body}) -> - FVs = free_vars({lam, Xs, Body}), +-spec lambda_lift_expr(state_layout(), fexpr()) -> Closure when + Closure :: fexpr(). +lambda_lift_expr(Layout, L = {lam, _, Xs, Body}) -> + FVs = free_vars(L), 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), + [Tag, _, F, Ar | _] = tuple_to_list(UExpr), ExtraArgs = case UExpr of - {builtin_u, _, _, TypeArgs} -> TypeArgs; - _ -> [] + {builtin_u, _, _, _, TypeArgs} -> TypeArgs; + _ -> [] end, Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, Ar) ], - Args = [{var, X} || X <- Xs] ++ ExtraArgs, + Args = [{var, get_fann(UExpr), X} || X <- Xs] ++ ExtraArgs, Body = case Tag of - builtin_u -> builtin_to_fcode(Layout, F, Args); - def_u -> {def, F, Args} + builtin_u -> builtin_to_fcode(Layout, get_fann(UExpr), F, Args); + def_u -> {def, get_fann(UExpr), F, Args} end, make_closure([], Xs, Body); -lambda_lift_expr(Layout, {remote_u, ArgsT, RetT, Ct, F}) -> +lambda_lift_expr(Layout, {remote_u, FAnn, 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, ArgsT, RetT, Ct1, F, Args}); + Args = [{var, [], X} || X <- Xs], + make_closure(FVs, Xs, {remote, FAnn, 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)} + {lit, _, _} -> Expr; + {nil, _} -> Expr; + {var, _, _} -> Expr; + {closure, _, _, _} -> Expr; + {def, FAnn, D, As} -> {def, FAnn, D, lambda_lift_exprs(Layout, As)}; + {builtin, FAnn, B, As} -> {builtin, FAnn, B, lambda_lift_exprs(Layout, As)}; + {remote, FAnn, ArgsT, RetT, Ct, F, As} -> {remote, FAnn, ArgsT, RetT, lambda_lift_expr(Layout, Ct), F, lambda_lift_exprs(Layout, As)}; + {con, FAnn, Ar, C, As} -> {con, FAnn, Ar, C, lambda_lift_exprs(Layout, As)}; + {tuple, FAnn, As} -> {tuple, FAnn, lambda_lift_exprs(Layout, As)}; + {proj, FAnn, A, I} -> {proj, FAnn, lambda_lift_expr(Layout, A), I}; + {set_proj, FAnn, A, I, B} -> {set_proj, FAnn, lambda_lift_expr(Layout, A), I, lambda_lift_expr(Layout, B)}; + {op, FAnn, Op, As} -> {op, FAnn, Op, lambda_lift_exprs(Layout, As)}; + {'let', FAnn, X, A, B} -> {'let', FAnn, X, lambda_lift_expr(Layout, A), lambda_lift_expr(Layout, B)}; + {funcall, FAnn, A, Bs} -> {funcall, FAnn, lambda_lift_expr(Layout, A), lambda_lift_exprs(Layout, Bs)}; + {set_state, FAnn, R, A} -> {set_state, FAnn, R, lambda_lift_expr(Layout, A)}; + {get_state, _, _} -> Expr; + {switch, FAnn, S} -> {switch, FAnn, lambda_lift_expr(Layout, S)}; + {split, Type, X, Alts} -> {split, Type, X, lambda_lift_exprs(Layout, Alts)}; + {nosplit, Rens, A} -> {nosplit, Rens, lambda_lift_expr(Layout, A)}; + {'case', P, S} -> {'case', P, lambda_lift_expr(Layout, S)} end. +-spec lambda_lift_exprs(state_layout(), [fexpr()]) -> [Closure] when + Closure :: fexpr(). lambda_lift_exprs(Layout, As) -> [lambda_lift_expr(Layout, A) || A <- As]. %% -- Optimisations ---------------------------------------------------------- @@ -1325,68 +1411,82 @@ optimize_fun(Fcode, Fun, Def = #{ body := Body0 }, Options) -> %% --- Inlining --- -spec inliner(fcode(), fun_name(), fexpr()) -> fexpr(). -inliner(Fcode, Fun, {def, Fun1, Args} = E) when Fun1 /= Fun -> +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. +-spec should_inline(fcode(), fun_name()) -> boolean(). should_inline(_Fcode, _Fun1) -> false == list_to_atom("true"). %% Dialyzer -inline(_Fcode, Fun, Args) -> {def, Fun, Args}. %% TODO +-spec inline(fcode(), fun_name(), Args) -> Def when + Args :: [fexpr()], + Def :: fexpr(). +inline(_Fcode, Fun, Args) -> {def, [], Fun, Args}. %% TODO %% --- Bind subexpressions --- -define(make_lets(Xs, Es, Body), make_lets(Es, fun(Xs) -> Body end)). +-spec bind_subexpressions(fexpr()) -> fexpr(). 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}); +-spec bind_subexpressions(expr_env(), fexpr()) -> fexpr(). +bind_subexpressions(_, {tuple, FAnn, Es}) -> + ?make_lets(Xs, Es, {tuple, FAnn, Xs}); +bind_subexpressions(_, {set_proj, FAnn, A, I, B}) -> + ?make_lets([X, Y], [A, B], {set_proj, FAnn, X, I, Y}); bind_subexpressions(_, E) -> E. +-spec make_lets([fexpr()], fun(([fexpr()]) -> fexpr())) -> fexpr(). make_lets(Es, Body) -> make_lets(Es, [], Body). +-spec make_lets([fexpr()], [fexpr()], fun(([fexpr()]) -> fexpr())) -> fexpr(). make_lets([], Xs, Body) -> Body(lists:reverse(Xs)); -make_lets([{var, _} = E | Es], Xs, Body) -> +make_lets([{var, _, _} = E | Es], Xs, Body) -> make_lets(Es, [E | Xs], Body); -make_lets([{lit, _} = E | Es], 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 --- +-spec inline_local_functions(fexpr()) -> fexpr(). 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) -> +-spec inline_local_functions(expr_env(), fexpr()) -> fexpr(). +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 + {lam, _, Xs, Body} -> let_bind(lists:zip(Xs, Args), Body); + _ -> Expr end; inline_local_functions(_, Expr) -> Expr. %% --- Let-floating --- +-spec let_floating(fexpr()) -> fexpr(). 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}) -> +-spec let_float(expr_env(), fexpr()) -> fexpr(). +let_float(_, {'let', FAnn, X, E, Body}) -> + pull_out_let({'let', FAnn, X, {here, E}, Body}); +let_float(_, {proj, FAnn, E, I}) -> + pull_out_let({proj, FAnn, {here, E}, I}); +let_float(_, {set_proj, FAnn, E, I, V}) -> + pull_out_let({set_proj, FAnn, {here, E}, I, {here, V}}); +let_float(_, {op, FAnn, Op, Es}) -> {Lets, Es1} = pull_out_let([{here, E} || E <- Es]), - let_bind(Lets, {op, Op, Es1}); + let_bind(Lets, {op, FAnn, Op, Es1}); let_float(_, E) -> E. +-spec pull_out_let(fexpr() | [fexpr()]) -> fexpr() | {Lets, [fexpr()]} when + Lets :: [{var_name(), fexpr()}]. pull_out_let(Expr) when is_tuple(Expr) -> {Lets, Es} = pull_out_let(tuple_to_list(Expr)), Inner = list_to_tuple(Es), @@ -1406,9 +1506,13 @@ pull_out_let(Es) when is_list(Es) -> end. %% Also renames the variables to fresh names +-spec let_view(fexpr()) -> {Lets, fexpr()} when + Lets :: [{var_name(), fexpr()}]. let_view(E) -> let_view(E, [], []). -let_view({'let', X, E, Rest}, Ren, Lets) -> +-spec let_view(fexpr(), rename(), Lets) -> {Lets, fexpr()} when + Lets :: [{var_name(), fexpr()}]. +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) -> @@ -1420,62 +1524,63 @@ let_view(E, Ren, Lets) -> simplifier(Expr) -> bottom_up(fun simplify/2, Expr). --spec simplify(#{var_name() => fexpr()}, fexpr()) -> fexpr(). +-spec simplify(expr_env(), fexpr()) -> fexpr(). %% (eâ‚€, .., en).i -> %% let _ = eâ‚€ in .. let x = ei in .. let _ = en in x -simplify(_Env, {proj, {tuple, Es}, I}) -> +simplify(_Env, {proj, FAnn, {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, + Val = if Dup -> It; true -> {var, FAnn, X} end, lists:foldr( fun({J, E}, Rest) when I == J -> case Dup of true -> Rest; - false -> {'let', X, E, Rest} + false -> {'let', FAnn, X, E, Rest} end; ({_, E}, Rest) -> case read_only(E) of true -> Rest; - false -> {'let', "_", E, Rest} + false -> {'let', FAnn, "_", 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 +simplify(Env, {proj, _, Var = {var, _, _}, I} = Expr) -> + case simpl_proj(Env, I, Var) 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}; +simplify(Env, {switch, FAnn, Split}) -> + case simpl_switch(Env, FAnn, [], Split) of + nomatch -> {builtin, FAnn, abort, [{lit, FAnn, {string, <<"Incomplete patterns">>}}]}; Expr -> Expr end; simplify(_, E) -> E. +-spec simpl_proj(expr_env(), integer(), fexpr()) -> fexpr() | false. 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 + 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. +-spec get_catchalls([fcase()]) -> [fcase()]. get_catchalls(Alts) -> - [ C || C = {'case', {var, _}, _} <- 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 @@ -1485,6 +1590,7 @@ get_catchalls(Alts) -> %% _ => switch(x) %% .. %% _ => e +-spec add_catchalls([fcase()], [fcase()]) -> [fcase()]. add_catchalls(Alts, []) -> Alts; add_catchalls(Alts, Catchalls) -> case lists:splitwith(fun({'case', {var, _}, _}) -> false; (_) -> true end, @@ -1494,118 +1600,120 @@ add_catchalls(Alts, Catchalls) -> %% NOTE: relies on catchalls always being at the end end. -nest_catchalls([C = {'case', {var, _}, {nosplit, _}} | _]) -> C; +-spec nest_catchalls([fcase()]) -> fcase(). +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}) -> +-spec simpl_switch(expr_env(), fann(), [fcase()], fsplit()) -> fexpr() | nomatch. +simpl_switch(_Env, _FAnn, _, {nosplit, _, E}) -> E; +simpl_switch(Env, FAnn, Catchalls, {split, Type, X, Alts}) -> Alts1 = add_catchalls(Alts, Catchalls), - Stuck = {switch, {split, Type, X, Alts1}}, - case constructor_form(Env, {var, X}) of + Stuck = {switch, FAnn, {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 + E -> simpl_case(Env, E, Alts1) end. +-spec simpl_case(expr_env(), fexpr(), [fcase()]) -> fexpr() | nomatch. 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 + case simpl_switch(Env1, get_fann(E), 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. +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. +-spec constructor_form(expr_env(), fexpr()) -> fexpr() | false. constructor_form(Env, Expr) -> case Expr of - {var, X} -> + {var, _, X} -> case maps:get(X, Env, free) of free -> false; E -> constructor_form(Env, E) %% TODO: shadowing? end; - {set_proj, E, I, V} -> + {set_proj, _, E, I, V} -> case constructor_form(Env, E) of - {tuple, Es} -> {tuple, setnth(I + 1, V, Es)}; - _ -> false + {tuple, FAnn, Es} -> {tuple, FAnn, setnth(I + 1, V, Es)}; + _ -> false end; - {proj, E, I} -> + {proj, _, E, I} -> case constructor_form(Env, E) of - {tuple, Es} -> constructor_form(Env, lists:nth(I + 1, Es)); - _ -> false + {tuple, _, Es} -> constructor_form(Env, lists:nth(I + 1, Es)); + _ -> false end; - {con, _, _, _} -> Expr; - {tuple, _} -> Expr; - {lit, _} -> Expr; - nil -> Expr; - {op, '::', _} -> Expr; - _ -> false + {con, _, _, _, _} -> Expr; + {tuple, _, _} -> Expr; + {lit, _, _} -> Expr; + {nil, _} -> Expr; + {op, _, '::', _} -> Expr; + _ -> false end. %% --- Drop unused lets --- +-spec drop_unused_lets(fexpr()) -> fexpr(). drop_unused_lets(Expr) -> bottom_up(fun drop_unused_lets/2, Expr). -drop_unused_lets(_, {'let', X, E, Body} = Expr) -> +-spec drop_unused_lets(expr_env(), fexpr()) -> fexpr(). +drop_unused_lets(_, {'let', FAnn, X, E, Body} = Expr) -> case {read_only(E), not lists:member(X, free_vars(Body))} of {true, true} -> Body; - {false, true} -> {'let', "_", E, Body}; + {false, true} -> {'let', FAnn, "_", 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 safe_to_duplicate(fexpr()) -> boolean(). +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). +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 --- @@ -1615,12 +1723,15 @@ eliminate_dead_code(Code = #{ 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 }. +-spec used_functions(functions()) -> Used when + Used :: #{ fun_name() => true }. used_functions(Funs) -> Exported = [ Fun || {Fun, #{ attrs := Attrs }} <- maps:to_list(Funs), not lists:member(private, Attrs) ], used_functions(#{}, Exported, Funs). +-spec used_functions(Used, [fun_name()], functions()) -> Used when + Used :: #{ fun_name() => true }. used_functions(Used, [], _) -> Used; used_functions(Used, [Name | Rest], Defs) -> case maps:is_key(Name, Used) of @@ -1681,6 +1792,7 @@ add_fun_env(Env = #{ fun_env := FunEnv }, Decls) -> FunEnv1 = maps:from_list(lists:flatmap(Entry, Decls)), Env#{ fun_env := maps:merge(FunEnv, FunEnv1) }. +-spec make_fun_name(env(), aeso_syntax:ann(), aeso_syntax:name()) -> fun_name(). make_fun_name(#{ context := Context }, Ann, Name) -> Entrypoint = proplists:get_value(entrypoint, Ann, false), case Context of @@ -1720,23 +1832,26 @@ lookup_con(#{ con_env := ConEnv }, Con) -> Tag -> Tag end. +-spec bind_vars(env(), [var_name()]) -> env(). bind_vars(Env, Xs) -> lists:foldl(fun(X, E) -> bind_var(E, X) end, Env, Xs). +-spec bind_var(env(), var_name()) -> env(). bind_var(Env = #{ vars := Vars }, X) -> Env#{ vars := [X | Vars] }. -resolve_var(#{ vars := Vars } = Env, [X]) -> +-spec resolve_var(env(), aeso_syntax:ann(), [aeso_syntax:name()]) -> fexpr(). +resolve_var(#{ vars := Vars } = Env, Ann, [X]) -> case lists:member(X, Vars) of - true -> {var, X}; + true -> {var, to_fann(Ann), X}; false -> case resolve_const(Env, [X]) of - false -> resolve_fun(Env, [X]); + false -> resolve_fun(Env, Ann, [X]); Const -> Const end end; -resolve_var(Env, Q) -> +resolve_var(Env, Ann, Q) -> case resolve_const(Env, Q) of - false -> resolve_fun(Env, Q); + false -> resolve_fun(Env, Ann, Q); Const -> Const end. @@ -1746,25 +1861,30 @@ resolve_const(#{ consts := Consts }, Q) -> Val -> Val end. -resolve_fun(#{ fun_env := Funs, builtins := Builtin } = Env, Q) -> +-spec resolve_fun(env(), aeso_syntax:ann(), [aeso_syntax:name()]) -> fexpr(). +resolve_fun(#{ fun_env := Funs, builtins := Builtin } = Env, Ann, 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} + {_, {B, none}} -> builtin_to_fcode(state_layout(Env), to_fann(Ann), B, []); + {_, {B, Ar}} -> {builtin_u, to_fann(Ann), B, Ar}; + {{Fun, Ar}, _} -> {def_u, to_fann(Ann), Fun, Ar} end. +-spec init_fresh_names([option()]) -> term(). init_fresh_names(Options) -> proplists:get_value(debug_info, Options, false) andalso init_saved_fresh_names(), put('%fresh', 0). +-spec clear_fresh_names([option()]) -> term(). clear_fresh_names(Options) -> proplists:get_value(debug_info, Options, false) andalso clear_saved_fresh_names(), erase('%fresh'). +-spec init_saved_fresh_names() -> term(). init_saved_fresh_names() -> put(saved_fresh_names, #{}). +-spec clear_saved_fresh_names() -> term(). clear_saved_fresh_names() -> erase(saved_fresh_names). @@ -1809,96 +1929,103 @@ 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. +fsplit_pat_vars({con, _, _, Ps}) -> Ps; +fsplit_pat_vars({assign, X, P}) -> [X, P]. +-spec free_vars(fexpr() | [fexpr()]) -> [var_name()]. 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)) + {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', FAnn, X, A, B} -> free_vars([A, {lam, FAnn, [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. +-spec used_defs(fexpr() | [fexpr()]) -> [fun_name()]. 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) + {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. +-spec bottom_up(Fun, fexpr()) -> fexpr() when + Fun :: fun((expr_env(), fexpr()) -> fexpr()). bottom_up(F, Expr) -> bottom_up(F, #{}, Expr). +-spec bottom_up(Fun, expr_env(), fexpr()) -> fexpr() when + Fun :: fun((expr_env(), fexpr()) -> fexpr()). 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; + {lit, _, _} -> Expr; + {nil, _} -> Expr; + {var, _, _} -> Expr; + {def, FAnn, D, Es} -> {def, FAnn, D, [bottom_up(F, Env, E) || E <- Es]}; + {def_u, _, _, _} -> Expr; + {builtin, FAnn, B, Es} -> {builtin, FAnn, B, [bottom_up(F, Env, E) || E <- Es]}; {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} -> + {builtin_u, _, _, _, _} -> Expr; + {remote, FAnn, ArgsT, RetT, Ct, Fun, Es} -> {remote, FAnn, ArgsT, RetT, bottom_up(F, Env, Ct), Fun, [bottom_up(F, Env, E) || E <- Es]}; + {remote_u, FAnn, ArgsT, RetT, Ct, Fun} -> {remote_u, FAnn, ArgsT, RetT, bottom_up(F, Env, Ct), Fun}; + {con, FAnn, Ar, I, Es} -> {con, FAnn, Ar, I, [bottom_up(F, Env, E) || E <- Es]}; + {tuple, FAnn, Es} -> {tuple, FAnn, [bottom_up(F, Env, E) || E <- Es]}; + {proj, FAnn, E, I} -> {proj, FAnn, bottom_up(F, Env, E), I}; + {set_proj, FAnn, R, I, E} -> {set_proj, FAnn, bottom_up(F, Env, R), I, bottom_up(F, Env, E)}; + {op, FAnn, Op, Es} -> {op, FAnn, Op, [bottom_up(F, Env, E) || E <- Es]}; + {funcall, FAnn, Fun, Es} -> {funcall, FAnn, bottom_up(F, Env, Fun), [bottom_up(F, Env, E) || E <- Es]}; + {set_state, FAnn, R, E} -> {set_state, FAnn, R, bottom_up(F, Env, E)}; + {get_state, _, _} -> Expr; + {closure, FAnn, F, CEnv} -> {closure, FAnn, F, bottom_up(F, Env, CEnv)}; + {switch, FAnn, Split} -> {switch, FAnn, bottom_up(F, Env, Split)}; + {lam, FAnn, Xs, B} -> {lam, FAnn, Xs, bottom_up(F, Env, B)}; + {'let', FAnn, 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); @@ -1907,16 +2034,17 @@ bottom_up(F, Env, Expr) -> true -> Z = fresh_name_save(X), Env1 = Env#{ Z => E1 }, - {'let', Z, E1, bottom_up(F, Env1, rename([{X, Z}], Body))}; + {'let', FAnn, Z, E1, bottom_up(F, Env1, rename([{X, Z}], Body))}; false -> Env1 = Env#{ X => E1 }, - {'let', X, E1, bottom_up(F, Env1, Body)} + {'let', FAnn, 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)}; + {nosplit, Rens, E} -> {nosplit, Rens, bottom_up(F, Env, E)}; {'case', Pat, Split} -> {'case', Pat, bottom_up(F, Env, Split)} end). +-spec get_named_args([aeso_syntax:named_arg_t()], [aeso_syntax:arg_expr()]) -> [aeso_syntax:expr()]. get_named_args(NamedArgsT, Args) -> IsNamed = fun({named_arg, _, _, _}) -> true; (_) -> false end, @@ -1924,6 +2052,7 @@ get_named_args(NamedArgsT, Args) -> NamedArgs = [get_named_arg(NamedArg, Named) || NamedArg <- NamedArgsT], NamedArgs ++ NotNamed. +-spec get_named_arg(aeso_syntax:named_arg_t(), [aeso_syntax:arg_expr()]) -> aeso_syntax:expr(). get_named_arg({named_arg_t, _, {id, _, Name}, _, Default}, Args) -> case [ Val || {named_arg, _, {id, _, X}, Val} <- Args, X == Name ] of [Val] -> Val; @@ -1932,38 +2061,41 @@ get_named_arg({named_arg_t, _, {id, _, Name}, _, Default}, Args) -> %% -- Renaming -- --spec rename([{var_name(), var_name()}], fexpr()) -> fexpr(). +-spec rename(rename(), 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} -> + {lit, _, _} -> Expr; + {nil, FAnn} -> {nil, FAnn}; + {var, FAnn, X} -> {var, FAnn, rename_var(Ren, X)}; + {def, FAnn, D, Es} -> {def, FAnn, D, [rename(Ren, E) || E <- Es]}; + {def_u, _, _, _} -> Expr; + {builtin, FAnn, B, Es} -> {builtin, FAnn, B, [rename(Ren, E) || E <- Es]}; + {builtin_u, _, _, _} -> Expr; + {builtin_u, _, _, _, _} -> Expr; + {remote, FAnn, ArgsT, RetT, Ct, F, Es} -> {remote, FAnn, ArgsT, RetT, rename(Ren, Ct), F, [rename(Ren, E) || E <- Es]}; + {remote_u, FAnn, ArgsT, RetT, Ct, F} -> {remote_u, FAnn, ArgsT, RetT, rename(Ren, Ct), F}; + {con, FAnn, Ar, I, Es} -> {con, FAnn, Ar, I, [rename(Ren, E) || E <- Es]}; + {tuple, FAnn, Es} -> {tuple, FAnn, [rename(Ren, E) || E <- Es]}; + {proj, FAnn, E, I} -> {proj, FAnn, rename(Ren, E), I}; + {set_proj, FAnn, R, I, E} -> {set_proj, FAnn, rename(Ren, R), I, rename(Ren, E)}; + {op, FAnn, Op, Es} -> {op, FAnn, Op, [rename(Ren, E) || E <- Es]}; + {funcall, FAnn, Fun, Es} -> {funcall, FAnn, rename(Ren, Fun), [rename(Ren, E) || E <- Es]}; + {set_state, FAnn, R, E} -> {set_state, FAnn, R, rename(Ren, E)}; + {get_state, _, _} -> Expr; + {closure, FAnn, F, Env} -> {closure, FAnn, F, rename(Ren, Env)}; + {switch, FAnn, Split} -> {switch, FAnn, rename_split(Ren, Split)}; + {lam, FAnn, Xs, B} -> {Zs, Ren1} = rename_bindings(Ren, Xs), - {lam, Zs, rename(Ren1, B)}; - {'let', X, E, Body} -> + {lam, FAnn, Zs, rename(Ren1, B)}; + {'let', FAnn, X, E, Body} -> {Z, Ren1} = rename_binding(Ren, X), - {'let', Z, rename(Ren, E), rename(Ren1, Body)} + {'let', FAnn, Z, rename(Ren, E), rename(Ren1, Body)} end. +-spec rename_var(rename(), var_name()) -> var_name(). rename_var(Ren, X) -> proplists:get_value(X, Ren, X). + +-spec rename_binding(rename(), var_name()) -> {var_name(), rename()}. rename_binding(Ren, X) -> Ren1 = lists:keydelete(X, 1, Ren), case lists:keymember(X, 2, Ren) of @@ -1973,18 +2105,21 @@ rename_binding(Ren, X) -> {Z, [{X, Z} | Ren1]} end. +-spec rename_bindings(rename(), [var_name()]) -> {[var_name()], rename()}. rename_bindings(Ren, []) -> {[], Ren}; rename_bindings(Ren, [X | Xs]) -> {Z, Ren1} = rename_binding(Ren, X), {Zs, Ren2} = rename_bindings(Ren1, Xs), {[Z | Zs], Ren2}. +-spec rename_fpats(rename(), [fpat()]) -> {[fpat()], rename()}. rename_fpats(Ren, []) -> {[], Ren}; rename_fpats(Ren, [P | Ps]) -> {Q, Ren1} = rename_fpat(Ren, P), {Qs, Ren2} = rename_fpats(Ren1, Ps), {[Q | Qs], Ren2}. +-spec rename_fpat(rename(), fpat()) -> {fpat(), rename()}. rename_fpat(Ren, P = {bool, _}) -> {P, Ren}; rename_fpat(Ren, P = {int, _}) -> {P, Ren}; rename_fpat(Ren, P = {string, _}) -> {P, Ren}; @@ -2003,6 +2138,7 @@ rename_fpat(Ren, {tuple, Ps}) -> {Ps1, Ren1} = rename_fpats(Ren, Ps), {{tuple, Ps1}, Ren1}. +-spec rename_spat(rename(), fsplit_pat()) -> {fsplit_pat(), rename()}. rename_spat(Ren, P = {bool, _}) -> {P, Ren}; rename_spat(Ren, P = {int, _}) -> {P, Ren}; rename_spat(Ren, P = {string, _}) -> {P, Ren}; @@ -2025,23 +2161,32 @@ rename_spat(Ren, {assign, X, P}) -> {P1, Ren2} = rename_binding(Ren1, P), {{assign, X1, P1}, Ren2}. +-spec rename_split(rename(), fsplit()) -> fsplit(). 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_split(Ren, {nosplit, Rens, E}) -> + {nosplit, update_rename(Rens, Ren), rename(Ren, E)}. +-spec rename_case(rename(), fcase()) -> fcase(). rename_case(Ren, {'case', Pat, Split}) -> {Pat1, Ren1} = rename_spat(Ren, Pat), {'case', Pat1, rename_split(Ren1, Split)}. +-spec update_rename(rename(), rename()) -> rename(). +update_rename(OldRen, NewRen) -> + [{Name, proplists:get_value(Rename, NewRen, Rename)} || {Name, Rename} <- OldRen]. + %% -- Records -- -field_index({typed, _, _, RecTy}, X) -> - field_index(RecTy, X); +-spec field_index(aeso_syntax:typedef(), aeso_syntax:name()) -> integer(). 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 +-spec field_value(aeso_syntax:field_t(), [aeso_syntax:field(aeso_syntax:pat())]) -> Res when + Res :: {upd, aeso_syntax:name(), Expr} | {set, Expr} | false, + Expr :: aeso_syntax:expr(). field_value({field_t, _, {id, _, X}, _}, Fields) -> View = fun({field, _, [{proj, _, {id, _, Y}}], E}) -> {Y, {set, E}}; ({field_upd, _, [{proj, _, {id, _, Y}}], @@ -2053,43 +2198,58 @@ field_value({field_t, _, {id, _, X}, _}, Fields) -> %% -- Attributes -- +-spec get_attributes(aeso_syntax:ann()) -> [stateful | payable | private]. 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)]. +-spec get_attributes_debug(aeso_syntax:ann()) -> [stateful | payable | private | fann()]. +get_attributes_debug(Ann) -> + get_attributes(Ann) ++ to_fann(Ann). + %% -- Basic utilities -- +-spec indexed([term()]) -> [{integer(), term()}]. indexed(Xs) -> lists:zip(lists:seq(1, length(Xs)), Xs). +-spec setnth(integer(), Val, Vals) -> Vals when + Val :: term(), + Vals :: [Val]. setnth(I, X, Xs) -> {Ys, [_ | Zs]} = lists:split(I - 1, Xs), Ys ++ [X] ++ Zs. -dialyzer({nowarn_function, [fcode_error/1, internal_error/1]}). +-spec fcode_error(string()) -> no_return(). 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)). +-spec internal_error(string()) -> no_return(). 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 -------------------------------------------------------- +-spec format_fcode(fcode()) -> string(). format_fcode(#{ functions := Funs }) -> prettypr:format(format_funs(Funs)). +-spec format_funs(functions()) -> prettypr:document(). format_funs(Funs) -> pp_above( [ pp_fun(Name, Def) || {Name, Def} <- maps:to_list(Funs) ]). +-spec format_fexpr(fexpr()) -> string(). format_fexpr(E) -> prettypr:format(pp_fexpr(E)). +-spec pp_fun(fun_name(), fun_def()) -> prettypr:document(). 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), @@ -2097,85 +2257,101 @@ pp_fun(Name, #{ args := Args, return := Return, body := Body }) -> pp_text(" : "), pp_ftype(Return), pp_text(" =")]), prettypr:nest(2, pp_fexpr(Body))). +-spec pp_fun_name(fun_name()) -> prettypr:document(). 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, ".")). +-spec pp_text(binary() | string() | atom() | integer()) -> prettypr:document(). 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)). +-spec pp_int(integer()) -> prettypr:document(). pp_int(I) -> prettypr:text(integer_to_list(I)). +-spec pp_beside([prettypr:document()]) -> prettypr:document(). pp_beside([]) -> prettypr:empty(); pp_beside([X]) -> X; pp_beside([X | Xs]) -> pp_beside(X, pp_beside(Xs)). +-spec pp_beside(prettypr:document(), prettypr:document()) -> prettypr:document(). pp_beside(A, B) -> prettypr:beside(A, B). +-spec pp_above([prettypr:document()]) -> prettypr:document(). pp_above([]) -> prettypr:empty(); pp_above([X]) -> X; pp_above([X | Xs]) -> pp_above(X, pp_above(Xs)). +-spec pp_above(prettypr:document(), prettypr:document()) -> prettypr:document(). pp_above(A, B) -> prettypr:above(A, B). +-spec pp_parens(prettypr:document()) -> prettypr:document(). pp_parens(Doc) -> pp_beside([pp_text("("), Doc, pp_text(")")]). + +-spec pp_braces(prettypr:document()) -> prettypr:document(). pp_braces(Doc) -> pp_beside([pp_text("{"), Doc, pp_text("}")]). +-spec pp_punctuate(prettypr:document(), [prettypr:document()]) -> [prettypr:document()]. pp_punctuate(_Sep, []) -> []; pp_punctuate(_Sep, [X]) -> [X]; pp_punctuate(Sep, [X | Xs]) -> [pp_beside(X, Sep) | pp_punctuate(Sep, Xs)]. +-spec pp_par([prettypr:document()]) -> prettypr:document(). pp_par([]) -> prettypr:empty(); pp_par(Xs) -> prettypr:par(Xs). -pp_fexpr({lit, {typerep, T}}) -> + +-spec pp_fexpr(fexpr()) -> prettypr:document(). +pp_fexpr({lit, _, {typerep, T}}) -> pp_ftype(T); -pp_fexpr({lit, {Tag, Lit}}) -> +pp_fexpr({lit, _, {contract_code, Contract}}) -> + pp_beside(pp_text("contract "), pp_text(Contract)); +pp_fexpr({lit, _, {Tag, Lit}}) -> aeso_pretty:expr({Tag, [], Lit}); -pp_fexpr(nil) -> +pp_fexpr({nil, _}) -> pp_text("[]"); -pp_fexpr({var, X}) -> pp_text(X); +pp_fexpr({var, _, X}) -> pp_text(X); pp_fexpr({def, Fun}) -> pp_fun_name(Fun); -pp_fexpr({def_u, Fun, Ar}) -> +pp_fexpr({def_u, _, Fun, Ar}) -> pp_beside([pp_fun_name(Fun), pp_text("/"), pp_int(Ar)]); -pp_fexpr({def, Fun, Args}) -> +pp_fexpr({def, _, Fun, Args}) -> pp_call(pp_fun_name(Fun), Args); -pp_fexpr({con, _, I, []}) -> +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_fexpr({con, FAnn, _, I, Es}) -> + pp_beside(pp_fexpr({con, FAnn, [], I, []}), + pp_fexpr({tuple, FAnn, Es})); +pp_fexpr({tuple, _, Es}) -> pp_parens(pp_par(pp_punctuate(pp_text(","), [pp_fexpr(E) || E <- Es]))); -pp_fexpr({proj, E, I}) -> +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("=>"), +pp_fexpr({lam, FAnn, Xs, A}) -> + pp_par([pp_fexpr({tuple, FAnn, [{var, FAnn, X} || X <- Xs]}), pp_text("=>"), prettypr:nest(2, pp_fexpr(A))]); -pp_fexpr({closure, Fun, ClEnv}) -> +pp_fexpr({closure, _, Fun, ClEnv}) -> FVs = case ClEnv of - {tuple, Xs} -> Xs; - {var, _} -> [ClEnv] + {tuple, _, Xs} -> Xs; + {var, _, _} -> [ClEnv] end, pp_call(pp_text("__CLOSURE__"), [{def, Fun} | FVs]); -pp_fexpr({set_proj, E, I, A}) -> +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}) -> +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}) -> +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}) -> +pp_fexpr({op, FAnn, Op, As}) -> + pp_beside(pp_text(Op), pp_fexpr({tuple, FAnn, As})); +pp_fexpr({'let', _, _, _, _} = Expr) -> + Lets = fun Lets({'let', _, Y, C, D}) -> {Ls, E} = Lets(D), {[{Y, C} | Ls], E}; Lets(E) -> {[], E} end, @@ -2186,29 +2362,29 @@ pp_fexpr({'let', _, _, _} = Expr) -> pp_above([ pp_par([pp_text(X), pp_text("="), prettypr:nest(2, pp_fexpr(A))]) || {X, A} <- Ls ]), pp_text(" in ") ]), pp_fexpr(Body) ])); -pp_fexpr({builtin_u, B, N}) -> +pp_fexpr({builtin_u, _, B, N}) -> pp_beside([pp_text(B), pp_text("/"), pp_text(N)]); -pp_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_fexpr({builtin_u, FAnn, B, N, TypeArgs}) -> + pp_beside([pp_text(B), pp_text("@"), pp_fexpr({tuple, FAnn, 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_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_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_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_fexpr({set_state, FAnn, R, A}) -> + pp_call(pp_text("set_state"), [{lit, FAnn, {int, R}}, A]); +pp_fexpr({get_state, FAnn, R}) -> + pp_call(pp_text("get_state"), [{lit, FAnn, {int, R}}]); +pp_fexpr({switch, _, Split}) -> pp_split(Split). +-spec pp_call(prettypr:document(), [fexpr()]) -> prettypr:document(). pp_call(Fun, Args) -> - pp_beside(Fun, pp_fexpr({tuple, Args})). + pp_beside(Fun, pp_fexpr({tuple, [], Args})). +-spec pp_call_t(string(), [ftype()]) -> prettypr:document(). pp_call_t(Fun, Args) -> pp_beside(pp_text(Fun), pp_ftype({tuple, Args})). @@ -2216,7 +2392,7 @@ pp_call_t(Fun, Args) -> 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({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]))); @@ -2230,27 +2406,36 @@ 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_fexpr({con, [], [], I - 1, []}); + _ -> pp_beside(pp_fexpr({con, [], [], I - 1, []}), pp_ftype({tuple, Args})) + end || {I, Args} <- indexed(Cons)])); +pp_ftype([]) -> + %% NOTE: This could happen with `{typerep, []}` since `[]` is not a ftype(). + %% TODO: It would be better to make sure that `{typerep, []}` does not arrive here. + pp_text("[]"). -pp_split({nosplit, E}) -> pp_fexpr(E); +-spec pp_split(fsplit()) -> prettypr:document(). +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]). +-spec pp_case(fcase()) -> prettypr:document(). 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}); +-spec pp_pat(fsplit_pat()) -> prettypr:document(). +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). + -> pp_fexpr({lit, [], P}); +pp_pat(nil) -> pp_fexpr({nil, []}); +pp_pat({assign, X, Y}) -> pp_beside([pp_text(X), pp_text(" = "), pp_text(Y)]). +-spec is_infix(op()) -> boolean(). is_infix(Op) -> C = hd(atom_to_list(Op)), C < $a orelse C > $z. diff --git a/src/aeso_compiler.erl b/src/aeso_compiler.erl index 7a0d069..1ff6ec3 100644 --- a/src/aeso_compiler.erl +++ b/src/aeso_compiler.erl @@ -119,7 +119,7 @@ from_string1(ContractString, Options) -> , warnings := Warnings } = string_to_code(ContractString, Options), #{ child_con_env := ChildContracts } = FCodeEnv, SavedFreshNames = maps:get(saved_fresh_names, FCodeEnv, #{}), - {FateCode, VarsRegs} = aeso_fcode_to_fate:compile(ChildContracts, FCode, SavedFreshNames, Options), + FateCode = aeso_fcode_to_fate:compile(ChildContracts, FCode, SavedFreshNames, Options), pp_assembler(FateCode, Options), ByteCode = aeb_fate_code:serialize(FateCode, []), {ok, Version} = version(), @@ -132,13 +132,7 @@ from_string1(ContractString, Options) -> payable => maps:get(payable, FCode), warnings => Warnings }, - ResDbg = Res#{variables_registers => VarsRegs}, - FinalRes = - case proplists:get_value(debug_info, Options, false) of - true -> ResDbg; - false -> Res - end, - {ok, maybe_generate_aci(FinalRes, FoldedTypedAst, Options)}. + {ok, maybe_generate_aci(Res, FoldedTypedAst, Options)}. maybe_generate_aci(Result, FoldedTypedAst, Options) -> case proplists:get_value(aci, Options) of @@ -192,7 +186,7 @@ check_call(Source, FunName, Args, Options) -> check_call1(ContractString0, FunName, Args, Options) -> case add_extra_call(ContractString0, {call, FunName, Args}, Options) of {ok, CallName, Code} -> - {def, _, FcodeArgs} = get_call_body(CallName, Code), + {def, _, _, FcodeArgs} = get_call_body(CallName, Code), {ok, FunName, [ aeso_fcode_to_fate:term_to_fate(A) || A <- FcodeArgs ]}; Err = {error, _} -> Err @@ -204,7 +198,7 @@ add_extra_call(Contract0, Call, Options) -> #{fcode := OrgFcode , fcode_env := #{child_con_env := ChildContracts} , ast := Ast} = string_to_code(Contract0, Options), - {FateCode, _} = aeso_fcode_to_fate:compile(ChildContracts, OrgFcode, #{}, []), + FateCode = aeso_fcode_to_fate:compile(ChildContracts, OrgFcode, #{}, []), %% collect all hashes and compute the first name without hash collision to SymbolHashes = maps:keys(aeb_fate_code:symbols(FateCode)), CallName = first_none_match(?CALL_NAME, SymbolHashes, diff --git a/src/aeso_fcode_to_fate.erl b/src/aeso_fcode_to_fate.erl index ebc4ebf..5c99d70 100644 --- a/src/aeso_fcode_to_fate.erl +++ b/src/aeso_fcode_to_fate.erl @@ -52,7 +52,8 @@ tailpos = true, child_contracts = #{}, saved_fresh_names = #{}, - options = [] }). + options = [], + debug_info = false }). %% -- Debugging -------------------------------------------------------------- @@ -81,24 +82,16 @@ code_error(Err) -> compile(FCode, SavedFreshNames, Options) -> compile(#{}, FCode, SavedFreshNames, Options). compile(ChildContracts, FCode, SavedFreshNames, Options) -> - try - compile1(ChildContracts, FCode, SavedFreshNames, Options) - after - put(variables_registers, undefined) - end. - -compile1(ChildContracts, FCode, SavedFreshNames, Options) -> #{ contract_name := ContractName, functions := Functions } = FCode, SFuns = functions_to_scode(ChildContracts, ContractName, Functions, SavedFreshNames, Options), SFuns1 = optimize_scode(SFuns, Options), FateCode = to_basic_blocks(SFuns1), ?debug(compile, Options, "~s\n", [aeb_fate_asm:pp(FateCode)]), - FateCode1 = case proplists:get_value(include_child_contract_symbols, Options, false) of - false -> FateCode; - true -> add_child_symbols(ChildContracts, FateCode) - end, - {FateCode1, get_variables_registers()}. + case proplists:get_value(include_child_contract_symbols, Options, false) of + false -> FateCode; + true -> add_child_symbols(ChildContracts, FateCode) + end. make_function_id(X) -> aeb_fate_code:symbol_identifier(make_function_name(X)). @@ -123,31 +116,15 @@ functions_to_scode(ChildContracts, ContractName, Functions, SavedFreshNames, Opt function_to_scode(ChildContracts, ContractName, Functions, Name, Attrs0, Args, Body, ResType, SavedFreshNames, Options) -> {ArgTypes, ResType1} = typesig_to_scode(Args, ResType), - Attrs = Attrs0 -- [stateful], %% Only track private and payable from here. + Attrs = [ A || A <- Attrs0, A == private orelse A == payable ], Env = init_env(ChildContracts, ContractName, Functions, Name, Args, SavedFreshNames, Options), - [ add_variables_register(Env, Arg, Register) || - proplists:get_value(debug_info, Options, false), - {Arg, Register} <- Env#env.vars ], + ArgsNames = [ X || {X, _} <- lists:reverse(Env#env.vars) ], + + %% DBG_LOC is added before the function body to make it possible to break + %% at the function signature SCode = to_scode(Env, Body), - {Attrs, {ArgTypes, ResType1}, SCode}. - -get_variables_registers() -> - case get(variables_registers) of - undefined -> #{}; - Vs -> Vs - end. - -add_variables_register(Env = #env{saved_fresh_names = SavedFreshNames}, Name, Register) -> - Olds = get_variables_registers(), - RealName = maps:get(Name, SavedFreshNames, Name), - FunName = - case Env#env.current_function of - event -> "Chain.event"; - {entrypoint, BinName} -> binary_to_list(BinName); - {local_fun, QualName} -> lists:last(QualName) - end, - New = {Env#env.contract, FunName, RealName}, - put(variables_registers, Olds#{New => Register}). + DbgSCode = dbg_contract(Env) ++ dbg_loc(Env, Attrs0) ++ dbg_scoped_vars(Env, ArgsNames, SCode), + {Attrs, {ArgTypes, ResType1}, DbgSCode}. -define(tvars, '$tvars'). @@ -194,20 +171,20 @@ types_to_scode(Ts) -> lists:map(fun type_to_scode/1, Ts). %% -- Environment functions -- init_env(ChildContracts, ContractName, FunNames, Name, Args, SavedFreshNames, Options) -> - #env{ vars = [ {X, {arg, I}} || {I, {X, _}} <- with_ixs(Args) ], - contract = ContractName, - child_contracts = ChildContracts, - locals = FunNames, - current_function = Name, - options = Options, - tailpos = true, - saved_fresh_names = SavedFreshNames }. + #env{ vars = [ {X, {arg, I}} || {I, {X, _}} <- with_ixs(Args) ], + contract = ContractName, + child_contracts = ChildContracts, + locals = FunNames, + current_function = Name, + options = Options, + tailpos = true, + saved_fresh_names = SavedFreshNames, + debug_info = proplists:get_value(debug_info, Options, false) }. next_var(#env{ vars = Vars }) -> 1 + lists:max([-1 | [J || {_, {var, J}} <- Vars]]). bind_var(Name, Var, Env = #env{ vars = Vars }) -> - proplists:get_value(debug_info, Env#env.options, false) andalso add_variables_register(Env, Name, Var), Env#env{ vars = [{Name, Var} | Vars] }. bind_local(Name, Env) -> @@ -234,7 +211,7 @@ serialize_contract_code(Env, C) -> Options = Env#env.options, SavedFreshNames = Env#env.saved_fresh_names, FCode = maps:get(C, Env#env.child_contracts), - {FateCode, _} = compile1(Env#env.child_contracts, FCode, SavedFreshNames, Options), + FateCode = compile(Env#env.child_contracts, FCode, SavedFreshNames, Options), ByteCode = aeb_fate_code:serialize(FateCode, []), {ok, Version} = aeso_compiler:version(), OriginalSourceCode = proplists:get_value(original_src, Options, ""), @@ -268,44 +245,44 @@ lit_to_fate(Env, L) -> term_to_fate(E) -> term_to_fate(#env{}, #{}, E). term_to_fate(GlobEnv, E) -> term_to_fate(GlobEnv, #{}, E). -term_to_fate(GlobEnv, _Env, {lit, L}) -> +term_to_fate(GlobEnv, _Env, {lit, _, L}) -> lit_to_fate(GlobEnv, L); %% negative literals are parsed as 0 - N -term_to_fate(_GlobEnv, _Env, {op, '-', [{lit, {int, 0}}, {lit, {int, N}}]}) -> +term_to_fate(_GlobEnv, _Env, {op, _, '-', [{lit, _, {int, 0}}, {lit, _, {int, N}}]}) -> aeb_fate_data:make_integer(-N); -term_to_fate(_GlobEnv, _Env, nil) -> +term_to_fate(_GlobEnv, _Env, {nil, _}) -> aeb_fate_data:make_list([]); -term_to_fate(GlobEnv, Env, {op, '::', [Hd, Tl]}) -> +term_to_fate(GlobEnv, Env, {op, _, '::', [Hd, Tl]}) -> %% The Tl will translate into a list, because FATE lists are just lists [term_to_fate(GlobEnv, Env, Hd) | term_to_fate(GlobEnv, Env, Tl)]; -term_to_fate(GlobEnv, Env, {tuple, As}) -> +term_to_fate(GlobEnv, Env, {tuple, _, As}) -> aeb_fate_data:make_tuple(list_to_tuple([ term_to_fate(GlobEnv, Env, A) || A<-As])); -term_to_fate(GlobEnv, Env, {con, Ar, I, As}) -> +term_to_fate(GlobEnv, Env, {con, _, Ar, I, As}) -> FateAs = [ term_to_fate(GlobEnv, Env, A) || A <- As ], aeb_fate_data:make_variant(Ar, I, list_to_tuple(FateAs)); -term_to_fate(_GlobEnv, _Env, {builtin, bits_all, []}) -> +term_to_fate(_GlobEnv, _Env, {builtin, _, bits_all, []}) -> aeb_fate_data:make_bits(-1); -term_to_fate(_GlobEnv, _Env, {builtin, bits_none, []}) -> +term_to_fate(_GlobEnv, _Env, {builtin, _, bits_none, []}) -> aeb_fate_data:make_bits(0); -term_to_fate(GlobEnv, _Env, {op, bits_set, [B, I]}) -> +term_to_fate(GlobEnv, _Env, {op, _, bits_set, [B, I]}) -> {bits, N} = term_to_fate(GlobEnv, B), J = term_to_fate(GlobEnv, I), {bits, N bor (1 bsl J)}; -term_to_fate(GlobEnv, _Env, {op, bits_clear, [B, I]}) -> +term_to_fate(GlobEnv, _Env, {op, _, bits_clear, [B, I]}) -> {bits, N} = term_to_fate(GlobEnv, B), J = term_to_fate(GlobEnv, I), {bits, N band bnot (1 bsl J)}; -term_to_fate(GlobEnv, Env, {'let', X, E, Body}) -> +term_to_fate(GlobEnv, Env, {'let', _, X, E, Body}) -> Env1 = Env#{ X => term_to_fate(GlobEnv, Env, E) }, term_to_fate(GlobEnv, Env1, Body); -term_to_fate(_GlobEnv, Env, {var, X}) -> +term_to_fate(_GlobEnv, Env, {var, _, X}) -> case maps:get(X, Env, undefined) of undefined -> throw(not_a_fate_value); V -> V end; -term_to_fate(_GlobEnv, _Env, {builtin, map_empty, []}) -> +term_to_fate(_GlobEnv, _Env, {builtin, _, map_empty, []}) -> aeb_fate_data:make_map(#{}); -term_to_fate(GlobEnv, Env, {op, map_set, [M, K, V]}) -> +term_to_fate(GlobEnv, Env, {op, _, map_set, [M, K, V]}) -> Map = term_to_fate(GlobEnv, Env, M), Map#{term_to_fate(GlobEnv, Env, K) => term_to_fate(GlobEnv, Env, V)}; term_to_fate(_GlobEnv, _Env, _) -> @@ -313,52 +290,59 @@ term_to_fate(_GlobEnv, _Env, _) -> to_scode(Env, T) -> try term_to_fate(Env, T) of - V -> [push(?i(V))] + V -> + FAnn = element(2, T), + [dbg_loc(Env, FAnn), push(?i(V))] catch throw:not_a_fate_value -> to_scode1(Env, T) end. -to_scode1(Env, {lit, L}) -> - [push(?i(lit_to_fate(Env, L)))]; +to_scode1(Env, {lit, Ann, L}) -> + [ dbg_loc(Env, Ann), push(?i(lit_to_fate(Env, L))) ]; -to_scode1(_Env, nil) -> - [aeb_fate_ops:nil(?a)]; +to_scode1(Env, {nil, Ann}) -> + [ dbg_loc(Env, Ann), aeb_fate_ops:nil(?a) ]; -to_scode1(Env, {var, X}) -> - [push(lookup_var(Env, X))]; +to_scode1(Env, {var, Ann, X}) -> + [ dbg_loc(Env, Ann), push(lookup_var(Env, X)) ]; -to_scode1(Env, {con, Ar, I, As}) -> +to_scode1(Env, {con, Ann, Ar, I, As}) -> N = length(As), - [[to_scode(notail(Env), A) || A <- As], - aeb_fate_ops:variant(?a, ?i(Ar), ?i(I), ?i(N))]; + [ dbg_loc(Env, Ann), + [to_scode(notail(Env), A) || A <- As], + aeb_fate_ops:variant(?a, ?i(Ar), ?i(I), ?i(N)) ]; -to_scode1(Env, {tuple, As}) -> +to_scode1(Env, {tuple, Ann, As}) -> N = length(As), - [[ to_scode(notail(Env), A) || A <- As ], - tuple(N)]; + [ dbg_loc(Env, Ann), + [ to_scode(notail(Env), A) || A <- As ], + tuple(N) ]; -to_scode1(Env, {proj, E, I}) -> - [to_scode(notail(Env), E), - aeb_fate_ops:element_op(?a, ?i(I), ?a)]; +to_scode1(Env, {proj, Ann, E, I}) -> + [ dbg_loc(Env, Ann), + to_scode(notail(Env), E), + aeb_fate_ops:element_op(?a, ?i(I), ?a) ]; -to_scode1(Env, {set_proj, R, I, E}) -> - [to_scode(notail(Env), E), - to_scode(notail(Env), R), - aeb_fate_ops:setelement(?a, ?i(I), ?a, ?a)]; +to_scode1(Env, {set_proj, Ann, R, I, E}) -> + [ dbg_loc(Env, Ann), + to_scode(notail(Env), E), + to_scode(notail(Env), R), + aeb_fate_ops:setelement(?a, ?i(I), ?a, ?a) ]; -to_scode1(Env, {op, Op, Args}) -> - call_to_scode(Env, op_to_scode(Op), Args); +to_scode1(Env, {op, Ann, Op, Args}) -> + [ dbg_loc(Env, Ann) | call_to_scode(Env, op_to_scode(Op), Args) ]; -to_scode1(Env, {'let', X, {var, Y}, Body}) -> +to_scode1(Env, {'let', Ann, X, {var, _, Y}, Body}) -> Env1 = bind_var(X, lookup_var(Env, Y), Env), - to_scode(Env1, Body); -to_scode1(Env, {'let', X, Expr, Body}) -> + [ dbg_loc(Env, Ann) | dbg_scoped_vars(Env1, [X], to_scode(Env1, Body)) ]; +to_scode1(Env, {'let', Ann, X, Expr, Body}) -> {I, Env1} = bind_local(X, Env), - [ to_scode(notail(Env), Expr), - aeb_fate_ops:store({var, I}, {stack, 0}), - to_scode(Env1, Body) ]; + SCode = [ to_scode(notail(Env), Expr), + aeb_fate_ops:store({var, I}, {stack, 0}), + to_scode(Env1, Body) ], + [ dbg_loc(Env, Ann) | dbg_scoped_vars(Env1, [X], SCode) ]; -to_scode1(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args}) -> +to_scode1(Env = #env{ current_function = Fun, tailpos = true, debug_info = false }, {def, Ann, Fun, Args}) -> %% Tail-call to current function, f(e0..en). Compile to %% [ let xi = ei ] %% [ STORE argi xi ] @@ -371,61 +355,62 @@ to_scode1(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args} aeb_fate_ops:store({var, I}, ?a)], {[I | Is], Acc1, Env2} end, {[], [], Env}, Args), - [ Code, + [ dbg_loc(Env, Ann), + Code, [ aeb_fate_ops:store({arg, I}, {var, J}) || {I, J} <- lists:zip(lists:seq(0, length(Vars) - 1), lists:reverse(Vars)) ], loop ]; -to_scode1(Env, {def, Fun, Args}) -> +to_scode1(Env, {def, Ann, Fun, Args}) -> FName = make_function_id(Fun), Lbl = aeb_fate_data:make_string(FName), - call_to_scode(Env, local_call(Env, ?i(Lbl)), Args); -to_scode1(Env, {funcall, Fun, Args}) -> - call_to_scode(Env, [to_scode(Env, Fun), local_call(Env, ?a)], Args); + [ dbg_loc(Env, Ann) | call_to_scode(Env, local_call(Env, ?i(Lbl)), Args) ]; +to_scode1(Env, {funcall, Ann, Fun, Args}) -> + [ dbg_loc(Env, Ann) | call_to_scode(Env, [to_scode(Env, Fun), local_call(Env, ?a)], Args) ]; -to_scode1(Env, {builtin, B, Args}) -> - builtin_to_scode(Env, B, Args); +to_scode1(Env, {builtin, Ann, B, Args}) -> + [ dbg_loc(Env, Ann) | builtin_to_scode(Env, B, Args) ]; -to_scode1(Env, {remote, ArgsT, RetT, Ct, Fun, [Gas, Value, Protected | Args]}) -> +to_scode1(Env, {remote, Ann, ArgsT, RetT, Ct, Fun, [Gas, Value, Protected | Args]}) -> Lbl = make_function_id(Fun), {ArgTypes, RetType0} = typesig_to_scode([{"_", T} || T <- ArgsT], RetT), ArgType = ?i(aeb_fate_data:make_typerep({tuple, ArgTypes})), RetType = ?i(aeb_fate_data:make_typerep(RetType0)), - case Protected of - {lit, {bool, false}} -> + SCode = case Protected of + {lit, _, {bool, false}} -> case Gas of - {builtin, call_gas_left, _} -> + {builtin, _, call_gas_left, _} -> Call = aeb_fate_ops:call_r(?a, Lbl, ArgType, RetType, ?a), call_to_scode(Env, Call, [Ct, Value | Args]); _ -> Call = aeb_fate_ops:call_gr(?a, Lbl, ArgType, RetType, ?a, ?a), call_to_scode(Env, Call, [Ct, Value, Gas | Args]) end; - {lit, {bool, true}} -> + {lit, _, {bool, true}} -> Call = aeb_fate_ops:call_pgr(?a, Lbl, ArgType, RetType, ?a, ?a, ?i(true)), call_to_scode(Env, Call, [Ct, Value, Gas | Args]); _ -> Call = aeb_fate_ops:call_pgr(?a, Lbl, ArgType, RetType, ?a, ?a, ?a), call_to_scode(Env, Call, [Ct, Value, Gas, Protected | Args]) - end; + end, + [ dbg_loc(Env, Ann) | SCode ]; -to_scode1(_Env, {get_state, Reg}) -> - [push(?s(Reg))]; -to_scode1(Env, {set_state, Reg, Val}) -> - call_to_scode(Env, [{'STORE', ?s(Reg), ?a}, - tuple(0)], [Val]); +to_scode1(Env, {get_state, Ann, Reg}) -> + [ dbg_loc(Env, Ann), push(?s(Reg)) ]; +to_scode1(Env, {set_state, Ann, Reg, Val}) -> + [ dbg_loc(Env, Ann) | call_to_scode(Env, [{'STORE', ?s(Reg), ?a}, tuple(0)], [Val]) ]; -to_scode1(Env, {closure, Fun, FVs}) -> - to_scode(Env, {tuple, [{lit, {string, make_function_id(Fun)}}, FVs]}); +to_scode1(Env, {closure, Ann, Fun, FVs}) -> + [ to_scode(Env, {tuple, Ann, [{lit, Ann, {string, make_function_id(Fun)}}, FVs]}) ]; -to_scode1(Env, {switch, Case}) -> - split_to_scode(Env, Case). +to_scode1(Env, {switch, Ann, Case}) -> + [ dbg_loc(Env, Ann) | split_to_scode(Env, Case) ]. -local_call( Env, Fun) when Env#env.tailpos -> aeb_fate_ops:call_t(Fun); -local_call(_Env, Fun) -> aeb_fate_ops:call(Fun). +local_call( Env = #env{debug_info = false}, Fun) when Env#env.tailpos -> aeb_fate_ops:call_t(Fun); +local_call(_Env, Fun) -> aeb_fate_ops:call(Fun). -split_to_scode(Env, {nosplit, Expr}) -> - [switch_body, to_scode(Env, Expr)]; +split_to_scode(Env, {nosplit, Renames, Expr}) -> + [switch_body, dbg_scoped_vars(Env, Renames, to_scode(Env, Expr))]; split_to_scode(Env, {split, {tuple, _}, X, Alts}) -> {Def, Alts1} = catchall_to_scode(Env, X, Alts), Arg = lookup_var(Env, X), @@ -649,7 +634,7 @@ builtin_to_scode(Env, chain_bytecode_hash, [_Addr] = Args) -> builtin_to_scode(Env, chain_clone, [InitArgsT, GasCap, Value, Prot, Contract | InitArgs]) -> case GasCap of - {builtin, call_gas_left, _} -> + {builtin, _, call_gas_left, _} -> call_to_scode(Env, aeb_fate_ops:clone(?a, ?a, ?a, ?a), [Contract, InitArgsT, Value, Prot | InitArgs] ); @@ -751,6 +736,77 @@ push(A) -> {'STORE', ?a, A}. tuple(0) -> push(?i({tuple, {}})); tuple(N) -> aeb_fate_ops:tuple(?a, N). +%% -- Debug info functions -- + +dbg_contract(#env{debug_info = false}) -> + []; +dbg_contract(#env{contract = Contract}) -> + [{'DBG_CONTRACT', {immediate, Contract}}]. + +dbg_loc(#env{debug_info = false}, _) -> + []; +dbg_loc(_Env, Ann) -> + File = case proplists:get_value(file, Ann, no_file) of + no_file -> ""; + F -> F + end, + Line = proplists:get_value(line, Ann, undefined), + case Line of + undefined -> []; + _ -> [{'DBG_LOC', {immediate, File}, {immediate, Line}}] + end. + +dbg_scoped_vars(#env{debug_info = false}, _, SCode) -> + SCode; +dbg_scoped_vars(_Env, [], SCode) -> + SCode; +dbg_scoped_vars(Env, [{SavedVarName, Var} | Rest], SCode) -> + dbg_scoped_vars(Env, Rest, dbg_scoped_var(Env, SavedVarName, Var, SCode)); +dbg_scoped_vars(Env = #env{saved_fresh_names = SavedFreshNames}, [Var | Rest], SCode) -> + SavedVarName = maps:get(Var, SavedFreshNames, Var), + dbg_scoped_vars(Env, Rest, dbg_scoped_var(Env, SavedVarName, Var, SCode)). + +dbg_scoped_var(Env, SavedVarName, Var, SCode) -> + case SavedVarName == "_" orelse is_fresh_name(SavedVarName) of + true -> + SCode; + false -> + Register = lookup_var(Env, Var), + Def = [{'DBG_DEF', {immediate, SavedVarName}, Register}], + Undef = [{'DBG_UNDEF', {immediate, SavedVarName}, Register}], + Def ++ dbg_undef(Undef, SCode) + end. + +is_fresh_name([$% | _]) -> + true; +is_fresh_name(_) -> + false. + +dbg_undef(_Undef, missing) -> + missing; +dbg_undef(Undef, loop) -> + [Undef, loop]; +dbg_undef(Undef, switch_body) -> + [switch_body, Undef]; +dbg_undef(Undef, {switch, Arg, Type, Alts, Catch}) -> + NewAlts = [ dbg_undef(Undef, Alt) || Alt <- Alts ], + NewCatch = dbg_undef(Undef, Catch), + NewSwitch = {switch, Arg, Type, NewAlts, NewCatch}, + NewSwitch; +dbg_undef(Undef, SCode) when is_list(SCode) -> + lists:droplast(SCode) ++ [dbg_undef(Undef, lists:last(SCode))]; +dbg_undef(Undef, SCode) when is_tuple(SCode); is_atom(SCode) -> + [Mnemonic | _] = + case is_tuple(SCode) of + true -> tuple_to_list(SCode); + false -> [SCode] + end, + Op = aeb_fate_opcodes:m_to_op(Mnemonic), + case aeb_fate_opcodes:end_bb(Op) of + true -> [Undef, SCode]; + false -> [SCode, Undef] + end. + %% -- Phase II --------------------------------------------------------------- %% Optimize @@ -886,6 +942,10 @@ attributes(I) -> loop -> Impure(pc, []); switch_body -> Pure(none, []); 'RETURN' -> Impure(pc, []); + {'DBG_LOC', _, _} -> Impure(none, []); + {'DBG_DEF', _, _} -> Impure(none, []); + {'DBG_UNDEF', _, _} -> Impure(none, []); + {'DBG_CONTRACT', _} -> Impure(none, []); {'RETURNR', A} -> Impure(pc, A); {'CALL', A} -> Impure(?a, [A]); {'CALL_R', A, _, B, C, D} -> Impure(?a, [A, B, C, D]); @@ -1605,7 +1665,23 @@ bb(_Name, Code) -> Blocks = lists:flatmap(fun split_calls/1, Blocks1), Labels = maps:from_list([ {Ref, I} || {I, {Ref, _}} <- with_ixs(Blocks) ]), BBs = [ set_labels(Labels, B) || B <- Blocks ], - maps:from_list(BBs). + maps:from_list(dbg_loc_filter(BBs)). + +%% Filter DBG_LOC instructions to keep one instruction per line +dbg_loc_filter(BBs) -> + dbg_loc_filter(BBs, [], [], sets:new()). + +dbg_loc_filter([], _, AllBlocks, _) -> + lists:reverse(AllBlocks); +dbg_loc_filter([{I, []} | Rest], AllOps, AllBlocks, DbgLocs) -> + dbg_loc_filter(Rest, [], [{I, lists:reverse(AllOps)} | AllBlocks], DbgLocs); +dbg_loc_filter([{I, [Op = {'DBG_LOC', _, _} | Ops]} | Rest], AllOps, AllBlocks, DbgLocs) -> + case sets:is_element(Op, DbgLocs) of + true -> dbg_loc_filter([{I, Ops} | Rest], AllOps, AllBlocks, DbgLocs); + false -> dbg_loc_filter([{I, Ops} | Rest], [Op | AllOps], AllBlocks, sets:add_element(Op, DbgLocs)) + end; +dbg_loc_filter([{I, [Op | Ops]} | Rest], AllOps, AllBlocks, DbgLocs) -> + dbg_loc_filter([{I, Ops} | Rest], [Op | AllOps], AllBlocks, DbgLocs). %% -- Break up scode into basic blocks -- diff --git a/src/aeso_syntax.erl b/src/aeso_syntax.erl index f1c7f99..0ff9f5e 100644 --- a/src/aeso_syntax.erl +++ b/src/aeso_syntax.erl @@ -10,7 +10,7 @@ -export([get_ann/1, get_ann/2, get_ann/3, set_ann/2, qualify/2]). --export_type([ann_line/0, ann_col/0, ann_origin/0, ann_format/0, ann/0]). +-export_type([ann_file/0, ann_line/0, ann_col/0, ann_origin/0, ann_format/0, ann/0]). -export_type([name/0, id/0, con/0, qid/0, qcon/0, tvar/0, op/0]). -export_type([bin_op/0, un_op/0]). -export_type([decl/0, letbind/0, typedef/0, pragma/0, fundecl/0]). @@ -24,8 +24,9 @@ -type ann_col() :: integer(). -type ann_origin() :: system | user. -type ann_format() :: '?:' | hex | infix | prefix | elif. +-type ann_file() :: string() | no_file. --type ann() :: [ {line, ann_line()} | {col, ann_col()} | {format, ann_format()} | {origin, ann_origin()} +-type ann() :: [ {file, ann_file()} | {line, ann_line()} | {col, ann_col()} | {format, ann_format()} | {origin, ann_origin()} | stateful | private | payable | main | interface | entrypoint]. -type name() :: string().