diff --git a/CHANGELOG.md b/CHANGELOG.md index 1ecefdc..d1e2c3f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added ### Changed +- FATE code generator improvements. ### Removed ## [4.1.0] - 2019-11-26 diff --git a/src/aeso_ast_infer_types.erl b/src/aeso_ast_infer_types.erl index d290f25..af95e4e 100644 --- a/src/aeso_ast_infer_types.erl +++ b/src/aeso_ast_infer_types.erl @@ -1189,21 +1189,20 @@ infer_expr(Env, {list, As, Elems}) -> NewElems = [check_expr(Env, X, ElemType) || X <- Elems], {typed, As, {list, As, NewElems}, {app_t, As, {id, As, "list"}, [ElemType]}}; infer_expr(Env, {list_comp, As, Yield, []}) -> - {typed, _, TypedYield, Type} = infer_expr(Env, Yield), + {typed, _, _, Type} = TypedYield = infer_expr(Env, Yield), {typed, As, {list_comp, As, TypedYield, []}, {app_t, As, {id, As, "list"}, [Type]}}; -infer_expr(Env, {list_comp, As, Yield, [{comprehension_bind, Arg, BExpr}|Rest]}) -> - BindVarType = fresh_uvar(As), +infer_expr(Env, {list_comp, As, Yield, [{comprehension_bind, Pat, BExpr}|Rest]}) -> TypedBind = {typed, As2, _, TypeBExpr} = infer_expr(Env, BExpr), + {NewE, TypedPat = {typed, _, _, PatType}} = infer_pattern(Env, Pat), unify( Env , TypeBExpr - , {app_t, As, {id, As, "list"}, [BindVarType]} - , {list_comp, TypedBind, TypeBExpr, {app_t, As2, {id, As, "list"}, [BindVarType]}}), - NewE = bind_var(Arg, BindVarType, Env), + , {app_t, As, {id, As, "list"}, [PatType]} + , {list_comp, TypedBind, TypeBExpr, {app_t, As2, {id, As, "list"}, [PatType]}}), {typed, _, {list_comp, _, TypedYield, TypedRest}, ResType} = infer_expr(NewE, {list_comp, As, Yield, Rest}), { typed , As - , {list_comp, As, TypedYield, [{comprehension_bind, {typed, Arg, BindVarType}, TypedBind}|TypedRest]} + , {list_comp, As, TypedYield, [{comprehension_bind, TypedPat, TypedBind}|TypedRest]} , ResType}; infer_expr(Env, {list_comp, AttrsL, Yield, [{comprehension_if, AttrsIF, Cond}|Rest]}) -> NewCond = check_expr(Env, Cond, {id, AttrsIF, "bool"}), @@ -1213,8 +1212,8 @@ infer_expr(Env, {list_comp, AttrsL, Yield, [{comprehension_if, AttrsIF, Cond}|Re , AttrsL , {list_comp, AttrsL, TypedYield, [{comprehension_if, AttrsIF, NewCond}|TypedRest]} , ResType}; -infer_expr(Env, {list_comp, AsLC, Yield, [{letval, AsLV, Pattern, Type, E}|Rest]}) -> - NewE = {typed, _, _, PatType} = infer_expr(Env, {typed, AsLV, E, arg_type(AsLV, Type)}), +infer_expr(Env, {list_comp, AsLC, Yield, [{letval, AsLV, Pattern, E}|Rest]}) -> + NewE = {typed, _, _, PatType} = infer_expr(Env, E), BlockType = fresh_uvar(AsLV), {'case', _, NewPattern, NewRest} = infer_case( Env @@ -1226,7 +1225,7 @@ infer_expr(Env, {list_comp, AsLC, Yield, [{letval, AsLV, Pattern, Type, E}|Rest] {typed, _, {list_comp, _, TypedYield, TypedRest}, ResType} = NewRest, { typed , AsLC - , {list_comp, AsLC, TypedYield, [{letval, AsLV, NewPattern, Type, NewE}|TypedRest]} + , {list_comp, AsLC, TypedYield, [{letval, AsLV, NewPattern, NewE}|TypedRest]} , ResType }; infer_expr(Env, {list_comp, AsLC, Yield, [Def={letfun, AsLF, _, _, _, _}|Rest]}) -> @@ -1341,6 +1340,16 @@ infer_expr(Env, {block, Attrs, Stmts}) -> BlockType = fresh_uvar(Attrs), NewStmts = infer_block(Env, Attrs, Stmts, BlockType), {typed, Attrs, {block, Attrs, NewStmts}, BlockType}; +infer_expr(_Env, {record_or_map_error, Attrs, Fields}) -> + type_error({mixed_record_and_map, {record, Attrs, Fields}}), + Type = fresh_uvar(Attrs), + {typed, Attrs, {record, Attrs, []}, Type}; +infer_expr(Env, {record_or_map_error, Attrs, Expr, []}) -> + type_error({empty_record_or_map_update, {record, Attrs, Expr, []}}), + infer_expr(Env, Expr); +infer_expr(Env, {record_or_map_error, Attrs, Expr, Fields}) -> + type_error({mixed_record_and_map, {record, Attrs, Expr, Fields}}), + infer_expr(Env, Expr); infer_expr(Env, {lam, Attrs, Args, Body}) -> ArgTypes = [fresh_uvar(As) || {arg, As, _, _} <- Args], ArgPatterns = [{typed, As, Pat, check_type(Env, T)} || {arg, As, Pat, T} <- Args], @@ -1349,7 +1358,7 @@ infer_expr(Env, {lam, Attrs, Args, Body}) -> infer_case(Env, Attrs, {tuple, Attrs, ArgPatterns}, {tuple_t, Attrs, ArgTypes}, Body, ResultType), NewArgs = [{arg, As, NewPat, NewT} || {typed, As, NewPat, NewT} <- NewArgPatterns], {typed, Attrs, {lam, Attrs, NewArgs, NewBody}, {fun_t, Attrs, [], ArgTypes, ResultType}}; -infer_expr(Env, Let = {letval, Attrs, _, _, _}) -> +infer_expr(Env, Let = {letval, Attrs, _, _}) -> type_error({missing_body_for_let, Attrs}), infer_expr(Env, {block, Attrs, [Let, abort_expr(Attrs, "missing body")]}); infer_expr(Env, Let = {letfun, Attrs, _, _, _, _}) -> @@ -1412,15 +1421,19 @@ infer_op(Env, As, Op, Args, InferOp) -> unify(Env, ArgTypes, OperandTypes, {infer_app, Op, Args, Inferred, ArgTypes}), {typed, As, {app, As, Op, TypedArgs}, ResultType}. -infer_case(Env, Attrs, Pattern, ExprType, Branch, SwitchType) -> +infer_pattern(Env, Pattern) -> Vars = free_vars(Pattern), Names = [N || {id, _, N} <- Vars, N /= "_"], case Names -- lists:usort(Names) of [] -> ok; Nonlinear -> type_error({non_linear_pattern, Pattern, lists:usort(Nonlinear)}) end, - NewEnv = bind_vars([{Var, fresh_uvar(Ann)} || Var = {id, Ann, _} <- Vars], Env#env{ in_pattern = true }), - NewPattern = {typed, _, _, PatType} = infer_expr(NewEnv, Pattern), + NewEnv = bind_vars([{Var, fresh_uvar(Ann1)} || Var = {id, Ann1, _} <- Vars], Env#env{ in_pattern = true }), + NewPattern = infer_expr(NewEnv, Pattern), + {NewEnv, NewPattern}. + +infer_case(Env, Attrs, Pattern, ExprType, Branch, SwitchType) -> + {NewEnv, NewPattern = {typed, _, _, PatType}} = infer_pattern(Env, Pattern), NewBranch = check_expr(NewEnv#env{ in_pattern = false }, Branch, SwitchType), unify(Env, PatType, ExprType, {case_pat, Pattern, PatType, ExprType}), {'case', Attrs, NewPattern, NewBranch}. @@ -1435,11 +1448,11 @@ infer_block(Env, Attrs, [Def={letfun, Ann, _, _, _, _}|Rest], BlockType) -> FunT = typesig_to_fun_t(TypeSig), NewE = bind_var({id, Ann, Name}, FunT, Env), [LetFun|infer_block(NewE, Attrs, Rest, BlockType)]; -infer_block(Env, _, [{letval, Attrs, Pattern, Type, E}|Rest], BlockType) -> - NewE = {typed, _, _, PatType} = infer_expr(Env, {typed, Attrs, E, arg_type(aeso_syntax:get_ann(Pattern), Type)}), +infer_block(Env, _, [{letval, Attrs, Pattern, E}|Rest], BlockType) -> + NewE = {typed, _, _, PatType} = infer_expr(Env, E), {'case', _, NewPattern, {typed, _, {block, _, NewRest}, _}} = infer_case(Env, Attrs, Pattern, PatType, {block, Attrs, Rest}, BlockType), - [{letval, Attrs, NewPattern, Type, NewE}|NewRest]; + [{letval, Attrs, NewPattern, NewE}|NewRest]; infer_block(Env, Attrs, [E|Rest], BlockType) -> [infer_expr(Env, E)|infer_block(Env, Attrs, Rest, BlockType)]. @@ -1481,18 +1494,13 @@ infer_prefix({IntOp,As}) when IntOp =:= '-' -> abort_expr(Ann, Str) -> {app, Ann, {id, Ann, "abort"}, [{string, Ann, Str}]}. -free_vars({int, _, _}) -> - []; -free_vars({char, _, _}) -> - []; -free_vars({string, _, _}) -> - []; -free_vars({bool, _, _}) -> - []; -free_vars(Id={id, _, _}) -> - [Id]; -free_vars({con, _, _}) -> - []; +free_vars({int, _, _}) -> []; +free_vars({char, _, _}) -> []; +free_vars({string, _, _}) -> []; +free_vars({bool, _, _}) -> []; +free_vars(Id={id, _, _}) -> [Id]; +free_vars({con, _, _}) -> []; +free_vars({qcon, _, _}) -> []; free_vars({tuple, _, Cpts}) -> free_vars(Cpts); free_vars({list, _, Elems}) -> @@ -1501,6 +1509,8 @@ free_vars({app, _, {'::', _}, Args}) -> free_vars(Args); free_vars({app, _, {con, _, _}, Args}) -> free_vars(Args); +free_vars({app, _, {qcon, _, _}, Args}) -> + free_vars(Args); free_vars({record, _, Fields}) -> free_vars([E || {field, _, _, E} <- Fields]); free_vars({typed, _, A, _}) -> @@ -2507,6 +2517,14 @@ mk_error({compiler_version_mismatch, Ann, Version, Op, Bound}) -> "because it does not satisfy the constraint" " ~s ~s ~s\n", [PrintV(Version), Op, PrintV(Bound)]), mk_t_err(pos(Ann), Msg); +mk_error({empty_record_or_map_update, Expr}) -> + Msg = io_lib:format("Empty record/map update\n~s", + [pp_expr(" ", Expr)]), + mk_t_err(pos(Expr), Msg); +mk_error({mixed_record_and_map, Expr}) -> + Msg = io_lib:format("Mixed record fields and map keys in\n~s", + [pp_expr(" ", Expr)]), + mk_t_err(pos(Expr), Msg); mk_error(Err) -> Msg = io_lib:format("Unknown error: ~p\n", [Err]), mk_t_err(pos(0, 0), Msg). diff --git a/src/aeso_ast_to_fcode.erl b/src/aeso_ast_to_fcode.erl index 9b28e78..84716ad 100644 --- a/src/aeso_ast_to_fcode.erl +++ b/src/aeso_ast_to_fcode.erl @@ -24,6 +24,8 @@ -type var_name() :: string(). -type sophia_name() :: [string()]. +-type state_reg() :: pos_integer(). + -type builtin() :: atom(). -type op() :: '+' | '-' | '*' | '/' | mod | '^' | '++' | '::' | @@ -68,6 +70,8 @@ | {funcall, fexpr(), [fexpr()]} %% Call to unknown function | {closure, fun_name(), fexpr()} | {switch, fsplit()} + | {set_state, state_reg(), fexpr()} + | {get_state, state_reg()} %% The following (unapplied top-level functions/builtins and %% lambdas) are generated by the fcode compiler, but translated %% to closures by the lambda lifter. @@ -116,6 +120,7 @@ -type fcode() :: #{ contract_name := string(), state_type := ftype(), + state_layout := state_layout(), event_type := ftype() | none, functions := #{ fun_name() => fun_def() }, payable := boolean() }. @@ -137,15 +142,18 @@ | {namespace, string()} | {abstract_contract, string()}. --type env() :: #{ type_env := type_env(), - fun_env := fun_env(), - con_env := con_env(), - event_type => aeso_syntax:typedef(), - builtins := builtins(), - options := [option()], - context => context(), - vars => [var_name()], - functions := #{ fun_name() => fun_def() } }. +-type state_layout() :: {tuple, [state_layout()]} | {reg, state_reg()}. + +-type env() :: #{ type_env := type_env(), + fun_env := fun_env(), + con_env := con_env(), + event_type => aeso_syntax:typedef(), + builtins := builtins(), + options := [option()], + state_layout => state_layout(), + context => context(), + vars => [var_name()], + functions := #{ fun_name() => fun_def() } }. -define(HASH_BYTES, 32). @@ -156,12 +164,14 @@ -spec ast_to_fcode(aeso_syntax:ast(), [option()]) -> fcode(). ast_to_fcode(Code, Options) -> Verbose = lists:member(pp_fcode, Options), + init_fresh_names(), FCode1 = to_fcode(init_env(Options), Code), [io:format("-- Before lambda lifting --\n~s\n\n", [format_fcode(FCode1)]) || Verbose], - FCode2 = lambda_lift(FCode1), - [ io:format("-- After lambda lifting --\n~s\n\n", [format_fcode(FCode2)]) || Verbose, FCode2 /= FCode1 ], - FCode3 = optimize_fcode(FCode2), - [ io:format("-- After optimization --\n~s\n\n", [format_fcode(FCode3)]) || Verbose, FCode3 /= FCode2 ], + FCode2 = optimize_fcode(FCode1), + [ io:format("-- After optimization --\n~s\n\n", [format_fcode(FCode2)]) || Verbose, FCode2 /= FCode1 ], + FCode3 = lambda_lift(FCode2), + [ io:format("-- After lambda lifting --\n~s\n\n", [format_fcode(FCode3)]) || Verbose, FCode3 /= FCode2 ], + clear_fresh_names(), FCode3. %% -- Environment ------------------------------------------------------------ @@ -221,6 +231,8 @@ builtins() -> || {NS, Funs} <- Scopes, {Fun, Arity} <- Funs ]). +state_layout(Env) -> maps:get(state_layout, Env, {reg, 1}). + -define(type(T), fun([]) -> T end). -define(type(X, T), fun([X]) -> T end). -define(type(X, Y, T), fun([X, Y]) -> T end). @@ -247,7 +259,13 @@ init_type_env() -> }. is_no_code(Env) -> - proplists:get_value(no_code, maps:get(options, Env, []), false). + get_option(no_code, Env). + +get_option(Opt, Env) -> + get_option(Opt, Env, false). + +get_option(Opt, Env, Default) -> + proplists:get_value(Opt, maps:get(options, Env, []), Default). %% -- Compilation ------------------------------------------------------------ @@ -260,11 +278,13 @@ to_fcode(Env, [{contract, Attrs, MainCon = {con, _, Main}, Decls}]) -> [Main, "Chain", "event"] => {chain_event, 1}} }, #{ functions := Funs } = Env1 = decls_to_fcode(MainEnv, Decls), - StateType = lookup_type(Env1, [Main, "state"], [], {tuple, []}), - EventType = lookup_type(Env1, [Main, "event"], [], none), - Payable = proplists:get_value(payable, Attrs, false), + StateType = lookup_type(Env1, [Main, "state"], [], {tuple, []}), + EventType = lookup_type(Env1, [Main, "event"], [], none), + StateLayout = state_layout(Env1), + Payable = proplists:get_value(payable, Attrs, false), #{ contract_name => Main, state_type => StateType, + state_layout => StateLayout, event_type => EventType, payable => Payable, functions => add_init_function(Env1, MainCon, StateType, @@ -284,9 +304,7 @@ decls_to_fcode(Env, Decls) -> %% environment. Env1 = add_fun_env(Env, Decls), lists:foldl(fun(D, E) -> - init_fresh_names(), R = decl_to_fcode(E, D), - clear_fresh_names(), R end, Env1, Decls). @@ -322,14 +340,15 @@ typedef_to_fcode(Env, Id = {id, _, Name}, Xs, Def) -> FDef = fun(Args) when length(Args) == length(Xs) -> Sub = maps:from_list(lists:zip([X || {tvar, _, X} <- Xs], Args)), case Def of - {record_t, Fields} -> {todo, Xs, Args, record_t, Fields}; + {record_t, Fields} -> + {tuple, [type_to_fcode(Env, Sub, T) || {field_t, _, _, T} <- Fields]}; {variant_t, Cons} -> FCons = [ begin {constr_t, _, _, Ts} = Con, [type_to_fcode(Env, Sub, T) || T <- Ts] end || Con <- Cons ], {variant, FCons}; - {alias_t, Type} -> {todo, Xs, Args, alias_t, Type} + {alias_t, Type} -> type_to_fcode(Env, Sub, Type) end; (Args) -> internal_error({type_arity_mismatch, Name, length(Args), length(Xs)}) end, @@ -351,7 +370,34 @@ typedef_to_fcode(Env, Id = {id, _, Name}, Xs, Def) -> "event" -> Env1#{ event_type => Def }; _ -> Env1 end, - bind_type(Env2, Q, FDef). + Env3 = compute_state_layout(Env2, Name, FDef), + bind_type(Env3, Q, FDef). + +compute_state_layout(Env = #{ context := {main_contract, _} }, "state", Type) -> + NoLayout = get_option(no_flatten_state, Env), + Layout = + case Type([]) of + _ when NoLayout -> {reg, 1}; + T -> + {_, L} = compute_state_layout(1, T), + L + end, + Env#{ state_layout => Layout }; +compute_state_layout(Env, _, _) -> Env. + +compute_state_layout(R, {tuple, [T]}) -> + compute_state_layout(R, T); +compute_state_layout(R, {tuple, Ts}) -> + {R1, Ls} = compute_state_layout(R, Ts), + {R1, {tuple, Ls}}; +compute_state_layout(R, []) -> + {R, []}; +compute_state_layout(R, [H | T]) -> + {R1, H1} = compute_state_layout(R, H), + {R2, T1} = compute_state_layout(R1, T), + {R2, [H1 | T1]}; +compute_state_layout(R, _) -> + {R + 1, {reg, R}}. check_state_and_event_types(#{ context := {main_contract, _} }, Id, [_ | _]) -> case Id of @@ -404,6 +450,13 @@ make_let(Expr, Body) -> {'let', X, Expr, Body({var, X})} end. +let_bind(X, {var, Y}, Body) -> rename([{X, Y}], Body); +let_bind(X, Expr, Body) -> {'let', X, Expr, Body}. + +let_bind(Binds, Body) -> + lists:foldr(fun({X, E}, Rest) -> let_bind(X, E, Rest) end, + Body, Binds). + -spec expr_to_fcode(env(), aeso_syntax:expr()) -> fexpr(). expr_to_fcode(Env, {typed, _, Expr, Type}) -> expr_to_fcode(Env, Type, Expr); @@ -464,7 +517,7 @@ expr_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Args}) when C %% Tuples expr_to_fcode(Env, _Type, {tuple, _, Es}) -> - {tuple, [expr_to_fcode(Env, E) || E <- Es]}; + make_tuple([expr_to_fcode(Env, E) || E <- Es]); %% Records expr_to_fcode(Env, Type, {proj, _Ann, Rec = {typed, _, _, RecType}, {id, _, X}}) -> @@ -476,18 +529,28 @@ expr_to_fcode(Env, Type, {proj, _Ann, Rec = {typed, _, _, RecType}, {id, _, X}}) FArgs = [type_to_fcode(Env, Arg) || Arg <- Args], {remote_u, FArgs, type_to_fcode(Env, Ret), expr_to_fcode(Env, Rec), {entrypoint, list_to_binary(X)}}; + {record_t, [_]} -> expr_to_fcode(Env, Rec); %% Singleton record {record_t, _} -> {proj, expr_to_fcode(Env, Rec), field_index(Rec, X)} end; +expr_to_fcode(Env, {record_t, [FieldT]}, {record, _Ann, [_] = Fields}) -> + {set, E} = field_value(FieldT, Fields), + expr_to_fcode(Env, E); expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Fields}) -> FVal = fun(F) -> %% All fields are present and no updates {set, E} = field_value(F, Fields), expr_to_fcode(Env, E) end, - {tuple, lists:map(FVal, FieldTypes)}; + make_tuple(lists:map(FVal, FieldTypes)); +expr_to_fcode(Env, {record_t, [FieldT]}, {record, _Ann, Rec, Fields}) -> + case field_value(FieldT, Fields) of + false -> expr_to_fcode(Env, Rec); + {set, E} -> expr_to_fcode(Env, E); + {upd, Z, E} -> {'let', Z, expr_to_fcode(Env, Rec), expr_to_fcode(bind_var(Env, Z), E)} + end; expr_to_fcode(Env, {record_t, FieldTypes}, {record, _Ann, Rec, Fields}) -> X = fresh_name(), Proj = fun(I) -> {proj, {var, X}, I - 1} end, @@ -519,9 +582,12 @@ expr_to_fcode(Env, _Type, {app, _, {'..', _}, [A, B]}) -> expr_to_fcode(Env, _Type, {list_comp, _, Yield, []}) -> {op, '::', [expr_to_fcode(Env, Yield), nil]}; -expr_to_fcode(Env, _Type, {list_comp, As, Yield, [{comprehension_bind, {typed, {id, _, Arg}, _}, BindExpr}|Rest]}) -> +expr_to_fcode(Env, _Type, {list_comp, As, Yield, [{comprehension_bind, Pat = {typed, _, _, PatType}, BindExpr}|Rest]}) -> + Arg = fresh_name(), Env1 = bind_var(Env, Arg), - Bind = {lam, [Arg], expr_to_fcode(Env1, {list_comp, As, Yield, Rest})}, + Bind = {lam, [Arg], expr_to_fcode(Env1, {switch, As, {typed, As, {id, As, Arg}, PatType}, + [{'case', As, Pat, {list_comp, As, Yield, Rest}}, + {'case', As, {id, As, "_"}, {list, As, []}}]})}, {def_u, FlatMap, _} = resolve_fun(Env, ["ListInternal", "flat_map"]), {def, FlatMap, [Bind, expr_to_fcode(Env, BindExpr)]}; expr_to_fcode(Env, Type, {list_comp, As, Yield, [{comprehension_if, _, Cond}|Rest]}) -> @@ -529,7 +595,7 @@ expr_to_fcode(Env, Type, {list_comp, As, Yield, [{comprehension_if, _, Cond}|Res expr_to_fcode(Env, Type, {list_comp, As, Yield, Rest}), nil ); -expr_to_fcode(Env, Type, {list_comp, As, Yield, [LV = {letval, _, _, _, _}|Rest]}) -> +expr_to_fcode(Env, Type, {list_comp, As, Yield, [LV = {letval, _, _, _}|Rest]}) -> expr_to_fcode(Env, Type, {block, As, [LV, {list_comp, As, Yield, Rest}]}); expr_to_fcode(Env, Type, {list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}) -> expr_to_fcode(Env, Type, {block, As, [LF, {list_comp, As, Yield, Rest}]}); @@ -574,8 +640,8 @@ expr_to_fcode(Env, _Type, {app, _, Fun = {typed, _, _, {fun_t, _, NamedArgsT, _, Args1 = get_named_args(NamedArgsT, Args), FArgs = [expr_to_fcode(Env, Arg) || Arg <- Args1], case expr_to_fcode(Env, Fun) of - {builtin_u, B, _Ar, TypeArgs} -> builtin_to_fcode(B, FArgs ++ TypeArgs); - {builtin_u, B, _Ar} -> builtin_to_fcode(B, FArgs); + {builtin_u, B, _Ar, TypeArgs} -> builtin_to_fcode(state_layout(Env), B, FArgs ++ TypeArgs); + {builtin_u, B, _Ar} -> builtin_to_fcode(state_layout(Env), B, FArgs); {def_u, F, _Ar} -> {def, F, FArgs}; {remote_u, ArgsT, RetT, Ct, RFun} -> {remote, ArgsT, RetT, Ct, RFun, FArgs}; FFun -> @@ -639,6 +705,13 @@ make_if(Cond, Then, Else) -> X = fresh_name(), {'let', X, Cond, make_if({var, X}, Then, Else)}. +-spec make_tuple([fexpr()]) -> fexpr(). +make_tuple([E]) -> E; +make_tuple(Es) -> {tuple, Es}. + +-spec strip_singleton_tuples(ftype()) -> ftype(). +strip_singleton_tuples({tuple, [T]}) -> strip_singleton_tuples(T); +strip_singleton_tuples(T) -> T. get_oracle_type(oracle_register, {fun_t, _, _, _, OType}) -> OType; get_oracle_type(oracle_query, {fun_t, _, _, [OType | _], _}) -> OType; @@ -726,10 +799,13 @@ split_tree(Env, Vars, Alts = [{'case', Pats, Body} | _]) -> {nosplit, rename(Ren, Body)}; I when is_integer(I) -> {Vars0, [{X, Type} | Vars1]} = lists:split(I - 1, Vars), + Type1 = strip_singleton_tuples(Type), SAlts = merge_alts(I, X, [ split_alt(I, A) || A <- Alts ]), - Cases = [ {'case', SPat, split_tree(Env, Vars0 ++ split_vars(SPat, Type) ++ Vars1, FAlts)} + MakeCase = fun({var, Z}, Split) -> {'case', {var, "_"}, rename_split([{Z, X}], Split)}; + (SPat, Split) -> {'case', SPat, Split} end, + Cases = [ MakeCase(SPat, split_tree(Env, Vars0 ++ split_vars(SPat, Type1) ++ Vars1, FAlts)) || {SPat, FAlts} <- SAlts ], - {split, Type, X, Cases} + {split, Type1, X, Cases} end. -spec merge_alts(integer(), var_name(), [{fsplit_pat(), falt()}]) -> [{fsplit_pat(), [falt()]}]. @@ -852,7 +928,7 @@ pat_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Pats}) when C #con_tag{tag = I, arities = As} = lookup_con(Env, Con), {con, As, I, [pat_to_fcode(Env, Pat) || Pat <- Pats]}; pat_to_fcode(Env, _Type, {tuple, _, Pats}) -> - {tuple, [ pat_to_fcode(Env, Pat) || Pat <- Pats ]}; + make_tuple([ pat_to_fcode(Env, Pat) || Pat <- Pats ]); pat_to_fcode(_Env, _Type, {bool, _, B}) -> {bool, B}; pat_to_fcode(_Env, _Type, {int, _, N}) -> {int, N}; pat_to_fcode(_Env, _Type, {char, _, N}) -> {int, N}; @@ -870,8 +946,8 @@ pat_to_fcode(Env, {record_t, Fields}, {record, _, FieldPats}) -> {set, Pat} -> Pat %% {upd, _, _} is impossible in patterns end end, - {tuple, [pat_to_fcode(Env, FieldPat(Field)) - || Field <- Fields]}; + make_tuple([pat_to_fcode(Env, FieldPat(Field)) + || Field <- Fields]); pat_to_fcode(_Env, Type, Pat) -> error({todo, Pat, ':', Type}). @@ -905,8 +981,10 @@ decision_tree_to_fcode({'if', A, Then, Else}) -> %% -- Statements -- -spec stmts_to_fcode(env(), [aeso_syntax:stmt()]) -> fexpr(). -stmts_to_fcode(Env, [{letval, _, {typed, _, {id, _, X}, _}, _, Expr} | Stmts]) -> +stmts_to_fcode(Env, [{letval, _, {typed, _, {id, _, X}, _}, Expr} | Stmts]) -> {'let', X, expr_to_fcode(Env, Expr), stmts_to_fcode(bind_var(Env, X), Stmts)}; +stmts_to_fcode(Env, [{letval, Ann, Pat, Expr} | Stmts]) -> + expr_to_fcode(Env, {switch, Ann, Expr, [{'case', Ann, Pat, {block, Ann, Stmts}}]}); stmts_to_fcode(Env, [{letfun, Ann, {id, _, X}, Args, _Type, Expr} | Stmts]) -> {'let', X, expr_to_fcode(Env, {lam, Ann, Args, Expr}), stmts_to_fcode(bind_var(Env, X), Stmts)}; @@ -934,23 +1012,40 @@ op_builtins() -> mcl_bls12_381_int_to_fr, mcl_bls12_381_int_to_fp, mcl_bls12_381_fr_to_int, mcl_bls12_381_fp_to_int ]. -builtin_to_fcode(require, [Cond, Msg]) -> +set_state({reg, R}, Val) -> + {set_state, R, Val}; +set_state({tuple, Ls}, Val) -> + ?make_let(X, Val, + lists:foldr(fun({I, L}, Code) -> + {'let', "_", set_state(L, {proj, X, I - 1}), Code} + end, {tuple, []}, indexed(Ls))). + +get_state({reg, R}) -> + {get_state, R}; +get_state({tuple, Ls}) -> + {tuple, [get_state(L) || L <- Ls]}. + +builtin_to_fcode(Layout, set_state, [Val]) -> + set_state(Layout, Val); +builtin_to_fcode(Layout, get_state, []) -> + get_state(Layout); +builtin_to_fcode(_Layout, require, [Cond, Msg]) -> make_if(Cond, {tuple, []}, {builtin, abort, [Msg]}); -builtin_to_fcode(chain_event, [Event]) -> +builtin_to_fcode(_Layout, chain_event, [Event]) -> {def, event, [Event]}; -builtin_to_fcode(map_delete, [Key, Map]) -> +builtin_to_fcode(_Layout, map_delete, [Key, Map]) -> {op, map_delete, [Map, Key]}; -builtin_to_fcode(map_member, [Key, Map]) -> +builtin_to_fcode(_Layout, map_member, [Key, Map]) -> {op, map_member, [Map, Key]}; -builtin_to_fcode(map_lookup, [Key0, Map0]) -> +builtin_to_fcode(_Layout, map_lookup, [Key0, Map0]) -> ?make_let(Key, Key0, ?make_let(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(map_lookup_default, [Key, Map, Def]) -> +builtin_to_fcode(_Layout, map_lookup_default, [Key, Map, Def]) -> {op, map_get_d, [Map, Key, Def]}; -builtin_to_fcode(Builtin, Args) -> +builtin_to_fcode(_Layout, Builtin, Args) -> case lists:member(Builtin, op_builtins()) of true -> {op, Builtin, Args}; false -> {builtin, Builtin, Args} @@ -965,8 +1060,9 @@ add_init_function(Env, Main, StateType, Funs0) -> Funs = add_default_init_function(Env, Main, StateType, Funs0), InitName = {entrypoint, <<"init">>}, InitFun = #{ body := InitBody} = maps:get(InitName, Funs), - Funs#{ InitName => InitFun#{ return => {tuple, []}, - body => {builtin, set_state, [InitBody]} } } + Funs1 = Funs#{ InitName => InitFun#{ return => {tuple, []}, + body => builtin_to_fcode(state_layout(Env), set_state, [InitBody]) } }, + Funs1 end. add_default_init_function(_Env, Main, StateType, Funs) -> @@ -1017,12 +1113,10 @@ event_function(_Env = #{event_type := {variant_t, EventCons}}, EventType = {vari %% the top-level and replace it with a closure. -spec lambda_lift(fcode()) -> fcode(). -lambda_lift(FCode = #{ functions := Funs }) -> - init_fresh_names(), +lambda_lift(FCode = #{ functions := Funs, state_layout := StateLayout }) -> init_lambda_funs(), - Funs1 = maps:map(fun lambda_lift_fun/2, Funs), + Funs1 = maps:map(fun(_, Body) -> lambda_lift_fun(StateLayout, Body) end, Funs), NewFuns = get_lambda_funs(), - clear_fresh_names(), FCode#{ functions := maps:merge(Funs1, NewFuns) }. -define(lambda_key, '%lambdalifted'). @@ -1035,8 +1129,8 @@ add_lambda_fun(Def) -> put(?lambda_key, Funs#{ Name => Def }), Name. -lambda_lift_fun(_, Def = #{ body := Body }) -> - Def#{ body := lambda_lift_expr(Body) }. +lambda_lift_fun(Layout, Def = #{ body := Body }) -> + Def#{ body := lambda_lift_expr(Layout, Body) }. lifted_fun([Z], Xs, Body) -> #{ attrs => [private], @@ -1057,10 +1151,10 @@ make_closure(FVs, Xs, Body) -> Tup = fun([Y]) -> Y; (Ys) -> {tuple, Ys} end, {closure, Fun, Tup([{var, Y} || Y <- FVs])}. -lambda_lift_expr({lam, Xs, Body}) -> +lambda_lift_expr(Layout, {lam, Xs, Body}) -> FVs = free_vars({lam, Xs, Body}), - make_closure(FVs, Xs, lambda_lift_expr(Body)); -lambda_lift_expr(UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == builtin_u -> + make_closure(FVs, Xs, lambda_lift_expr(Layout, Body)); +lambda_lift_expr(Layout, UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == builtin_u -> [Tag, F, Ar | _] = tuple_to_list(UExpr), ExtraArgs = case UExpr of {builtin_u, _, _, TypeArgs} -> TypeArgs; @@ -1069,40 +1163,42 @@ lambda_lift_expr(UExpr) when element(1, UExpr) == def_u; element(1, UExpr) == bu Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, Ar) ], Args = [{var, X} || X <- Xs] ++ ExtraArgs, Body = case Tag of - builtin_u -> builtin_to_fcode(F, Args); + builtin_u -> builtin_to_fcode(Layout, F, Args); def_u -> {def, F, Args} end, make_closure([], Xs, Body); -lambda_lift_expr({remote_u, ArgsT, RetT, Ct, F}) -> +lambda_lift_expr(Layout, {remote_u, ArgsT, RetT, Ct, F}) -> FVs = free_vars(Ct), - Ct1 = lambda_lift_expr(Ct), + Ct1 = lambda_lift_expr(Layout, Ct), GasAndValueArgs = 2, Xs = [ lists:concat(["arg", I]) || I <- lists:seq(1, length(ArgsT) + GasAndValueArgs) ], Args = [{var, X} || X <- Xs], make_closure(FVs, Xs, {remote, ArgsT, RetT, Ct1, F, Args}); -lambda_lift_expr(Expr) -> +lambda_lift_expr(Layout, Expr) -> case Expr of {lit, _} -> Expr; nil -> Expr; {var, _} -> Expr; {closure, _, _} -> Expr; - {def, D, As} -> {def, D, lambda_lift_exprs(As)}; - {builtin, B, As} -> {builtin, B, lambda_lift_exprs(As)}; - {remote, ArgsT, RetT, Ct, F, As} -> {remote, ArgsT, RetT, lambda_lift_expr(Ct), F, lambda_lift_exprs(As)}; - {con, Ar, C, As} -> {con, Ar, C, lambda_lift_exprs(As)}; - {tuple, As} -> {tuple, lambda_lift_exprs(As)}; - {proj, A, I} -> {proj, lambda_lift_expr(A), I}; - {set_proj, A, I, B} -> {set_proj, lambda_lift_expr(A), I, lambda_lift_expr(B)}; - {op, Op, As} -> {op, Op, lambda_lift_exprs(As)}; - {'let', X, A, B} -> {'let', X, lambda_lift_expr(A), lambda_lift_expr(B)}; - {funcall, A, Bs} -> {funcall, lambda_lift_expr(A), lambda_lift_exprs(Bs)}; - {switch, S} -> {switch, lambda_lift_expr(S)}; - {split, Type, X, Alts} -> {split, Type, X, lambda_lift_exprs(Alts)}; - {nosplit, A} -> {nosplit, lambda_lift_expr(A)}; - {'case', P, S} -> {'case', P, lambda_lift_expr(S)} + {def, D, As} -> {def, D, lambda_lift_exprs(Layout, As)}; + {builtin, B, As} -> {builtin, B, lambda_lift_exprs(Layout, As)}; + {remote, ArgsT, RetT, Ct, F, As} -> {remote, ArgsT, RetT, lambda_lift_expr(Layout, Ct), F, lambda_lift_exprs(Layout, As)}; + {con, Ar, C, As} -> {con, Ar, C, lambda_lift_exprs(Layout, As)}; + {tuple, As} -> {tuple, lambda_lift_exprs(Layout, As)}; + {proj, A, I} -> {proj, lambda_lift_expr(Layout, A), I}; + {set_proj, A, I, B} -> {set_proj, lambda_lift_expr(Layout, A), I, lambda_lift_expr(Layout, B)}; + {op, Op, As} -> {op, Op, lambda_lift_exprs(Layout, As)}; + {'let', X, A, B} -> {'let', X, lambda_lift_expr(Layout, A), lambda_lift_expr(Layout, B)}; + {funcall, A, Bs} -> {funcall, lambda_lift_expr(Layout, A), lambda_lift_exprs(Layout, Bs)}; + {set_state, R, A} -> {set_state, R, lambda_lift_expr(Layout, A)}; + {get_state, _} -> Expr; + {switch, S} -> {switch, lambda_lift_expr(Layout, S)}; + {split, Type, X, Alts} -> {split, Type, X, lambda_lift_exprs(Layout, Alts)}; + {nosplit, A} -> {nosplit, lambda_lift_expr(Layout, A)}; + {'case', P, S} -> {'case', P, lambda_lift_expr(Layout, S)} end. -lambda_lift_exprs(As) -> [lambda_lift_expr(A) || A <- As]. +lambda_lift_exprs(Layout, As) -> [lambda_lift_expr(Layout, A) || A <- As]. %% -- Optimisations ---------------------------------------------------------- @@ -1120,7 +1216,12 @@ optimize_fcode(Code = #{ functions := Funs }) -> -spec optimize_fun(fcode(), fun_name(), fun_def()) -> fun_def(). optimize_fun(Fcode, Fun, Def = #{ body := Body }) -> %% io:format("Optimizing ~p =\n~s\n", [_Fun, prettypr:format(pp_fexpr(_Body))]), - Def#{ body := inliner(Fcode, Fun, Body) }. + Def#{ body := drop_unused_lets( + simplifier( + let_floating( + bind_subexpressions( + inline_local_functions( + inliner(Fcode, Fun, Body)))))) }. %% --- Inlining --- @@ -1136,6 +1237,246 @@ should_inline(_Fcode, _Fun1) -> false == list_to_atom("true"). %% Dialyzer inline(_Fcode, Fun, Args) -> {def, Fun, Args}. %% TODO +%% --- Bind subexpressions --- + +-define(make_lets(Xs, Es, Body), make_lets(Es, fun(Xs) -> Body end)). + +bind_subexpressions(Expr) -> + bottom_up(fun bind_subexpressions/2, Expr). + +bind_subexpressions(_, {tuple, Es}) -> + ?make_lets(Xs, Es, {tuple, Xs}); +bind_subexpressions(_, {set_proj, A, I, B}) -> + ?make_lets([X, Y], [A, B], {set_proj, X, I, Y}); +bind_subexpressions(_, E) -> E. + +make_lets(Es, Body) -> make_lets(Es, [], Body). + +make_lets([], Xs, Body) -> Body(lists:reverse(Xs)); +make_lets([{var, _} = E | Es], Xs, Body) -> + make_lets(Es, [E | Xs], Body); +make_lets([{lit, _} = E | Es], Xs, Body) -> + make_lets(Es, [E | Xs], Body); +make_lets([E | Es], Xs, Body) -> + ?make_let(X, E, make_lets(Es, [X | Xs], Body)). + +%% --- Inline local functions --- + +inline_local_functions(Expr) -> + bottom_up(fun inline_local_functions/2, Expr). + +inline_local_functions(Env, {funcall, {proj, {var, Y}, 0}, [{proj, {var, Y}, 1} | Args]} = Expr) -> + %% TODO: Don't always inline local funs? + case maps:get(Y, Env, free) of + {lam, Xs, Body} -> let_bind(lists:zip(Xs, Args), Body); + _ -> Expr + end; +inline_local_functions(_, Expr) -> Expr. + +%% --- Let-floating --- + +let_floating(Expr) -> bottom_up(fun let_float/2, Expr). + +let_float(_, {'let', X, E, Body}) -> + pull_out_let({'let', X, {here, E}, Body}); +let_float(_, {proj, E, I}) -> + pull_out_let({proj, {here, E}, I}); +let_float(_, {set_proj, E, I, V}) -> + pull_out_let({set_proj, {here, E}, I, {here, V}}); +let_float(_, {op, Op, Es}) -> + {Lets, Es1} = pull_out_let([{here, E} || E <- Es]), + let_bind(Lets, {op, Op, Es1}); +let_float(_, E) -> E. + +pull_out_let(Expr) when is_tuple(Expr) -> + {Lets, Es} = pull_out_let(tuple_to_list(Expr)), + Inner = list_to_tuple(Es), + let_bind(Lets, Inner); +pull_out_let(Es) when is_list(Es) -> + case lists:splitwith(fun({here, _}) -> false; (_) -> true end, Es) of + {Es0, [{here, E} | Es1]} -> + case let_view(E) of + {[], _} -> + {Lets, Es2} = pull_out_let(Es1), + {Lets, Es0 ++ [E] ++ Es2}; + {Lets, E1} -> + {Lets1, Es2} = pull_out_let(Es1), + {Lets ++ Lets1, Es0 ++ [E1] ++ Es2} + end; + {_, []} -> {[], Es} + end. + +%% Also renames the variables to fresh names +let_view(E) -> let_view(E, [], []). + +let_view({'let', X, E, Rest}, Ren, Lets) -> + Z = fresh_name(), + let_view(Rest, [{X, Z} | Ren], [{Z, rename(Ren, E)} | Lets]); +let_view(E, Ren, Lets) -> + {lists:reverse(Lets), rename(Ren, E)}. + +%% --- Simplification --- + +-spec simplifier(fexpr()) -> fexpr(). +simplifier(Expr) -> + bottom_up(fun simplify/2, Expr). + +-spec simplify(#{var_name() => fexpr()}, fexpr()) -> fexpr(). + +%% (e₀, .., en).i -> +%% let _ = e₀ in .. let x = ei in .. let _ = en in x +simplify(_Env, {proj, {tuple, Es}, I}) -> + It = lists:nth(I + 1, Es), + X = fresh_name(), + Dup = safe_to_duplicate(It), + Val = if Dup -> It; true -> {var, X} end, + lists:foldr( + fun({J, E}, Rest) when I == J -> + case Dup of + true -> Rest; + false -> {'let', X, E, Rest} + end; + ({_, E}, Rest) -> + case read_only(E) of + true -> Rest; + false -> {'let', "_", E, Rest} + end + end, Val, indexed(Es)); + +%% let x = e in .. x.i .. +simplify(Env, {proj, {var, X}, I} = Expr) -> + case simpl_proj(Env, I, {var, X}) of + false -> Expr; + E -> E + end; + +simplify(Env, {switch, Split}) -> + case simpl_switch(Env, Split) of + nomatch -> {builtin, abort, [{lit, {string, <<"Incomplete patterns">>}}]}; + stuck -> {switch, Split}; + Expr -> Expr + end; + +simplify(_, E) -> + E. + +simpl_proj(Env, I, Expr) -> + IfSafe = fun(E) -> case safe_to_duplicate(E) of + true -> E; + false -> false + end end, + case Expr of + false -> false; + {var, X} -> simpl_proj(Env, I, maps:get(X, Env, false)); + {tuple, Es} -> IfSafe(lists:nth(I + 1, Es)); + {set_proj, _, I, Val} -> IfSafe(Val); + {set_proj, E, _, _} -> simpl_proj(Env, I, E); + {proj, E, J} -> simpl_proj(Env, I, simpl_proj(Env, J, E)); + _ -> false + end. + +simpl_switch(_Env, {nosplit, E}) -> E; +simpl_switch(Env, {split, _, X, Alts}) -> + case constructor_form(Env, {var, X}) of + false -> stuck; + E -> simpl_switch(Env, E, Alts) + end. + +simpl_switch(_, _, []) -> nomatch; +simpl_switch(Env, E, [{'case', Pat, Body} | Alts]) -> + case match_pat(Pat, E) of + false -> simpl_switch(Env, E, Alts); + Binds -> + Env1 = maps:merge(Env, maps:from_list(Binds)), + case simpl_switch(Env1, Body) of + nomatch -> simpl_switch(Env, E, Alts); + stuck -> stuck; + Body1 -> let_bind(Binds, Body1) + end + end. + +-spec match_pat(fsplit_pat(), fexpr()) -> false | [{var_name(), fexpr()}]. +match_pat({tuple, Xs}, {tuple, Es}) -> lists:zip(Xs, Es); +match_pat({con, _, C, Xs}, {con, _, C, Es}) -> lists:zip(Xs, Es); +match_pat(L, {lit, L}) -> []; +match_pat(nil, nil) -> []; +match_pat({'::', X, Y}, {op, '::', [A, B]}) -> [{X, A}, {Y, B}]; +match_pat({var, X}, E) -> [{X, E}]; +match_pat(_, _) -> false. + +constructor_form(Env, Expr) -> + case Expr of + {var, X} -> + case maps:get(X, Env, free) of + free -> false; + E -> constructor_form(Env, E) %% TODO: shadowing? + end; + {set_proj, E, I, V} -> + case constructor_form(Env, E) of + {tuple, Es} -> {tuple, setnth(I + 1, V, Es)}; + _ -> false + end; + {proj, E, I} -> + case constructor_form(Env, E) of + {tuple, Es} -> constructor_form(Env, lists:nth(I + 1, Es)); + _ -> false + end; + {con, _, _, _} -> Expr; + {tuple, _} -> Expr; + {lit, _} -> Expr; + nil -> Expr; + {op, '::', _} -> Expr; + _ -> false + end. + +%% --- Drop unused lets --- + +drop_unused_lets(Expr) -> bottom_up(fun drop_unused_lets/2, Expr). + +drop_unused_lets(_, {'let', X, E, Body} = Expr) -> + case {read_only(E), not lists:member(X, free_vars(Body))} of + {true, true} -> Body; + {false, true} -> {'let', "_", E, Body}; + _ -> Expr + end; +drop_unused_lets(_, Expr) -> Expr. + +%% -- Static analysis -------------------------------------------------------- + +safe_to_duplicate({lit, _}) -> true; +safe_to_duplicate({var, _}) -> true; +safe_to_duplicate(nil) -> true; +safe_to_duplicate({tuple, []}) -> true; +safe_to_duplicate(_) -> false. + +-spec read_only(fexpr() | fsplit() | fcase() | [fexpr()] | [fcase()]) -> boolean(). +read_only({lit, _}) -> true; +read_only({var, _}) -> true; +read_only(nil) -> true; +read_only({con, _, _, Es}) -> read_only(Es); +read_only({tuple, Es}) -> read_only(Es); +read_only({proj, E, _}) -> read_only(E); +read_only({set_proj, A, _, B}) -> read_only([A, B]); +read_only({op, _, Es}) -> read_only(Es); +read_only({get_state, _}) -> true; +read_only({set_state, _, _}) -> false; +read_only({def_u, _, _}) -> true; +read_only({remote_u, _, _, _, _}) -> true; +read_only({builtin_u, _, _}) -> true; +read_only({builtin_u, _, _, _}) -> true; +read_only({lam, _, _}) -> true; +read_only({def, _, _}) -> false; %% TODO: purity analysis +read_only({remote, _, _, _, _, _}) -> false; +read_only({builtin, _, _}) -> false; %% TODO: some builtins are +read_only({switch, Split}) -> read_only(Split); +read_only({split, _, _, Cases}) -> read_only(Cases); +read_only({nosplit, E}) -> read_only(E); +read_only({'case', _, Split}) -> read_only(Split); +read_only({'let', _, A, B}) -> read_only([A, B]); +read_only({funcall, _, _}) -> false; +read_only({closure, _, _}) -> internal_error(no_closures_here); +read_only(Es) when is_list(Es) -> lists:all(fun read_only/1, Es). + %% --- Deadcode elimination --- -spec eliminate_dead_code(fcode()) -> fcode(). @@ -1257,10 +1598,10 @@ resolve_var(#{ vars := Vars } = Env, [X]) -> end; resolve_var(Env, Q) -> resolve_fun(Env, Q). -resolve_fun(#{ fun_env := Funs, builtins := Builtin }, Q) -> +resolve_fun(#{ fun_env := Funs, builtins := Builtin } = Env, Q) -> case {maps:get(Q, Funs, not_found), maps:get(Q, Builtin, not_found)} of {not_found, not_found} -> internal_error({unbound_variable, Q}); - {_, {B, none}} -> {builtin, B, []}; + {_, {B, none}} -> builtin_to_fcode(state_layout(Env), B, []); {_, {B, Ar}} -> {builtin_u, B, Ar}; {{Fun, Ar}, _} -> {def_u, Fun, Ar} end. @@ -1295,14 +1636,14 @@ pat_vars({con, _, _, Ps}) -> pat_vars(Ps); pat_vars(Ps) when is_list(Ps) -> [X || P <- Ps, X <- pat_vars(P)]. -spec fsplit_pat_vars(fsplit_pat()) -> [var_name()]. -fsplit_pat_vars({var, X}) -> [X || X /= "_"]; -fsplit_pat_vars({bool, _}) -> []; -fsplit_pat_vars({int, _}) -> []; -fsplit_pat_vars({string, _}) -> []; -fsplit_pat_vars(nil) -> []; -fsplit_pat_vars({'::', P, Q}) -> [P, Q]; -fsplit_pat_vars({tuple, Ps}) -> Ps; -fsplit_pat_vars({con, _, _, Ps}) -> Ps. +fsplit_pat_vars({var, X}) -> [X || X /= "_"]; +fsplit_pat_vars({bool, _}) -> []; +fsplit_pat_vars({int, _}) -> []; +fsplit_pat_vars({string, _}) -> []; +fsplit_pat_vars(nil) -> []; +fsplit_pat_vars({'::', P, Q}) -> [P, Q]; +fsplit_pat_vars({tuple, Ps}) -> Ps; +fsplit_pat_vars({con, _, _, Ps}) -> Ps. free_vars(Xs) when is_list(Xs) -> lists:umerge([ free_vars(X) || X <- Xs ]); @@ -1325,6 +1666,8 @@ free_vars(Expr) -> {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); @@ -1354,6 +1697,8 @@ used_defs(Expr) -> {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); @@ -1362,6 +1707,50 @@ used_defs(Expr) -> {'case', _, A} -> used_defs(A) end. +bottom_up(F, Expr) -> bottom_up(F, #{}, Expr). + +bottom_up(F, Env, Expr) -> + F(Env, case Expr of + {lit, _} -> Expr; + nil -> Expr; + {var, _} -> Expr; + {def, D, Es} -> {def, D, [bottom_up(F, Env, E) || E <- Es]}; + {def_u, _, _} -> Expr; + {builtin, B, Es} -> {builtin, B, [bottom_up(F, Env, E) || E <- Es]}; + {builtin_u, _, _} -> Expr; + {builtin_u, _, _, _} -> Expr; + {remote, ArgsT, RetT, Ct, Fun, Es} -> {remote, ArgsT, RetT, bottom_up(F, Env, Ct), Fun, [bottom_up(F, Env, E) || E <- Es]}; + {remote_u, ArgsT, RetT, Ct, Fun} -> {remote_u, ArgsT, RetT, bottom_up(F, Env, Ct), Fun}; + {con, Ar, I, Es} -> {con, Ar, I, [bottom_up(F, Env, E) || E <- Es]}; + {tuple, Es} -> {tuple, [bottom_up(F, Env, E) || E <- Es]}; + {proj, E, I} -> {proj, bottom_up(F, Env, E), I}; + {set_proj, R, I, E} -> {set_proj, bottom_up(F, Env, R), I, bottom_up(F, Env, E)}; + {op, Op, Es} -> {op, Op, [bottom_up(F, Env, E) || E <- Es]}; + {funcall, Fun, Es} -> {funcall, bottom_up(F, Env, Fun), [bottom_up(F, Env, E) || E <- Es]}; + {set_state, R, E} -> {set_state, R, bottom_up(F, Env, E)}; + {get_state, _} -> Expr; + {closure, F, CEnv} -> {closure, F, bottom_up(F, Env, CEnv)}; + {switch, Split} -> {switch, bottom_up(F, Env, Split)}; + {lam, Xs, B} -> {lam, Xs, bottom_up(F, Env, B)}; + {'let', X, E, Body} -> + E1 = bottom_up(F, Env, E), + %% Always freshen user variables to avoid shadowing issues. + ShouldFreshen = fun(Y = "%" ++ _) -> maps:is_key(Y, Env); + (_) -> true end, + case ShouldFreshen(X) of + true -> + Z = fresh_name(), + Env1 = Env#{ Z => E1 }, + {'let', Z, E1, bottom_up(F, Env1, rename([{X, Z}], Body))}; + false -> + Env1 = Env#{ X => E1 }, + {'let', X, E1, bottom_up(F, Env1, Body)} + end; + {split, Type, X, Cases} -> {split, Type, X, [bottom_up(F, Env, Case) || Case <- Cases]}; + {nosplit, E} -> {nosplit, bottom_up(F, Env, E)}; + {'case', Pat, Split} -> {'case', Pat, bottom_up(F, Env, Split)} + end). + get_named_args(NamedArgsT, Args) -> IsNamed = fun({named_arg, _, _, _}) -> true; (_) -> false end, @@ -1396,6 +1785,8 @@ rename(Ren, Expr) -> {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} -> @@ -1502,6 +1893,10 @@ get_attributes(Ann) -> indexed(Xs) -> lists:zip(lists:seq(1, length(Xs)), Xs). +setnth(I, X, Xs) -> + {Ys, [_ | Zs]} = lists:split(I - 1, Xs), + Ys ++ [X] ++ Zs. + -dialyzer({nowarn_function, [fcode_error/1, internal_error/1]}). fcode_error(Error) -> @@ -1604,9 +1999,18 @@ pp_fexpr({op, Op, [A] = Args}) -> end; pp_fexpr({op, Op, As}) -> pp_beside(pp_text(Op), pp_fexpr({tuple, As})); -pp_fexpr({'let', X, A, B}) -> - pp_par([pp_beside([pp_text("let "), pp_text(X), pp_text(" = "), pp_fexpr(A), pp_text(" in")]), - pp_fexpr(B)]); +pp_fexpr({'let', _, _, _} = Expr) -> + Lets = fun Lets({'let', Y, C, D}) -> + {Ls, E} = Lets(D), + {[{Y, C} | Ls], E}; + Lets(E) -> {[], E} end, + {Ls, Body} = Lets(Expr), + pp_parens( + pp_par( + [ pp_beside([ pp_text("let "), + pp_above([ pp_par([pp_text(X), pp_text("="), prettypr:nest(2, pp_fexpr(A))]) || {X, A} <- Ls ]), + pp_text(" in ") ]), + pp_fexpr(Body) ])); pp_fexpr({builtin_u, B, N}) -> pp_beside([pp_text(B), pp_text("/"), pp_text(N)]); pp_fexpr({builtin_u, B, N, TypeArgs}) -> @@ -1619,6 +2023,10 @@ pp_fexpr({remote, ArgsT, RetT, Ct, Fun, As}) -> pp_call(pp_parens(pp_beside([pp_fexpr(Ct), pp_text("."), pp_fun_name(Fun), pp_text(" : "), pp_ftype({function, ArgsT, RetT})])), As); pp_fexpr({funcall, Fun, As}) -> pp_call(pp_fexpr(Fun), As); +pp_fexpr({set_state, R, A}) -> + pp_call(pp_text("set_state"), [{lit, {int, R}}, A]); +pp_fexpr({get_state, R}) -> + pp_call(pp_text("get_state"), [{lit, {int, R}}]); pp_fexpr({switch, Split}) -> pp_split(Split). pp_call(Fun, Args) -> @@ -1634,7 +2042,7 @@ pp_ftype({tvar, X}) -> pp_text(X); pp_ftype({bytes, N}) -> pp_call(pp_text("bytes"), [{lit, {int, N}}]); pp_ftype({oracle, Q, R}) -> pp_call_t("oracle", [Q, R]); pp_ftype({tuple, Ts}) -> - pp_parens(pp_par(pp_punctuate(pp_text(","), [pp_ftype(T) || T <- Ts]))); + pp_parens(pp_par(pp_punctuate(pp_text(" *"), [pp_ftype(T) || T <- Ts]))); pp_ftype({list, T}) -> pp_call_t("list", [T]); pp_ftype({function, Args, Res}) -> diff --git a/src/aeso_ast_to_icode.erl b/src/aeso_ast_to_icode.erl index 0dc28fa..bd90f94 100644 --- a/src/aeso_ast_to_icode.erl +++ b/src/aeso_ast_to_icode.erl @@ -318,19 +318,23 @@ ast_body({app, As, Fun, Args}, Icode) -> end; ast_body({list_comp, _, Yield, []}, Icode) -> #list{elems = [ast_body(Yield, Icode)]}; -ast_body({list_comp, As, Yield, [{comprehension_bind, {typed, Arg, ArgType}, BindExpr}|Rest]}, Icode) -> +ast_body({list_comp, As, Yield, [{comprehension_bind, {typed, _, Pat, ArgType}, BindExpr}|Rest]}, Icode) -> + Arg = "%lc", + Body = {switch, As, {typed, As, {id, As, Arg}, ArgType}, + [{'case', As, Pat, {list_comp, As, Yield, Rest}}, + {'case', As, {id, As, "_"}, {list, As, []}}]}, #funcall { function = #var_ref{ name = ["ListInternal", "flat_map"] } , args = - [ #lambda{ args=[#arg{name = ast_id(Arg), type = ast_type(ArgType, Icode)}] - , body = ast_body({list_comp, As, Yield, Rest}, Icode) + [ #lambda{ args=[#arg{name = Arg, type = ast_type(ArgType, Icode)}] + , body = ast_body(Body, Icode) } , ast_body(BindExpr, Icode) ] }; ast_body({list_comp, As, Yield, [{comprehension_if, AsIF, Cond}|Rest]}, Icode) -> ast_body({'if', AsIF, Cond, {list_comp, As, Yield, Rest}, {list, As, []}}, Icode); -ast_body({list_comp, As, Yield, [LV = {letval, _, _, _, _}|Rest]}, Icode) -> +ast_body({list_comp, As, Yield, [LV = {letval, _, _, _}|Rest]}, Icode) -> ast_body({block, As, [LV, {list_comp, As, Yield, Rest}]}, Icode); ast_body({list_comp, As, Yield, [LF = {letfun, _, _, _, _, _}|Rest]}, Icode) -> ast_body({block, As, [LF, {list_comp, As, Yield, Rest}]}, Icode); @@ -344,14 +348,14 @@ ast_body({switch,_,A,Cases}, Icode) -> #switch{expr=ast_body(A, Icode), cases=[{ast_body(Pat, Icode),ast_body(Body, Icode)} || {'case',_,Pat,Body} <- Cases]}; -ast_body({block, As, [{letval, _, Pat, _, E} | Rest]}, Icode) -> +ast_body({block, As, [{letval, _, Pat, E} | Rest]}, Icode) -> E1 = ast_body(E, Icode), Pat1 = ast_body(Pat, Icode), Rest1 = ast_body({block, As, Rest}, Icode), #switch{expr = E1, cases = [{Pat1, Rest1}]}; ast_body({block, As, [{letfun, Ann, F, Args, _Type, Expr} | Rest]}, Icode) -> - ast_body({block, As, [{letval, Ann, F, unused, {lam, Ann, Args, Expr}} | Rest]}, Icode); + ast_body({block, As, [{letval, Ann, F, {lam, Ann, Args, Expr}} | Rest]}, Icode); ast_body({block,_,[]}, _Icode) -> #tuple{cpts=[]}; ast_body({block,_,[E]}, Icode) -> diff --git a/src/aeso_fcode_to_fate.erl b/src/aeso_fcode_to_fate.erl index 46f827d..ddb15eb 100644 --- a/src/aeso_fcode_to_fate.erl +++ b/src/aeso_fcode_to_fate.erl @@ -41,8 +41,8 @@ -define(TODO(What), error({todo, ?FILE, ?LINE, ?FUNCTION_NAME, What})). -define(i(X), {immediate, X}). --define(a, {stack, 0}). --define(s, {store, 1}). +-define(a, {stack, 0}). +-define(s(N), {store, N}). -define(void, {var, 9999}). -record(env, { contract, vars = [], locals = [], current_function, tailpos = true }). @@ -120,9 +120,10 @@ type_to_scode(name) -> name; type_to_scode(channel) -> channel; type_to_scode(bits) -> bits; type_to_scode(any) -> any; -type_to_scode({variant, Cons}) -> {variant, lists:map(fun(T) -> type_to_scode({tuple, T}) end, Cons)}; +type_to_scode({variant, Cons}) -> {variant, [{tuple, types_to_scode(Con)} || Con <- Cons]}; type_to_scode({list, Type}) -> {list, type_to_scode(Type)}; -type_to_scode({tuple, Types}) -> {tuple, lists:map(fun type_to_scode/1, Types)}; +type_to_scode({tuple, [Type]}) -> type_to_scode(Type); +type_to_scode({tuple, Types}) -> {tuple, types_to_scode(Types)}; type_to_scode({map, Key, Val}) -> {map, type_to_scode(Key), type_to_scode(Val)}; type_to_scode({function, _Args, _Res}) -> {tuple, [string, any]}; type_to_scode({tvar, X}) -> @@ -134,6 +135,8 @@ type_to_scode({tvar, X}) -> J -> {tvar, J} end. +types_to_scode(Ts) -> lists:map(fun type_to_scode/1, Ts). + %% -- Phase I ---------------------------------------------------------------- %% Icode to structured assembly @@ -179,84 +182,99 @@ lit_to_fate(L) -> {typerep, T} -> aeb_fate_data:make_typerep(type_to_scode(T)) end. -term_to_fate({lit, L}) -> +term_to_fate(E) -> term_to_fate(#{}, E). + +term_to_fate(_Env, {lit, L}) -> lit_to_fate(L); %% negative literals are parsed as 0 - N -term_to_fate({op, '-', [{lit, {int, 0}}, {lit, {int, N}}]}) -> +term_to_fate(_Env, {op, '-', [{lit, {int, 0}}, {lit, {int, N}}]}) -> aeb_fate_data:make_integer(-N); -term_to_fate(nil) -> +term_to_fate(_Env, nil) -> aeb_fate_data:make_list([]); -term_to_fate({op, '::', [Hd, Tl]}) -> +term_to_fate(Env, {op, '::', [Hd, Tl]}) -> %% The Tl will translate into a list, because FATE lists are just lists - [term_to_fate(Hd) | term_to_fate(Tl)]; -term_to_fate({tuple, As}) -> - aeb_fate_data:make_tuple(list_to_tuple([ term_to_fate(A) || A<-As])); -term_to_fate({con, Ar, I, As}) -> - FateAs = [ term_to_fate(A) || A <- As ], + [term_to_fate(Env, Hd) | term_to_fate(Env, Tl)]; +term_to_fate(Env, {tuple, As}) -> + aeb_fate_data:make_tuple(list_to_tuple([ term_to_fate(Env, A) || A<-As])); +term_to_fate(Env, {con, Ar, I, As}) -> + FateAs = [ term_to_fate(Env, A) || A <- As ], aeb_fate_data:make_variant(Ar, I, list_to_tuple(FateAs)); -term_to_fate({builtin, bits_all, []}) -> +term_to_fate(_Env, {builtin, bits_all, []}) -> aeb_fate_data:make_bits(-1); -term_to_fate({builtin, bits_none, []}) -> +term_to_fate(_Env, {builtin, bits_none, []}) -> aeb_fate_data:make_bits(0); -term_to_fate({op, bits_set, [B, I]}) -> +term_to_fate(_Env, {op, bits_set, [B, I]}) -> {bits, N} = term_to_fate(B), J = term_to_fate(I), {bits, N bor (1 bsl J)}; -term_to_fate({op, bits_clear, [B, I]}) -> +term_to_fate(_Env, {op, bits_clear, [B, I]}) -> {bits, N} = term_to_fate(B), J = term_to_fate(I), {bits, N band bnot (1 bsl J)}; -term_to_fate({builtin, map_empty, []}) -> +term_to_fate(Env, {'let', X, E, Body}) -> + Env1 = Env#{ X => term_to_fate(Env, E) }, + term_to_fate(Env1, Body); +term_to_fate(Env, {var, X}) -> + case maps:get(X, Env, undefined) of + undefined -> throw(not_a_fate_value); + V -> V + end; +term_to_fate(_Env, {builtin, map_empty, []}) -> aeb_fate_data:make_map(#{}); -term_to_fate({'let', _, {builtin, map_empty, []}, Set}) -> - aeb_fate_data:make_map(map_to_fate(Set)). +term_to_fate(Env, {op, map_set, [M, K, V]}) -> + Map = term_to_fate(Env, M), + Map#{term_to_fate(Env, K) => term_to_fate(Env, V)}; +term_to_fate(_Env, _) -> + throw(not_a_fate_value). -map_to_fate({op, map_set, [{var, _}, K, V]}) -> - #{term_to_fate(K) => term_to_fate(V)}; -map_to_fate({op, map_set, [Set, K, V]}) -> - Map = map_to_fate(Set), Map#{term_to_fate(K) => term_to_fate(V)}. +to_scode(Env, T) -> + try term_to_fate(T) of + V -> [push(?i(V))] + catch throw:not_a_fate_value -> + to_scode1(Env, T) + end. -to_scode(_Env, {lit, L}) -> +to_scode1(_Env, {lit, L}) -> [push(?i(lit_to_fate(L)))]; -to_scode(_Env, nil) -> +to_scode1(_Env, nil) -> [aeb_fate_ops:nil(?a)]; -to_scode(Env, {var, X}) -> +to_scode1(Env, {var, X}) -> [push(lookup_var(Env, X))]; -to_scode(Env, {con, Ar, I, As}) -> +to_scode1(Env, {con, Ar, I, As}) -> N = length(As), [[to_scode(notail(Env), A) || A <- As], aeb_fate_ops:variant(?a, ?i(Ar), ?i(I), ?i(N))]; -to_scode(Env, {tuple, As}) -> +to_scode1(Env, {tuple, As}) -> N = length(As), [[ to_scode(notail(Env), A) || A <- As ], tuple(N)]; -to_scode(Env, {proj, E, I}) -> +to_scode1(Env, {proj, E, I}) -> [to_scode(notail(Env), E), aeb_fate_ops:element_op(?a, ?i(I), ?a)]; -to_scode(Env, {set_proj, R, I, E}) -> +to_scode1(Env, {set_proj, R, I, E}) -> [to_scode(notail(Env), E), to_scode(notail(Env), R), aeb_fate_ops:setelement(?a, ?i(I), ?a, ?a)]; -to_scode(Env, {op, Op, Args}) -> +to_scode1(Env, {op, Op, Args}) -> call_to_scode(Env, op_to_scode(Op), Args); -to_scode(Env, {'let', X, {var, Y}, Body}) -> +to_scode1(Env, {'let', X, {var, Y}, Body}) -> Env1 = bind_var(X, lookup_var(Env, Y), Env), to_scode(Env1, Body); -to_scode(Env, {'let', X, Expr, Body}) -> +to_scode1(Env, {'let', 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) ]; -to_scode(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args}) -> +to_scode1(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args}) -> %% Tail-call to current function, f(e0..en). Compile to %% [ let xi = ei ] %% [ STORE argi xi ] @@ -274,17 +292,17 @@ to_scode(Env = #env{ current_function = Fun, tailpos = true }, {def, Fun, Args}) || {I, J} <- lists:zip(lists:seq(0, length(Vars) - 1), lists:reverse(Vars)) ], loop ]; -to_scode(Env, {def, Fun, Args}) -> +to_scode1(Env, {def, 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_scode(Env, {funcall, Fun, Args}) -> +to_scode1(Env, {funcall, Fun, Args}) -> call_to_scode(Env, [to_scode(Env, Fun), local_call(Env, ?a)], Args); -to_scode(Env, {builtin, B, Args}) -> +to_scode1(Env, {builtin, B, Args}) -> builtin_to_scode(Env, B, Args); -to_scode(Env, {remote, ArgsT, RetT, Ct, Fun, [Gas, Value | Args]}) -> +to_scode1(Env, {remote, ArgsT, RetT, Ct, Fun, [Gas, Value | Args]}) -> Lbl = make_function_id(Fun), {ArgTypes, RetType0} = typesig_to_scode([{"_", T} || T <- ArgsT], RetT), ArgType = ?i(aeb_fate_data:make_typerep({tuple, ArgTypes})), @@ -298,10 +316,16 @@ to_scode(Env, {remote, ArgsT, RetT, Ct, Fun, [Gas, Value | Args]}) -> call_to_scode(Env, Call, [Ct, Value, Gas | Args]) end; -to_scode(Env, {closure, Fun, FVs}) -> +to_scode1(_Env, {get_state, Reg}) -> + [push(?s(Reg))]; +to_scode1(Env, {set_state, Reg, Val}) -> + call_to_scode(Env, [{'STORE', ?s(Reg), ?a}, + tuple(0)], [Val]); + +to_scode1(Env, {closure, Fun, FVs}) -> to_scode(Env, {tuple, [{lit, {string, make_function_id(Fun)}}, FVs]}); -to_scode(Env, {switch, Case}) -> +to_scode1(Env, {switch, Case}) -> split_to_scode(Env, Case). local_call( Env, Fun) when Env#env.tailpos -> aeb_fate_ops:call_t(Fun); @@ -420,11 +444,6 @@ call_to_scode(Env, CallCode, Args) -> [[to_scode(notail(Env), A) || A <- lists:reverse(Args)], CallCode]. -builtin_to_scode(_Env, get_state, []) -> - [push(?s)]; -builtin_to_scode(Env, set_state, [_] = Args) -> - call_to_scode(Env, [{'STORE', ?s, ?a}, - tuple(0)], Args); builtin_to_scode(Env, chain_event, Args) -> call_to_scode(Env, [erlang:apply(aeb_fate_ops, log, lists:duplicate(length(Args), ?a)), tuple(0)], Args); @@ -672,11 +691,11 @@ pp_op(loop) -> "LOOP"; pp_op(I) -> aeb_fate_pp:format_op(I, #{}). -pp_arg(?i(I)) -> io_lib:format("~w", [I]); -pp_arg({arg, N}) -> io_lib:format("arg~p", [N]); -pp_arg({store, N}) -> io_lib:format("store~p", [N]); -pp_arg({var, N}) -> io_lib:format("var~p", [N]); -pp_arg(?a) -> "a". +pp_arg(?i(I)) -> io_lib:format("~w", [I]); +pp_arg({arg, N}) -> io_lib:format("arg~p", [N]); +pp_arg(?s(N)) -> io_lib:format("store~p", [N]); +pp_arg({var, N}) -> io_lib:format("var~p", [N]); +pp_arg(?a) -> "a". %% -- Analysis -- @@ -1419,7 +1438,7 @@ desugar_args(I) when is_tuple(I) -> list_to_tuple([Op | lists:map(fun desugar_arg/1, Args)]); desugar_args(I) -> I. -desugar_arg({store, N}) -> {var, -N}; +desugar_arg(?s(N)) -> {var, -N}; desugar_arg(A) -> A. %% -- Phase III -------------------------------------------------------------- @@ -1629,6 +1648,7 @@ tweak_returns(['RETURN', {'PUSH', A} | Code]) -> [{'RETURNR', A} | Code tweak_returns(['RETURN' | Code = [{'CALL_T', _} | _]]) -> Code; tweak_returns(['RETURN' | Code = [{'ABORT', _} | _]]) -> Code; tweak_returns(['RETURN' | Code = [{'EXIT', _} | _]]) -> Code; +tweak_returns(['RETURN' | Code = [loop | _]]) -> Code; tweak_returns(Code) -> Code. %% -- Split basic blocks at CALL instructions -- @@ -1642,8 +1662,7 @@ split_calls(Ref, [], Acc, Blocks) -> split_calls(Ref, [I | Code], Acc, Blocks) when element(1, I) == 'CALL'; element(1, I) == 'CALL_R'; element(1, I) == 'CALL_GR'; - element(1, I) == 'jumpif'; - I == loop -> + element(1, I) == 'jumpif' -> split_calls(make_ref(), Code, [], [{Ref, lists:reverse([I | Acc])} | Blocks]); split_calls(Ref, [{'ABORT', _} = I | _Code], Acc, Blocks) -> lists:reverse([{Ref, lists:reverse([I | Acc])} | Blocks]); diff --git a/src/aeso_parser.erl b/src/aeso_parser.erl index 06a3c43..c5f90cb 100644 --- a/src/aeso_parser.erl +++ b/src/aeso_parser.erl @@ -164,9 +164,7 @@ letdecl() -> letdef() -> choice(valdef(), fundef()). valdef() -> - choice( - ?RULE(id(), tok('='), body(), {letval, [], _1, type_wildcard(), _3}), - ?RULE(id(), tok(':'), type(), tok('='), body(), {letval, [], _1, _3, _5})). + ?RULE(pattern(), tok('='), body(), {letval, [], _1, _3}). fundef() -> choice( @@ -238,7 +236,7 @@ branch() -> ?RULE(pattern(), keyword('=>'), body(), {'case', _2, _1, _3}). pattern() -> - ?LET_P(E, expr500(), parse_pattern(E)). + ?LET_P(E, expr(), parse_pattern(E)). %% -- Expressions ------------------------------------------------------------ @@ -297,7 +295,7 @@ comprehension_if() -> ?RULE(keyword('if'), parens(expr()), {comprehension_if, _1, _2}). comprehension_bind() -> - ?RULE(id(), tok('<-'), expr(), {comprehension_bind, _1, _3}). + ?RULE(pattern(), tok('<-'), expr(), {comprehension_bind, _1, _3}). arg_expr() -> ?LAZY_P( @@ -349,7 +347,9 @@ record(Fs) -> bad_expr_err("Cannot use '@' in map construction", infix({lvalue, FAnn, LV}, {'@', Ann}, Id)); ({field, FAnn, LV, _}) -> bad_expr_err("Cannot use nested fields or keys in map construction", {lvalue, FAnn, LV}) end, - {map, Ann, lists:map(KV, Fs)} + {map, Ann, lists:map(KV, Fs)}; + record_or_map_error -> + {record_or_map_error, get_ann(hd(Fs)), Fs} end. record_or_map(Fields) -> @@ -361,9 +361,7 @@ record_or_map(Fields) -> case lists:usort(lists:map(Kind, Fields)) of [proj] -> record; [map_get] -> map; - _ -> - [{field, Ann, _, _} | _] = Fields, - bad_expr_err("Mixed record fields and map keys in", {record, Ann, Fields}) + _ -> record_or_map_error %% Defer error until type checking end. field_assignment() -> @@ -545,7 +543,9 @@ list_comp_e(Ann, Expr, Binds) -> {list_comp, Ann, Expr, Binds}. -spec parse_pattern(aeso_syntax:expr()) -> aeso_parse_lib:parser(aeso_syntax:pat()). parse_pattern({app, Ann, Con = {'::', _}, Es}) -> {app, Ann, Con, lists:map(fun parse_pattern/1, Es)}; -parse_pattern({app, Ann, Con = {con, _, _}, Es}) -> +parse_pattern({app, Ann, {'-', _}, [{int, _, N}]}) -> + {int, Ann, -N}; +parse_pattern({app, Ann, Con = {Tag, _, _}, Es}) when Tag == con; Tag == qcon -> {app, Ann, Con, lists:map(fun parse_pattern/1, Es)}; parse_pattern({tuple, Ann, Es}) -> {tuple, Ann, lists:map(fun parse_pattern/1, Es)}; @@ -553,7 +553,10 @@ parse_pattern({list, Ann, Es}) -> {list, Ann, lists:map(fun parse_pattern/1, Es)}; parse_pattern({record, Ann, Fs}) -> {record, Ann, lists:map(fun parse_field_pattern/1, Fs)}; +parse_pattern({typed, Ann, E, Type}) -> + {typed, Ann, parse_pattern(E), Type}; parse_pattern(E = {con, _, _}) -> E; +parse_pattern(E = {qcon, _, _}) -> E; parse_pattern(E = {id, _, _}) -> E; parse_pattern(E = {int, _, _}) -> E; parse_pattern(E = {bool, _, _}) -> E; diff --git a/src/aeso_pretty.erl b/src/aeso_pretty.erl index 2472ead..1979925 100644 --- a/src/aeso_pretty.erl +++ b/src/aeso_pretty.erl @@ -169,7 +169,7 @@ decl(D = {letfun, Attrs, _, _, _, _}) -> false -> "function" end, hsep(lists:map(Mod, Attrs) ++ [letdecl(Fun, D)]); -decl(D = {letval, _, _, _, _}) -> letdecl("let", D). +decl(D = {letval, _, _, _}) -> letdecl("let", D). -spec pragma(aeso_syntax:pragma()) -> doc(). pragma({compiler, Op, Ver}) -> @@ -193,8 +193,8 @@ name({tvar, _, Name}) -> text(Name); name({typed, _, Name, _}) -> name(Name). -spec letdecl(string(), aeso_syntax:letbind()) -> doc(). -letdecl(Let, {letval, _, F, T, E}) -> - block_expr(0, hsep([text(Let), typed(name(F), T), text("=")]), E); +letdecl(Let, {letval, _, P, E}) -> + block_expr(0, hsep([text(Let), expr(P), text("=")]), E); letdecl(Let, {letfun, _, F, Args, T, E}) -> block_expr(0, hsep([text(Let), typed(beside(name(F), args(Args)), T), text("=")]), E). @@ -305,6 +305,8 @@ expr_p(_, {tuple, _, Es}) -> tuple(lists:map(fun expr/1, Es)); expr_p(_, {list, _, Es}) -> list(lists:map(fun expr/1, Es)); +expr_p(_, {list_comp, _, E, Binds}) -> + list([follow(expr(E), hsep(text("|"), par(punctuate(text(","), lists:map(fun lc_bind/1, Binds)), 0)), 0)]); expr_p(_, {record, _, Fs}) -> record(lists:map(fun field/1, Fs)); expr_p(_, {map, Ann, KVs}) -> @@ -387,6 +389,13 @@ stmt_p({else, Else}) -> _ -> block_expr(200, text("else"), Else) end. +lc_bind({comprehension_bind, P, E}) -> + follow(hsep(expr(P), text("<-")), expr(E)); +lc_bind({comprehension_if, _, E}) -> + beside([text("if("), expr(E), text(")")]); +lc_bind(Let) -> + letdecl("let", Let). + -spec bin_prec(aeso_syntax:bin_op()) -> {integer(), integer(), integer()}. bin_prec('..') -> { 0, 0, 0}; %% Always printed inside '[ ]' bin_prec('=') -> { 0, 0, 0}; %% Always printed inside '[ ]' @@ -450,7 +459,7 @@ elim1(Get={map_get, _, _}) -> elim(Get); elim1(Get={map_get, _, _, _}) -> elim(Get). alt({'case', _, Pat, Body}) -> - block_expr(0, hsep(expr_p(500, Pat), text("=>")), Body). + block_expr(0, hsep(expr(Pat), text("=>")), Body). block_expr(_, Header, {block, _, Ss}) -> block(Header, statements(Ss)); @@ -460,7 +469,7 @@ block_expr(P, Header, E) -> statements(Stmts) -> above([ statement(S) || S <- Stmts ]). -statement(S = {letval, _, _, _, _}) -> letdecl("let", S); +statement(S = {letval, _, _, _}) -> letdecl("let", S); statement(S = {letfun, _, _, _, _, _}) -> letdecl("let", S); statement(E) -> expr(E). diff --git a/src/aeso_syntax.erl b/src/aeso_syntax.erl index 4eb52ef..3c7ce56 100644 --- a/src/aeso_syntax.erl +++ b/src/aeso_syntax.erl @@ -47,7 +47,7 @@ -type pragma() :: {compiler, '==' | '<' | '>' | '=<' | '>=', compiler_version()}. -type letbind() - :: {letval, ann(), id(), type(), expr()} + :: {letval, ann(), pat(), expr()} | {letfun, ann(), id(), [arg()], type(), expr()}. -type arg() :: {arg, ann(), id(), type()}. @@ -100,9 +100,8 @@ | {list, ann(), [expr()]} | {list_comp, ann(), expr(), [comprehension_exp()]} | {typed, ann(), expr(), type()} - | {record, ann(), [field(expr())]} - | {record, ann(), expr(), [field(expr())]} %% record update - | {map, ann(), expr(), [field(expr())]} %% map update + | {record_or_map(), ann(), [field(expr())]} + | {record_or_map(), ann(), expr(), [field(expr())]} %% record/map update | {map, ann(), [{expr(), expr()}]} | {map_get, ann(), expr(), expr()} | {map_get, ann(), expr(), expr(), expr()} @@ -111,7 +110,9 @@ | id() | qid() | con() | qcon() | constant(). --type comprehension_exp() :: [ {comprehension_bind, id(), expr()} +-type record_or_map() :: record | map | record_or_map_error. + +-type comprehension_exp() :: [ {comprehension_bind, pat(), expr()} | {comprehension_if, ann(), expr()} | letbind() ]. @@ -139,6 +140,7 @@ -type pat() :: {app, ann(), con() | op(), [pat()]} | {tuple, ann(), [pat()]} | {list, ann(), [pat()]} + | {typed, ann(), pat(), type()} | {record, ann(), [field(pat())]} | constant() | con() diff --git a/src/aeso_syntax_utils.erl b/src/aeso_syntax_utils.erl index 5aa43e9..b5618e5 100644 --- a/src/aeso_syntax_utils.erl +++ b/src/aeso_syntax_utils.erl @@ -48,7 +48,7 @@ fold(Alg = #alg{zero = Zero, plus = Plus, scoped = Scoped}, Fun, K, X) -> {type_decl, _, I, _} -> BindType(I); {type_def, _, I, _, D} -> Plus(BindType(I), Decl(D)); {fun_decl, _, _, T} -> Type(T); - {letval, _, F, T, E} -> Sum([BindExpr(F), Type(T), Expr(E)]); + {letval, _, P, E} -> Scoped(BindExpr(P), Expr(E)); {letfun, _, F, Xs, T, E} -> Sum([BindExpr(F), Type(T), Expr(Xs ++ [E])]); %% typedef() {alias_t, T} -> Type(T); @@ -76,8 +76,8 @@ fold(Alg = #alg{zero = Zero, plus = Plus, scoped = Scoped}, Fun, K, X) -> Plus(Expr(E), Scoped(BindExpr(I), Expr({list_comp, A, Y, R}))); {list_comp, A, Y, [{comprehension_if, _, E}|R]} -> Plus(Expr(E), Expr({list_comp, A, Y, R})); - {list_comp, A, Y, [D = {letval, _, F, _, _} | R]} -> - Plus(Decl(D), Scoped(BindExpr(F), Expr({list_comp, A, Y, R}))); + {list_comp, A, Y, [D = {letval, _, Pat, _} | R]} -> + Plus(Decl(D), Scoped(BindExpr(Pat), Expr({list_comp, A, Y, R}))); {list_comp, A, Y, [D = {letfun, _, F, _, _, _} | R]} -> Plus(Decl(D), Scoped(BindExpr(F), Expr({list_comp, A, Y, R}))); {typed, _, E, T} -> Plus(Expr(E), Type(T)); diff --git a/test/aeso_aci_tests.erl b/test/aeso_aci_tests.erl index ec6737c..d5010e3 100644 --- a/test/aeso_aci_tests.erl +++ b/test/aeso_aci_tests.erl @@ -106,7 +106,7 @@ aci_test_contract(Name) -> ok. check_stub(Stub, Options) -> - case aeso_parser:string(binary_to_list(Stub), Options) of + try aeso_parser:string(binary_to_list(Stub), Options) of Ast -> try %% io:format("AST: ~120p\n", [Ast]), @@ -117,9 +117,9 @@ check_stub(Stub, Options) -> _:R -> io:format("Error: ~p\n", [R]), error(R) - end; - {error, E} -> - io:format("Error: ~p\n", [E]), - error({parse_error, E}) + end + catch throw:{error, Errs} -> + _ = [ io:format("~s\n", [aeso_errors:pp(E)]) || E <- Errs ], + error({parse_errors, Errs}) end. diff --git a/test/aeso_compiler_tests.erl b/test/aeso_compiler_tests.erl index 5506da9..73869c1 100644 --- a/test/aeso_compiler_tests.erl +++ b/test/aeso_compiler_tests.erl @@ -138,6 +138,7 @@ compilable_contracts() -> "test", "builtin_bug", "builtin_map_get_bug", + "lc_record_bug", "nodeadcode", "deadcode", "variant_types", @@ -162,7 +163,9 @@ compilable_contracts() -> "payable", "unapplied_builtins", "underscore_number_literals", - "pairing_crypto" + "pairing_crypto", + "qualified_constructor", + "let_patterns" ]. not_yet_compilable(fate) -> []; @@ -596,6 +599,17 @@ failing_contracts() -> [<>]) + , ?TYPE_ERROR(bad_records, + [<>, + <>, + <> + ]) ]. -define(Path(File), "code_errors/" ??File). diff --git a/test/aeso_parser_tests.erl b/test/aeso_parser_tests.erl index 6b2fc5c..09c4c3f 100644 --- a/test/aeso_parser_tests.erl +++ b/test/aeso_parser_tests.erl @@ -4,6 +4,8 @@ -include_lib("eunit/include/eunit.hrl"). +id(X) -> X. + simple_contracts_test_() -> {foreach, fun() -> ok end, @@ -30,7 +32,7 @@ simple_contracts_test_() -> end, Parse = fun(S) -> try remove_line_numbers(parse_expr(S)) - catch _:_ -> ?assertMatch(ok, {parse_fail, S}) end + catch _:_ -> ?assertMatch(ok, id({parse_fail, S})) end end, CheckParens = fun(Expr) -> ?assertEqual(Parse(NoPar(Expr)), Parse(Par(Expr))) @@ -38,7 +40,6 @@ simple_contracts_test_() -> LeftAssoc = fun(Op) -> CheckParens({{a, Op, b}, Op, c}) end, RightAssoc = fun(Op) -> CheckParens({a, Op, {b, Op, c}}) end, NonAssoc = fun(Op) -> - OpAtom = list_to_atom(Op), ?assertThrow({error, [_]}, parse_expr(NoPar({a, Op, {b, Op, c}}))) end, Stronger = fun(Op1, Op2) -> @@ -77,7 +78,7 @@ parse_string(Text, Opts) -> aeso_parser:string(Text, Opts). parse_expr(Text) -> - [{letval, _, _, _, Expr}] = + [{letval, _, _, Expr}] = parse_string("let _ = " ++ Text), Expr. diff --git a/test/contracts/bad_records.aes b/test/contracts/bad_records.aes new file mode 100644 index 0000000..529e6f9 --- /dev/null +++ b/test/contracts/bad_records.aes @@ -0,0 +1,5 @@ +contract BadRecord = + entrypoint foo() = + let r = {x = 0, [0] = 1} + r{x = 0, [0] = 1} + r{} diff --git a/test/contracts/lc_record_bug.aes b/test/contracts/lc_record_bug.aes new file mode 100644 index 0000000..dcce24d --- /dev/null +++ b/test/contracts/lc_record_bug.aes @@ -0,0 +1,4 @@ +contract Foo = + record r = {x : int} + // Crashed in the backend due to missing type annotation on the lc body. + entrypoint lc(xs) = [ {x = x} | x <- xs ] diff --git a/test/contracts/let_patterns.aes b/test/contracts/let_patterns.aes new file mode 100644 index 0000000..9ba1ba6 --- /dev/null +++ b/test/contracts/let_patterns.aes @@ -0,0 +1,15 @@ +contract LetPatterns = + + record r = {x : int, y : int, b : bool} + + entrypoint test() = foo([1, 0], (2, 3), Some(4), {x = 5, y = 6, b = false}) + + entrypoint foo(xs : list(int), p : int * int, some : option(int), r : r) = + let x :: _ = xs + let (a, b) = p + let Some(n) = some + let {x = i, y = j} = r + x + a + b + n + i + j + + entrypoint lc(xs : list(option(int))) : list(int) = + [ x | Some(x) <- xs ] diff --git a/test/contracts/qualified_constructor.aes b/test/contracts/qualified_constructor.aes new file mode 100644 index 0000000..31a77a5 --- /dev/null +++ b/test/contracts/qualified_constructor.aes @@ -0,0 +1,8 @@ +namespace Foo = + datatype x = A | B(int) + +contract Bar = + entrypoint f(a : Foo.x) = + switch(a) + Foo.A => 0 + Foo.B(n) => n