QPQ-AG/sophia
11
0
Fork 0
Code Issues 43 Pull Requests 7 Actions Packages Projects Releases 16 Wiki Activity

First test work commit, don't touch

Browse Source
This commit is contained in:
Robert Virding
2018-12-22 01:23:40 +01:00
parent 3ceb8c38db
commit d4d02fd576
97 changed files with 10599 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/aeso_abi.erl
+255
View File
@@ -0,0 +1,255 @@
%%%-------------------------------------------------------------------
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc
%%% Encode and decode data and function calls according to
%%% Sophia-AEVM-ABI.
%%% @end
%%% Created : 25 Jan 2018
%%%
%%%-------------------------------------------------------------------
-module(aeso_abi).
-define(HASH_SIZE, 32).
-export([ old_create_calldata/3
, create_calldata/5
, check_calldata/2
, function_type_info/3
, function_type_hash/3
, arg_typerep_from_function/2
, type_hash_from_function_name/2
, typereps_from_type_hash/2
, function_name_from_type_hash/2
, get_function_hash_from_calldata/1
]).
-type hash() :: <<_:256>>. %% 256 = ?HASH_SIZE * 8.
-type function_name() :: binary(). %% String
-type typerep() :: aeso_sophia:type().
-type function_type_info() :: { FunctionHash :: hash()
, FunctionName :: function_name()
, ArgType :: aeso_sophia:heap() %% binary typerep
, OutType :: aeso_sophia:heap() %% binary typerep
}.
-type type_info() :: [function_type_info()].
-ifdef(COMMON_TEST).
-define(TEST_LOG(Format, Data),
try ct:log(Format, Data)
catch
%% Enable setting up node with "test" rebar profile.
error:undef -> ok
end).
-define(DEBUG_LOG(Format, Data), begin lager:debug(Format, Data), ?TEST_LOG(Format, Data) end).
-else.
-define(TEST_LOG(Format, Data), ok).
-define(DEBUG_LOG(Format, Data), lager:debug(Format, Data)).
-endif.
%%%===================================================================
%%% API
%%%===================================================================
%%%===================================================================
%%% Handle calldata
create_calldata(Contract, FunName, Args, ArgTypes, RetType) ->
case get_type_info_and_hash(Contract, FunName) of
{ok, TypeInfo, TypeHashInt} ->
Data = aeso_heap:to_binary({TypeHashInt, list_to_tuple(Args)}),
case check_calldata(Data, TypeInfo) of
{ok, CallDataType, OutType} ->
case check_given_type(FunName, ArgTypes, RetType, CallDataType, OutType) of
ok ->
{ok, Data, CallDataType, OutType};
{error, _} = Err ->
Err
end;
{error,_What} = Err -> Err
end;
{error, _} = Err -> Err
end.
get_type_info_and_hash(#{type_info := TypeInfo}, FunName) ->
FunBin = list_to_binary(FunName),
case type_hash_from_function_name(FunBin, TypeInfo) of
{ok, <<TypeHashInt:?HASH_SIZE/unit:8>>} -> {ok, TypeInfo, TypeHashInt};
{ok, _} -> {error, bad_type_hash};
{error, _} = Err -> Err
end.
%% Check that the given type matches the type from the metadata.
check_given_type(FunName, GivenArgs, GivenRet, CalldataType, ExpectRet) ->
{tuple, [word, {tuple, ExpectArgs}]} = CalldataType,
ReturnOk = if FunName == "init" -> true;
GivenRet == any -> true;
true -> GivenRet == ExpectRet
end,
ArgsOk = ExpectArgs == GivenArgs,
case ReturnOk andalso ArgsOk of
true -> ok;
false when FunName == "init" ->
{error, {init_args_mismatch,
{given, GivenArgs},
{expected, ExpectArgs}}};
false ->
{error, {call_type_mismatch,
{given, GivenArgs, '=>', GivenRet},
{expected, ExpectArgs, '=>', ExpectRet}}}
end.
-spec check_calldata(aeso_sophia:heap(), type_info()) ->
{'ok', typerep()} | {'error', atom()}.
check_calldata(CallData, TypeInfo) ->
%% The first element of the CallData should be the function name
case get_function_hash_from_calldata(CallData) of
{ok, Hash} ->
case typereps_from_type_hash(Hash, TypeInfo) of
{ok, ArgType, OutType} ->
try aeso_heap:from_binary({tuple, [word, ArgType]}, CallData) of
{ok, _Something} ->
{ok, {tuple, [word, ArgType]}, OutType};
{error, _} ->
{error, bad_call_data}
catch
_T:_E ->
?TEST_LOG("Error parsing call data: ~p", [{_T, _E}]),
{error, bad_call_data}
end;
{error, _} ->
?TEST_LOG("Unknown function hash ~p", [Hash]),
{error, unknown_function}
end;
{error, _What} ->
?TEST_LOG("Bad call data ~p", [_What]),
{error, bad_call_data}
end.
-spec get_function_hash_from_calldata(CallData::binary()) ->
{ok, binary()} | {error, term()}.
get_function_hash_from_calldata(CallData) ->
case aeso_heap:from_binary({tuple, [word]}, CallData) of
{ok, {HashInt}} -> {ok, <<HashInt:?HASH_SIZE/unit:8>>};
{error, _} = Error -> Error
end.
%%%===================================================================
%%% Handle type info from contract meta data
-spec function_type_info(function_name(), [typerep()], typerep()) ->
function_type_info().
function_type_info(Name, Args, OutType) ->
ArgType = {tuple, [T || {_, T} <- Args]},
{ function_type_hash(Name, ArgType, OutType)
, Name
, aeso_heap:to_binary(ArgType)
, aeso_heap:to_binary(OutType)
}.
-spec function_type_hash(function_name(), typerep(), typerep()) -> hash().
function_type_hash(Name, ArgType, OutType) when is_binary(Name) ->
Bin = iolist_to_binary([ Name
, aeso_heap:to_binary(ArgType)
, aeso_heap:to_binary(OutType)
]),
%% Calculate a 256 bit digest BLAKE2b hash value of a binary
{ok, Hash} = enacl:generichash(?HASH_SIZE, Bin),
Hash.
-spec arg_typerep_from_function(function_name(), type_info()) ->
{'ok', typerep()} | {'error', 'bad_type_data' | 'unknown_function'}.
arg_typerep_from_function(Function, TypeInfo) ->
case lists:keyfind(Function, 2, TypeInfo) of
{_TypeHash, Function, ArgTypeBin,_OutTypeBin} ->
case aeso_heap:from_binary(typerep, ArgTypeBin) of
{ok, ArgType} -> {ok, ArgType};
{error,_} -> {error, bad_type_data}
end;
false ->
{error, unknown_function}
end.
-spec typereps_from_type_hash(hash(), type_info()) ->
{'ok', typerep()} | {'error', 'bad_type_data' | 'unknown_function'}.
typereps_from_type_hash(TypeHash, TypeInfo) ->
case lists:keyfind(TypeHash, 1, TypeInfo) of
{TypeHash,_Function, ArgTypeBin, OutTypeBin} ->
case {aeso_heap:from_binary(typerep, ArgTypeBin),
aeso_heap:from_binary(typerep, OutTypeBin)} of
{{ok, ArgType}, {ok, OutType}} -> {ok, ArgType, OutType};
{_, _} -> {error, bad_type_data}
end;
false ->
{error, unknown_function}
end.
-spec function_name_from_type_hash(hash(), type_info()) ->
{'ok', function_name()}
| {'error', 'unknown_function'}.
function_name_from_type_hash(TypeHash, TypeInfo) ->
case lists:keyfind(TypeHash, 1, TypeInfo) of
{TypeHash, Function,_ArgTypeBin,_OutTypeBin} ->
{ok, Function};
false ->
{error, unknown_function}
end.
-spec type_hash_from_function_name(function_name(), type_info()) ->
{'ok', hash()}
| {'error', 'unknown_function'}.
type_hash_from_function_name(Name, TypeInfo) ->
case lists:keyfind(Name, 2, TypeInfo) of
{TypeHash, Name,_ArgTypeBin,_OutTypeBin} ->
{ok, TypeHash};
false ->
{error, unknown_function}
end.
%% -- Old calldata creation. Kept for backwards compatibility. ---------------
old_create_calldata(Contract, Function, Argument) when is_map(Contract) ->
case aeso_constants:string(Argument) of
{ok, {tuple, _, _} = Tuple} ->
old_encode_call(Contract, Function, Tuple);
{ok, {unit, _} = Tuple} ->
old_encode_call(Contract, Function, Tuple);
{ok, ParsedArgument} ->
%% The Sophia compiler does not parse a singleton tuple (42) as a tuple,
%% Wrap it in a tuple.
old_encode_call(Contract, Function, {tuple, [], [ParsedArgument]});
{error, _} ->
{error, argument_syntax_error}
end.
%% Call takes one arument.
%% Use a tuple to pass multiple arguments.
old_encode_call(Contract, Function, ArgumentAst) ->
Argument = old_ast_to_erlang(ArgumentAst),
case get_type_info_and_hash(Contract, Function) of
{ok, TypeInfo, TypeHashInt} ->
Data = aeso_heap:to_binary({TypeHashInt, Argument}),
case check_calldata(Data, TypeInfo) of
{ok, CallDataType, OutType} ->
{ok, Data, CallDataType, OutType};
{error, _} = Err ->
Err
end;
{error, _} = Err -> Err
end.
old_ast_to_erlang({int, _, N}) -> N;
old_ast_to_erlang({hash, _, <<N:?HASH_SIZE/unit:8>>}) -> N;
old_ast_to_erlang({hash, _, <<Hi:256, Lo:256>>}) -> {Hi, Lo}; %% signature
old_ast_to_erlang({bool, _, true}) -> 1;
old_ast_to_erlang({bool, _, false}) -> 0;
old_ast_to_erlang({string, _, Bin}) -> Bin;
old_ast_to_erlang({unit, _}) -> {};
old_ast_to_erlang({con, _, "None"}) -> none;
old_ast_to_erlang({app, _, {con, _, "Some"}, [A]}) -> {some, old_ast_to_erlang(A)};
old_ast_to_erlang({tuple, _, Elems}) ->
list_to_tuple(lists:map(fun old_ast_to_erlang/1, Elems));
old_ast_to_erlang({list, _, Elems}) ->
lists:map(fun old_ast_to_erlang/1, Elems);
old_ast_to_erlang({map, _, Elems}) ->
maps:from_list([ {old_ast_to_erlang(element(1, Elem)), old_ast_to_erlang(element(2, Elem))}
|| Elem <- Elems ]).
src/aeso_ast.erl
+27
View File
@@ -0,0 +1,27 @@
-module(aeso_ast).
-export([int/2,
line/1,
pp/1,
pp_typed/1,
symbol/2,
symbol_name/1
]).
symbol(Line, Chars) -> {symbol, Line, Chars}.
int(Line, Int) -> {'Int', Line, Int}.
line({symbol, Line, _}) -> Line.
symbol_name({symbol, _, Name}) -> Name.
pp(Ast) ->
%% TODO: Actually do *Pretty* printing.
io:format("~p~n", [Ast]).
pp_typed(TypedAst) ->
String = prettypr:format(aeso_pretty:decls(TypedAst, [show_generated])),
%%io:format("Typed tree:\n~p\n",[TypedAst]),
io:format("Type info:\n~s\n",[String]).
src/aeso_ast_infer_types.erl
+1662
View File
File diff suppressed because it is too large Load Diff
src/aeso_ast_to_icode.erl
+711
View File
@@ -0,0 +1,711 @@
%%%-------------------------------------------------------------------
%%% @author Happi (Erik Stenman)
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc
%%% Compiler from Aeterinty Sophia language to the Aeternity VM, aevm.
%%% @end
%%% Created : 21 Dec 2017
%%%
%%%-------------------------------------------------------------------
-module(aeso_ast_to_icode).
-export([ast_typerep/1, ast_typerep/2, type_value/1,
convert_typed/2, prim_call/5]).
-include_lib("aebytecode/include/aeb_opcodes.hrl").
-include("aeso_icode.hrl").
-spec convert_typed(aeso_syntax:ast(), list()) -> aeso_icode:icode().
convert_typed(TypedTree, Options) ->
code(TypedTree, aeso_icode:new(Options)).
code([{contract, _Attribs, {con, _, Name}, Code}|Rest], Icode) ->
NewIcode = contract_to_icode(Code,
aeso_icode:set_name(Name, Icode)),
code(Rest, NewIcode);
code([], Icode) ->
add_default_init_function(add_builtins(Icode)).
%% Generate error on correct format.
gen_error(Error) ->
error({code_errors, [Error]}).
%% Create default init function (only if state is unit).
add_default_init_function(Icode = #{functions := Funs, state_type := State}) ->
case lists:keymember("init", 1, Funs) of
true -> Icode;
false when State /= {tuple, []} -> gen_error(missing_init_function);
false ->
Type = {tuple, [typerep, {tuple, []}]},
Value = #tuple{ cpts = [type_value({tuple, []}), {tuple, []}] },
DefaultInit = {"init", [], [], Value, Type},
Icode#{ functions => [DefaultInit | Funs] }
end.
-spec contract_to_icode(aeso_syntax:ast(), aeso_icode:icode()) ->
aeso_icode:icode().
contract_to_icode([{type_def, _Attrib, {id, _, Name}, Args, Def} | Rest],
Icode = #{ types := Types, constructors := Constructors }) ->
TypeDef = make_type_def(Args, Def, Icode),
NewConstructors =
case Def of
{variant_t, Cons} ->
Tags = lists:seq(0, length(Cons) - 1),
GetName = fun({constr_t, _, {con, _, C}, _}) -> C end,
maps:from_list([ {GetName(Con), Tag} || {Tag, Con} <- lists:zip(Tags, Cons) ]);
_ -> #{}
end,
Icode1 = Icode#{ types := Types#{ Name => TypeDef },
constructors := maps:merge(Constructors, NewConstructors) },
Icode2 = case Name of
"state" when Args == [] -> Icode1#{ state_type => ast_typerep(Def, Icode) };
"state" -> gen_error(state_type_cannot_be_parameterized);
"event" when Args == [] -> Icode1#{ event_type => Def };
"event" -> gen_error(event_type_cannot_be_parameterized);
_ -> Icode1
end,
contract_to_icode(Rest, Icode2);
contract_to_icode([{letfun, Attrib, Name, Args, _What, Body={typed,_,_,T}}|Rest], Icode) ->
FunAttrs = [ stateful || proplists:get_value(stateful, Attrib, false) ] ++
[ private || proplists:get_value(private, Attrib, false) orelse
proplists:get_value(internal, Attrib, false) ],
%% TODO: Handle types
FunName = ast_id(Name),
%% TODO: push funname to env
FunArgs = ast_args(Args, [], Icode),
%% TODO: push args to env
{FunBody, TypeRep} =
case FunName of
"init" ->
%% Pair the initial state with a typerep for the state (TODO: until we have the state type in some contract metadata)
#{ state_type := StateType } = Icode,
{#tuple{ cpts = [type_value(StateType), ast_body(Body, Icode)] },
{tuple, [typerep, ast_typerep(T, Icode)]}};
_ -> {ast_body(Body, Icode), ast_typerep(T, Icode)}
end,
NewIcode = ast_fun_to_icode(FunName, FunAttrs, FunArgs, FunBody, TypeRep, Icode),
contract_to_icode(Rest, NewIcode);
contract_to_icode([{letrec,_,Defs}|Rest], Icode) ->
%% OBS! This code ignores the letrec structure of the source,
%% because the back end treats ALL declarations as recursive! We
%% need to decide whether to (a) modify the back end to respect
%% the letrec structure, or (b) (preferably) modify the front end
%% just to parse a list of (mutually recursive) definitions.
contract_to_icode(Defs++Rest, Icode);
contract_to_icode([], Icode) -> Icode;
contract_to_icode(Code, Icode) ->
lager:debug("Unhandled code ~p~n",[Code]),
Icode.
ast_id({id, _, Id}) -> Id.
ast_args([{arg, _, Name, Type}|Rest], Acc, Icode) ->
ast_args(Rest, [{ast_id(Name), ast_type(Type, Icode)}| Acc], Icode);
ast_args([], Acc, _Icode) -> lists:reverse(Acc).
ast_type(T, Icode) ->
ast_typerep(T, Icode).
-define(id_app(Fun, Args, ArgTypes, OutType),
{app, _, {typed, _, {id, _, Fun}, {fun_t, _, _, ArgTypes, OutType}}, Args}).
-define(qid_app(Fun, Args, ArgTypes, OutType),
{app, _, {typed, _, {qid, _, Fun}, {fun_t, _, _, ArgTypes, OutType}}, Args}).
-define(oracle_t(Q, R), {app_t, _, {id, _, "oracle"}, [Q, R]}).
-define(query_t(Q, R), {app_t, _, {id, _, "oracle_query"}, [Q, R]}).
-define(option_t(A), {app_t, _, {id, _, "option"}, [A]}).
-define(map_t(K, V), {app_t, _, {id, _, "map"}, [K, V]}).
ast_body(?qid_app(["Chain","spend"], [To, Amount], _, _), Icode) ->
prim_call(?PRIM_CALL_SPEND, ast_body(Amount, Icode), [ast_body(To, Icode)], [word], {tuple, []});
ast_body(?qid_app(["Chain","event"], [Event], _, _), Icode) ->
aeso_builtins:check_event_type(Icode),
builtin_call({event, maps:get(event_type, Icode)}, [ast_body(Event, Icode)]);
%% Chain environment
ast_body(?qid_app(["Chain", "balance"], [Address], _, _), Icode) ->
#prim_balance{ address = ast_body(Address, Icode) };
ast_body(?qid_app(["Chain", "block_hash"], [Height], _, _), Icode) ->
#prim_block_hash{ height = ast_body(Height, Icode) };
ast_body(?qid_app(["Call", "gas_left"], [], _, _), _Icode) ->
prim_gas_left;
ast_body({qid, _, ["Contract", "address"]}, _Icode) -> prim_contract_address;
ast_body({qid, _, ["Contract", "balance"]}, _Icode) -> #prim_balance{ address = prim_contract_address };
ast_body({qid, _, ["Call", "origin"]}, _Icode) -> prim_call_origin;
ast_body({qid, _, ["Call", "caller"]}, _Icode) -> prim_caller;
ast_body({qid, _, ["Call", "value"]}, _Icode) -> prim_call_value;
ast_body({qid, _, ["Call", "gas_price"]}, _Icode) -> prim_gas_price;
ast_body({qid, _, ["Chain", "coinbase"]}, _Icode) -> prim_coinbase;
ast_body({qid, _, ["Chain", "timestamp"]}, _Icode) -> prim_timestamp;
ast_body({qid, _, ["Chain", "block_height"]}, _Icode) -> prim_block_height;
ast_body({qid, _, ["Chain", "difficulty"]}, _Icode) -> prim_difficulty;
ast_body({qid, _, ["Chain", "gas_limit"]}, _Icode) -> prim_gas_limit;
%% TODO: eta expand!
ast_body({qid, _, ["Chain", "balance"]}, _Icode) ->
gen_error({underapplied_primitive, 'Chain.balance'});
ast_body({qid, _, ["Chain", "block_hash"]}, _Icode) ->
gen_error({underapplied_primitive, 'Chain.block_hash'});
ast_body({qid, _, ["Chain", "spend"]}, _Icode) ->
gen_error({underapplied_primitive, 'Chain.spend'});
%% State
ast_body({id, _, "state"}, _Icode) -> prim_state;
ast_body(?id_app("put", [NewState], _, _), Icode) ->
#prim_put{ state = ast_body(NewState, Icode) };
ast_body({id, _, "put"}, _Icode) ->
gen_error({underapplied_primitive, put}); %% TODO: eta
%% Abort
ast_body(?id_app("abort", [String], _, _), Icode) ->
#funcall{ function = #var_ref{ name = {builtin, abort} },
args = [ast_body(String, Icode)] };
%% Oracles
ast_body(?qid_app(["Oracle", "register"], Args, _, ?oracle_t(QType, RType)), Icode) ->
{Sign, [Acct, QFee, TTL]} = get_signature_arg(Args),
prim_call(?PRIM_CALL_ORACLE_REGISTER, #integer{value = 0},
[ast_body(Acct, Icode), ast_body(Sign, Icode), ast_body(QFee, Icode), ast_body(TTL, Icode),
ast_type_value(QType, Icode), ast_type_value(RType, Icode)],
[word, sign_t(), word, ttl_t(Icode), typerep, typerep], word);
ast_body(?qid_app(["Oracle", "query_fee"], [Oracle], _, _), Icode) ->
prim_call(?PRIM_CALL_ORACLE_QUERY_FEE, #integer{value = 0},
[ast_body(Oracle, Icode)], [word], word);
ast_body(?qid_app(["Oracle", "query"], [Oracle, Q, QFee, QTTL, RTTL], [_, QType, _, _, _], _), Icode) ->
prim_call(?PRIM_CALL_ORACLE_QUERY, ast_body(QFee, Icode),
[ast_body(Oracle, Icode), ast_body(Q, Icode), ast_body(QTTL, Icode), ast_body(RTTL, Icode)],
[word, ast_type(QType, Icode), ttl_t(Icode), ttl_t(Icode)], word);
ast_body(?qid_app(["Oracle", "extend"], Args, _, _), Icode) ->
{Sign, [Oracle, TTL]} = get_signature_arg(Args),
prim_call(?PRIM_CALL_ORACLE_EXTEND, #integer{value = 0},
[ast_body(Oracle, Icode), ast_body(Sign, Icode), ast_body(TTL, Icode)],
[word, sign_t(), ttl_t(Icode)], {tuple, []});
ast_body(?qid_app(["Oracle", "respond"], Args, [_, _, RType], _), Icode) ->
{Sign, [Oracle, Query, R]} = get_signature_arg(Args),
prim_call(?PRIM_CALL_ORACLE_RESPOND, #integer{value = 0},
[ast_body(Oracle, Icode), ast_body(Query, Icode), ast_body(Sign, Icode), ast_body(R, Icode)],
[word, word, sign_t(), ast_type(RType, Icode)], {tuple, []});
ast_body(?qid_app(["Oracle", "get_question"], [Oracle, Q], [_, ?query_t(QType, _)], _), Icode) ->
prim_call(?PRIM_CALL_ORACLE_GET_QUESTION, #integer{value = 0},
[ast_body(Oracle, Icode), ast_body(Q, Icode)], [word, word], ast_type(QType, Icode));
ast_body(?qid_app(["Oracle", "get_answer"], [Oracle, Q], [_, ?query_t(_, RType)], _), Icode) ->
prim_call(?PRIM_CALL_ORACLE_GET_ANSWER, #integer{value = 0},
[ast_body(Oracle, Icode), ast_body(Q, Icode)], [word, word], aeso_icode:option_typerep(ast_type(RType, Icode)));
ast_body({qid, _, ["Oracle", "register"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.register'});
ast_body({qid, _, ["Oracle", "query"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.query'});
ast_body({qid, _, ["Oracle", "extend"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.extend'});
ast_body({qid, _, ["Oracle", "respond"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.respond'});
ast_body({qid, _, ["Oracle", "query_fee"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.query_fee'});
ast_body({qid, _, ["Oracle", "get_answer"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.get_answer'});
ast_body({qid, _, ["Oracle", "get_question"]}, _Icode) -> gen_error({underapplied_primitive, 'Oracle.get_question'});
%% Name service
ast_body(?qid_app(["AENS", "resolve"], [Name, Key], _, ?option_t(Type)), Icode) ->
case is_monomorphic(Type) of
true ->
case ast_type(Type, Icode) of
T when T == word; T == string -> ok;
_ -> gen_error({invalid_result_type, 'AENS.resolve', Type})
end,
prim_call(?PRIM_CALL_AENS_RESOLVE, #integer{value = 0},
[ast_body(Name, Icode), ast_body(Key, Icode), ast_type_value(Type, Icode)],
[string, string, typerep], aeso_icode:option_typerep(ast_type(Type, Icode)));
false ->
gen_error({unresolved_result_type, 'AENS.resolve', Type})
end;
ast_body(?qid_app(["AENS", "preclaim"], Args, _, _), Icode) ->
{Sign, [Addr, CHash]} = get_signature_arg(Args),
prim_call(?PRIM_CALL_AENS_PRECLAIM, #integer{value = 0},
[ast_body(Addr, Icode), ast_body(CHash, Icode), ast_body(Sign, Icode)],
[word, word, sign_t()], {tuple, []});
ast_body(?qid_app(["AENS", "claim"], Args, _, _), Icode) ->
{Sign, [Addr, Name, Salt]} = get_signature_arg(Args),
prim_call(?PRIM_CALL_AENS_CLAIM, #integer{value = 0},
[ast_body(Addr, Icode), ast_body(Name, Icode), ast_body(Salt, Icode), ast_body(Sign, Icode)],
[word, string, word, sign_t()], {tuple, []});
ast_body(?qid_app(["AENS", "transfer"], Args, _, _), Icode) ->
{Sign, [FromAddr, ToAddr, NameHash]} = get_signature_arg(Args),
prim_call(?PRIM_CALL_AENS_TRANSFER, #integer{value = 0},
[ast_body(FromAddr, Icode), ast_body(ToAddr, Icode), ast_body(NameHash, Icode), ast_body(Sign, Icode)],
[word, word, word, sign_t()], {tuple, []});
ast_body(?qid_app(["AENS", "revoke"], Args, _, _), Icode) ->
{Sign, [Addr, NameHash]} = get_signature_arg(Args),
prim_call(?PRIM_CALL_AENS_REVOKE, #integer{value = 0},
[ast_body(Addr, Icode), ast_body(NameHash, Icode), ast_body(Sign, Icode)],
[word, word, sign_t()], {tuple, []});
ast_body({qid, _, ["AENS", "resolve"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.resolve'});
ast_body({qid, _, ["AENS", "preclaim"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.preclaim'});
ast_body({qid, _, ["AENS", "claim"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.claim'});
ast_body({qid, _, ["AENS", "transfer"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.transfer'});
ast_body({qid, _, ["AENS", "revoke"]}, _Icode) -> gen_error({underapplied_primitive, 'AENS.revoke'});
%% Maps
%% -- map lookup m[k]
ast_body({map_get, _, Map, Key}, Icode) ->
{_, ValType} = check_monomorphic_map(Map, Icode),
Fun = {map_get, ast_typerep(ValType, Icode)},
builtin_call(Fun, [ast_body(Map, Icode), ast_body(Key, Icode)]);
%% -- map lookup_default m[k = v]
ast_body({map_get, _, Map, Key, Val}, Icode) ->
{_, ValType} = check_monomorphic_map(Map, Icode),
Fun = {map_lookup_default, ast_typerep(ValType, Icode)},
builtin_call(Fun, [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Val, Icode)]);
%% -- lookup functions
ast_body(?qid_app(["Map", "lookup"], [Key, Map], _, _), Icode) ->
map_get(Key, Map, Icode);
ast_body(?qid_app(["Map", "lookup_default"], [Key, Map, Val], _, _), Icode) ->
{_, ValType} = check_monomorphic_map(Map, Icode),
Fun = {map_lookup_default, ast_typerep(ValType, Icode)},
builtin_call(Fun, [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Val, Icode)]);
ast_body(?qid_app(["Map", "member"], [Key, Map], _, _), Icode) ->
builtin_call(map_member, [ast_body(Map, Icode), ast_body(Key, Icode)]);
ast_body(?qid_app(["Map", "size"], [Map], _, _), Icode) ->
builtin_call(map_size, [ast_body(Map, Icode)]);
ast_body(?qid_app(["Map", "delete"], [Key, Map], _, _), Icode) ->
map_del(Key, Map, Icode);
%% -- map conversion to/from list
ast_body(App = ?qid_app(["Map", "from_list"], [List], _, MapType), Icode) ->
Ann = aeso_syntax:get_ann(App),
{KeyType, ValType} = check_monomorphic_map(Ann, MapType, Icode),
builtin_call(map_from_list, [ast_body(List, Icode), map_empty(KeyType, ValType, Icode)]);
ast_body(?qid_app(["Map", "to_list"], [Map], _, _), Icode) ->
map_tolist(Map, Icode);
ast_body({qid, _, ["Map", "from_list"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.from_list'});
%% ast_body({qid, _, ["Map", "to_list"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.to_list'});
ast_body({qid, _, ["Map", "lookup"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.lookup'});
ast_body({qid, _, ["Map", "lookup_default"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.lookup_default'});
ast_body({qid, _, ["Map", "member"]}, _Icode) -> gen_error({underapplied_primitive, 'Map.member'});
%% -- map construction { k1 = v1, k2 = v2 }
ast_body({typed, Ann, {map, _, KVs}, MapType}, Icode) ->
{KeyType, ValType} = check_monomorphic_map(Ann, MapType, Icode),
lists:foldr(fun({K, V}, Map) ->
builtin_call(map_put, [Map, ast_body(K, Icode), ast_body(V, Icode)])
end, map_empty(KeyType, ValType, Icode), KVs);
%% -- map update m { [k] = v } or m { [k] @ x = f(x) } or m { [k = v] @ x = f(x) }
ast_body({map, _, Map, []}, Icode) -> ast_body(Map, Icode);
ast_body({map, _, Map, [Upd]}, Icode) ->
case Upd of
{field, _, [{map_get, _, Key}], Val} ->
map_put(Key, Val, Map, Icode);
{field_upd, _, [{map_get, _, Key}], ValFun} ->
map_upd(Key, ValFun, Map, Icode);
{field_upd, _, [{map_get, _, Key, Val}], ValFun} ->
map_upd(Key, Val, ValFun, Map, Icode)
end;
ast_body({map, Ann, Map, [Upd | Upds]}, Icode) ->
ast_body({map, Ann, {map, Ann, Map, [Upd]}, Upds}, Icode);
%% Strings
%% -- String length
ast_body(?qid_app(["String", "length"], [String], _, _), Icode) ->
#funcall{ function = #var_ref{ name = {builtin, string_length} },
args = [ast_body(String, Icode)] };
%% -- String concat
ast_body(?qid_app(["String", "concat"], [String1, String2], _, _), Icode) ->
#funcall{ function = #var_ref{ name = {builtin, string_concat} },
args = [ast_body(String1, Icode), ast_body(String2, Icode)] };
%% -- String hash (sha3)
ast_body(?qid_app(["String", "sha3"], [String], _, _), Icode) ->
#unop{ op = 'sha3', rand = ast_body(String, Icode) };
%% -- Conversion
ast_body(?qid_app(["Int", "to_str"], [Int], _, _), Icode) ->
builtin_call(int_to_str, [ast_body(Int, Icode)]);
ast_body(?qid_app(["Address", "to_str"], [Addr], _, _), Icode) ->
builtin_call(addr_to_str, [ast_body(Addr, Icode)]);
%% Other terms
ast_body({id, _, Name}, _Icode) ->
%% TODO Look up id in env
#var_ref{name = Name};
ast_body({bool, _, Bool}, _Icode) -> %BOOL as ints
Value = if Bool -> 1 ; true -> 0 end,
#integer{value = Value};
ast_body({int, _, Value}, _Icode) ->
#integer{value = Value};
ast_body({hash, _, Hash}, _Icode) ->
case Hash of
<<Value:32/unit:8>> -> %% address
#integer{value = Value};
<<Hi:32/unit:8, Lo:32/unit:8>> -> %% signature
#tuple{cpts = [#integer{value = Hi},
#integer{value = Lo}]}
end;
ast_body({string,_,Bin}, _Icode) ->
Cpts = [size(Bin) | aeso_memory:binary_to_words(Bin)],
#tuple{cpts = [#integer{value=X} || X <- Cpts]};
ast_body({tuple,_,Args}, Icode) ->
#tuple{cpts = [ast_body(A, Icode) || A <- Args]};
ast_body({list,_,Args}, Icode) ->
#list{elems = [ast_body(A, Icode) || A <- Args]};
%% Typed contract calls
ast_body({proj, _, {typed, _, Addr, {con, _, _}}, {id, _, "address"}}, Icode) ->
ast_body(Addr, Icode); %% Values of contract types _are_ addresses.
ast_body({app, _, {typed, _, {proj, _, {typed, _, Addr, {con, _, Contract}}, {id, _, FunName}},
{fun_t, _, NamedT, ArgsT, OutT}}, Args0}, Icode) ->
NamedArgs = [Arg || Arg = {named_arg, _, _, _} <- Args0],
Args = Args0 -- NamedArgs,
ArgOpts = [ {Name, ast_body(Value, Icode)} || {named_arg, _, {id, _, Name}, Value} <- NamedArgs ],
Defaults = [ {Name, ast_body(Default, Icode)} || {named_arg_t, _, {id, _, Name}, _, Default} <- NamedT ],
%% TODO: eta expand
length(Args) /= length(ArgsT) andalso
gen_error({underapplied_contract_call,
string:join([Contract, FunName], ".")}),
ArgsI = [ ast_body(Arg, Icode) || Arg <- Args ],
ArgType = ast_typerep({tuple_t, [], ArgsT}),
Gas = proplists:get_value("gas", ArgOpts ++ Defaults),
Value = proplists:get_value("value", ArgOpts ++ Defaults),
OutType = ast_typerep(OutT, Icode),
<<TypeHash:256>> = aeso_abi:function_type_hash(list_to_binary(FunName), ArgType, OutType),
%% The function is represented by its type hash (which includes the name)
Fun = #integer{value = TypeHash},
#prim_call_contract{
address = ast_body(Addr, Icode),
gas = Gas,
value = Value,
arg = #tuple{cpts = [Fun, #tuple{ cpts = ArgsI }]},
%% The type check is implicitly done by using the type hash as the
%% entrypoint on the callee side.
type_hash= #integer{value = 0}
};
ast_body({proj, _, {typed, _, _, {con, _, Contract}}, {id, _, FunName}}, _Icode) ->
gen_error({underapplied_contract_call,
string:join([Contract, FunName], ".")});
ast_body({con, _, Name}, Icode) ->
Tag = aeso_icode:get_constructor_tag(Name, Icode),
#tuple{cpts = [#integer{value = Tag}]};
ast_body({app, _, {typed, _, {con, _, Name}, _}, Args}, Icode) ->
Tag = aeso_icode:get_constructor_tag(Name, Icode),
#tuple{cpts = [#integer{value = Tag} | [ ast_body(Arg, Icode) || Arg <- Args ]]};
ast_body({app,As,Fun,Args}, Icode) ->
case aeso_syntax:get_ann(format, As) of
infix ->
{Op, _} = Fun,
[A, B] = Args,
ast_binop(Op, As, A, B, Icode);
prefix ->
{Op, _} = Fun,
[A] = Args,
#unop{op = Op, rand = ast_body(A, Icode)};
_ ->
#funcall{function=ast_body(Fun, Icode),
args=[ast_body(A, Icode) || A <- Args]}
end;
ast_body({'if',_,Dec,Then,Else}, Icode) ->
#ifte{decision = ast_body(Dec, Icode)
,then = ast_body(Then, Icode)
,else = ast_body(Else, Icode)};
ast_body({switch,_,A,Cases}, Icode) ->
%% let's assume the parser has already ensured that only valid
%% patterns appear in cases.
#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) ->
#switch{expr=ast_body(E, Icode),
cases=[{ast_body(Pat, Icode),ast_body({block,As,Rest}, Icode)}]};
ast_body({block,_,[]}, _Icode) ->
#tuple{cpts=[]};
ast_body({block,_,[E]}, Icode) ->
ast_body(E, Icode);
ast_body({block,As,[E|Rest]}, Icode) ->
#switch{expr=ast_body(E, Icode),
cases=[{#var_ref{name="_"},ast_body({block,As,Rest}, Icode)}]};
ast_body({lam,_,Args,Body}, Icode) ->
#lambda{args=[#arg{name = ast_id(P), type = ast_type(T, Icode)} || {arg,_,P,T} <- Args],
body=ast_body(Body, Icode)};
ast_body({typed,_,{record,Attrs,Fields},{record_t,DefFields}}, Icode) ->
%% Compile as a tuple with the fields in the order they appear in the definition.
NamedField = fun({field, _, [{proj, _, {id, _, Name}}], E}) -> {Name, E} end,
NamedFields = lists:map(NamedField, Fields),
#tuple{cpts =
[case proplists:get_value(Name,NamedFields) of
undefined ->
lager:debug("~p not in ~p\n", [Name, NamedFields]),
Line = aeso_syntax:get_ann(line, Attrs),
#missing_field{format = "Missing field in record: ~s (on line ~p)\n",
args = [Name,Line]};
E ->
ast_body(E, Icode)
end
|| {field_t,_,{id,_,Name},_} <- DefFields]};
ast_body({typed,_,{record,Attrs,_Fields},T}, _Icode) ->
gen_error({record_has_bad_type,Attrs,T});
ast_body({proj,_,{typed,_,Record,{record_t,Fields}},{id,_,FieldName}}, Icode) ->
[Index] = [I
|| {I,{field_t,_,{id,_,Name},_}} <-
lists:zip(lists:seq(1,length(Fields)),Fields),
Name==FieldName],
#binop{op = '!', left = #integer{value = 32*(Index-1)}, right = ast_body(Record, Icode)};
ast_body({record, Attrs, {typed, _, Record, RecType={record_t, Fields}}, Update}, Icode) ->
UpdatedName = fun({field, _, [{proj, _, {id, _, Name}}], _}) -> Name;
({field_upd, _, [{proj, _, {id, _, Name}}], _}) -> Name
end,
UpdatedNames = lists:map(UpdatedName, Update),
Rec = {typed, Attrs, {id, Attrs, "_record"}, RecType},
CompileUpdate =
fun(Fld={field, _, _, _}) -> Fld;
({field_upd, Ann, LV=[{proj, Ann1, P}], Fun}) ->
{field, Ann, LV, {app, Ann, Fun, [{proj, Ann1, Rec, P}]}}
end,
#switch{expr=ast_body(Record, Icode),
cases=[{#var_ref{name = "_record"},
ast_body({typed, Attrs,
{record, Attrs,
lists:map(CompileUpdate, Update) ++
[{field, Attrs, [{proj, Attrs, {id, Attrs, Name}}],
{proj, Attrs, Rec, {id, Attrs, Name}}}
|| {field_t, _, {id, _, Name}, _} <- Fields,
not lists:member(Name, UpdatedNames)]},
RecType}, Icode)}
]};
ast_body({typed, _, Body, _}, Icode) ->
ast_body(Body, Icode).
ast_binop(Op, Ann, {typed, _, A, Type}, B, Icode)
when Op == '=='; Op == '!=';
Op == '<'; Op == '>';
Op == '<='; Op == '=<'; Op == '>=' ->
Monomorphic = is_monomorphic(Type),
case ast_typerep(Type, Icode) of
_ when not Monomorphic ->
gen_error({cant_compare_polymorphic_type, Ann, Op, Type});
word -> #binop{op = Op, left = ast_body(A, Icode), right = ast_body(B, Icode)};
string ->
Neg = case Op of
'==' -> fun(X) -> X end;
'!=' -> fun(X) -> #unop{ op = '!', rand = X } end;
_ -> gen_error({cant_compare, Ann, Op, Type})
end,
Neg(#funcall{ function = #var_ref{name = {builtin, str_equal}},
args = [ast_body(A, Icode), ast_body(B, Icode)] });
_ -> gen_error({cant_compare, Ann, Op, Type})
end;
ast_binop('++', _, A, B, Icode) ->
#funcall{ function = #var_ref{ name = {builtin, list_concat} },
args = [ast_body(A, Icode), ast_body(B, Icode)] };
ast_binop('bsl', _, A, B, Icode) ->
#binop{op = '*', left = ast_body(A, Icode),
right = #binop{op = '^', left = {integer, 2}, right = ast_body(B, Icode)}};
ast_binop('bsr', _, A, B, Icode) ->
#binop{op = 'div', left = ast_body(A, Icode),
right = #binop{op = '^', left = {integer, 2}, right = ast_body(B, Icode)}};
ast_binop(Op, _, A, B, Icode) ->
#binop{op = Op, left = ast_body(A, Icode), right = ast_body(B, Icode)}.
check_monomorphic_map({typed, Ann, _, MapType}, Icode) ->
check_monomorphic_map(Ann, MapType, Icode).
check_monomorphic_map(Ann, Type = ?map_t(KeyType, ValType), Icode) ->
case is_monomorphic(KeyType) of
true ->
case has_maps(ast_type(KeyType, Icode)) of
false -> {KeyType, ValType};
true -> gen_error({cant_use_map_as_map_keys, Ann, Type})
end;
false -> gen_error({cant_compile_map_with_polymorphic_keys, Ann, Type})
end.
map_empty(KeyType, ValType, Icode) ->
prim_call(?PRIM_CALL_MAP_EMPTY, #integer{value = 0},
[ast_type_value(KeyType, Icode),
ast_type_value(ValType, Icode)],
[typerep, typerep], word).
map_get(Key, Map = {typed, Ann, _, MapType}, Icode) ->
{_KeyType, ValType} = check_monomorphic_map(Ann, MapType, Icode),
builtin_call({map_lookup, ast_type(ValType, Icode)}, [ast_body(Map, Icode), ast_body(Key, Icode)]).
map_put(Key, Val, Map, Icode) ->
builtin_call(map_put, [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Val, Icode)]).
map_del(Key, Map, Icode) ->
prim_call(?PRIM_CALL_MAP_DELETE, #integer{value = 0},
[ast_body(Map, Icode), ast_body(Key, Icode)],
[word, word], word).
map_tolist(Map, Icode) ->
{KeyType, ValType} = check_monomorphic_map(Map, Icode),
prim_call(?PRIM_CALL_MAP_TOLIST, #integer{value = 0},
[ast_body(Map, Icode)],
[word], {list, {tuple, [ast_type(KeyType, Icode), ast_type(ValType, Icode)]}}).
map_upd(Key, ValFun, Map = {typed, Ann, _, MapType}, Icode) ->
{_, ValType} = check_monomorphic_map(Ann, MapType, Icode),
FunName = {map_upd, ast_type(ValType, Icode)},
Args = [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(ValFun, Icode)],
builtin_call(FunName, Args).
map_upd(Key, Default, ValFun, Map = {typed, Ann, _, MapType}, Icode) ->
{_, ValType} = check_monomorphic_map(Ann, MapType, Icode),
FunName = {map_upd_default, ast_type(ValType, Icode)},
Args = [ast_body(Map, Icode), ast_body(Key, Icode), ast_body(Default, Icode), ast_body(ValFun, Icode)],
builtin_call(FunName, Args).
is_monomorphic({tvar, _, _}) -> false;
is_monomorphic([H|T]) ->
is_monomorphic(H) andalso is_monomorphic(T);
is_monomorphic(T) when is_tuple(T) ->
is_monomorphic(tuple_to_list(T));
is_monomorphic(_) -> true.
%% Implemented as a contract call to the contract with address 0.
prim_call(Prim, Amount, Args, ArgTypes, OutType) ->
TypeHash =
case aeb_primops:op_needs_type_check(Prim) of
true ->
PrimBin = binary:encode_unsigned(Prim),
ArgType = {tuple, ArgTypes},
<<TH:256>> = aeso_abi:function_type_hash(PrimBin, ArgType, OutType),
TH;
false ->
0
end,
#prim_call_contract{ gas = prim_gas_left,
address = #integer{ value = ?PRIM_CALLS_CONTRACT },
value = Amount,
arg = #tuple{cpts = [#integer{ value = Prim }| Args]},
type_hash= #integer{value = TypeHash}
}.
make_type_def(Args, Def, Icode = #{ type_vars := TypeEnv }) ->
TVars = [ X || {tvar, _, X} <- Args ],
fun(Types) ->
TypeEnv1 = maps:from_list(lists:zip(TVars, Types)),
ast_typerep(Def, Icode#{ type_vars := maps:merge(TypeEnv, TypeEnv1) })
end.
-spec ast_typerep(aeso_syntax:type()) -> aeso_sophia:type().
ast_typerep(Type) -> ast_typerep(Type, aeso_icode:new([])).
ast_typerep({id, _, Name}, Icode) ->
lookup_type_id(Name, [], Icode);
ast_typerep({qid, _, Name}, Icode) ->
lookup_type_id(Name, [], Icode);
ast_typerep({con, _, _}, _) ->
word; %% Contract type
ast_typerep({app_t, _, {id, _, Name}, Args}, Icode) ->
ArgReps = [ ast_typerep(Arg, Icode) || Arg <- Args ],
lookup_type_id(Name, ArgReps, Icode);
ast_typerep({tvar,_,A}, #{ type_vars := TypeVars }) ->
case maps:get(A, TypeVars, undefined) of
undefined -> word; %% We serialize type variables just as addresses in the originating VM.
Type -> Type
end;
ast_typerep({tuple_t,_,Cpts}, Icode) ->
{tuple, [ast_typerep(C, Icode) || C<-Cpts]};
ast_typerep({record_t,Fields}, Icode) ->
{tuple, [ begin
{field_t, _, _, T} = Field,
ast_typerep(T, Icode)
end || Field <- Fields]};
ast_typerep({fun_t,_,_,_,_}, _Icode) ->
function;
ast_typerep({alias_t, T}, Icode) -> ast_typerep(T, Icode);
ast_typerep({variant_t, Cons}, Icode) ->
{variant, [ begin
{constr_t, _, _, Args} = Con,
[ ast_typerep(Arg, Icode) || Arg <- Args ]
end || Con <- Cons ]}.
ttl_t(Icode) ->
ast_typerep({qid, [], ["Chain", "ttl"]}, Icode).
sign_t() ->
{tuple, [word, word]}.
get_signature_arg(Args0) ->
NamedArgs = [Arg || Arg = {named_arg, _, _, _} <- Args0],
Args = Args0 -- NamedArgs,
DefaultVal = {tuple, [], [{int, [], 0}, {int, [], 0}]},
Sig =
case NamedArgs of
[] -> DefaultVal;
[{named_arg, _, _, Val}] -> Val
end,
{Sig, Args}.
lookup_type_id(Name, Args, #{ types := Types }) ->
case maps:get(Name, Types, undefined) of
undefined -> gen_error({undefined_type, Name});
TDef -> TDef(Args)
end.
ast_type_value(T, Icode) ->
type_value(ast_type(T, Icode)).
type_value(word) ->
#tuple{ cpts = [#integer{ value = ?TYPEREP_WORD_TAG }] };
type_value(string) ->
#tuple{ cpts = [#integer{ value = ?TYPEREP_STRING_TAG }] };
type_value(typerep) ->
#tuple{ cpts = [#integer{ value = ?TYPEREP_TYPEREP_TAG }] };
type_value({list, A}) ->
#tuple{ cpts = [#integer{ value = ?TYPEREP_LIST_TAG }, type_value(A)] };
type_value({tuple, As}) ->
#tuple{ cpts = [#integer{ value = ?TYPEREP_TUPLE_TAG },
#list{ elems = [ type_value(A) || A <- As ] }] };
type_value({variant, Cs}) ->
#tuple{ cpts = [#integer{ value = ?TYPEREP_VARIANT_TAG },
#list{ elems = [ #list{ elems = [ type_value(A) || A <- As ] } || As <- Cs ] }] };
type_value({map, K, V}) ->
#tuple{ cpts = [#integer{ value = ?TYPEREP_MAP_TAG },
type_value(K), type_value(V)] }.
%% As abort is a built-in in the future it will be illegal to for
%% users to define abort. For the time being strip away all user
%% defined abort functions.
ast_fun_to_icode("abort", _Atts, _Args, _Body, _TypeRep, Icode) ->
%% Strip away all user defined abort functions.
Icode;
ast_fun_to_icode(Name, Attrs, Args, Body, TypeRep, #{functions := Funs} = Icode) ->
NewFuns = [{Name, Attrs, Args, Body, TypeRep}| Funs],
aeso_icode:set_functions(NewFuns, Icode).
has_maps({map, _, _}) -> true;
has_maps(word) -> false;
has_maps(string) -> false;
has_maps(typerep) -> false;
has_maps({list, T}) -> has_maps(T);
has_maps({tuple, Ts}) -> lists:any(fun has_maps/1, Ts);
has_maps({variant, Cs}) -> lists:any(fun has_maps/1, lists:append(Cs)).
%% -------------------------------------------------------------------
%% Builtins
%% -------------------------------------------------------------------
builtin_call(Builtin, Args) ->
#funcall{ function = #var_ref{ name = {builtin, Builtin} },
args = Args }.
add_builtins(Icode = #{functions := Funs}) ->
Builtins = aeso_builtins:used_builtins(Funs),
Icode#{functions := [ aeso_builtins:builtin_function(B) || B <- Builtins ] ++ Funs}.
src/aeso_builtins.erl
+510
View File
@@ -0,0 +1,510 @@
%%%-------------------------------------------------------------------
%%% @copyright (C) 2018, Aeternity Anstalt
%%% @doc
%%% Compiler builtin functions for Aeterinty Sophia language.
%%% @end
%%% Created : 20 Dec 2018
%%%
%%%-------------------------------------------------------------------
-module(aeso_builtins).
-export([ builtin_function/1
, check_event_type/1
, used_builtins/1 ]).
-import(aeso_ast_to_icode, [prim_call/5]).
-include_lib("aebytecode/include/aeb_opcodes.hrl").
-include("aeso_icode.hrl").
used_builtins(#funcall{ function = #var_ref{ name = {builtin, Builtin} }, args = Args }) ->
lists:umerge(dep_closure([Builtin]), used_builtins(Args));
used_builtins([H|T]) ->
lists:umerge(used_builtins(H), used_builtins(T));
used_builtins(T) when is_tuple(T) ->
used_builtins(tuple_to_list(T));
used_builtins(M) when is_map(M) ->
used_builtins(maps:to_list(M));
used_builtins(_) -> [].
builtin_deps(Builtin) ->
lists:usort(builtin_deps1(Builtin)).
builtin_deps1({map_lookup_default, Type}) -> [{map_lookup, Type}];
builtin_deps1({map_get, Type}) -> [{map_lookup, Type}];
builtin_deps1(map_member) -> [{map_lookup, word}];
builtin_deps1({map_upd, Type}) -> [{map_get, Type}, map_put];
builtin_deps1({map_upd_default, Type}) -> [{map_lookup_default, Type}, map_put];
builtin_deps1(map_from_list) -> [map_put];
builtin_deps1(str_equal) -> [str_equal_p];
builtin_deps1(string_concat) -> [string_concat_inner1, string_concat_inner2];
builtin_deps1(int_to_str) -> [int_to_str_, int_digits];
builtin_deps1(addr_to_str) -> [base58_int, string_concat];
builtin_deps1(base58_int) -> [base58_int_encode, base58_int_pad, string_reverse, string_concat];
builtin_deps1(base58_int_encode) -> [base58_int_encode_, base58_tab];
builtin_deps1(string_reverse) -> [string_reverse_];
builtin_deps1(_) -> [].
dep_closure(Deps) ->
case lists:umerge(lists:map(fun builtin_deps/1, Deps)) of
[] -> Deps;
Deps1 -> lists:umerge(Deps, dep_closure(Deps1))
end.
%% Helper functions/macros
v(X) when is_atom(X) -> v(atom_to_list(X));
v(X) when is_list(X) -> #var_ref{name = X}.
option_none() -> {tuple, [{integer, 0}]}.
option_some(X) -> {tuple, [{integer, 1}, X]}.
-define(call(Fun, Args), #funcall{ function = #var_ref{ name = {builtin, Fun} }, args = Args }).
-define(I(X), {integer, X}).
-define(V(X), v(X)).
-define(A(Op), aeb_opcodes:mnemonic(Op)).
-define(LET(Var, Expr, Body), {switch, Expr, [{v(Var), Body}]}).
-define(DEREF(Var, Ptr, Body), {switch, v(Ptr), [{{tuple, [v(Var)]}, Body}]}).
-define(NXT(Ptr), op('+', Ptr, 32)).
-define(NEG(A), op('/', A, {unop, '-', {integer, 1}})).
-define(BYTE(Ix, Word), op('byte', Ix, Word)).
-define(EQ(A, B), op('==', A, B)).
-define(LT(A, B), op('<', A, B)).
-define(GT(A, B), op('>', A, B)).
-define(ADD(A, B), op('+', A, B)).
-define(SUB(A, B), op('-', A, B)).
-define(MUL(A, B), op('*', A, B)).
-define(DIV(A, B), op('div', A, B)).
-define(MOD(A, B), op('mod', A, B)).
-define(EXP(A, B), op('^', A, B)).
-define(AND(A, B), op('&&', A, B)).
-define(BSL(X, B), ?MUL(X, ?EXP(2, ?MUL(B, 8)))).
-define(BSR(X, B), ?DIV(X, ?EXP(2, ?MUL(B, 8)))).
op(Op, A, B) -> {binop, Op, operand(A), operand(B)}.
operand(A) when is_atom(A) -> v(A);
operand(I) when is_integer(I) -> {integer, I};
operand(T) -> T.
str_to_icode(String) when is_list(String) ->
str_to_icode(list_to_binary(String));
str_to_icode(BinStr) ->
Cpts = [size(BinStr) | aeso_memory:binary_to_words(BinStr)],
#tuple{ cpts = [ #integer{value = X} || X <- Cpts ] }.
check_event_type(Icode) ->
case maps:get(event_type, Icode) of
{variant_t, Cons} ->
check_event_type(Cons, Icode);
_ ->
error({event_should_be_variant_type})
end.
check_event_type(Evts, Icode) ->
[ check_event_type(Name, T, Icode)
|| {constr_t, _, {con, _, Name}, Types} <- Evts, T <- Types ].
check_event_type(EvtName, Type, Icode) ->
io:format("~p: ~p??\n", [EvtName, Type]),
io:format("=> ~p\n", [aeso_ast_to_icode:ast_typerep(Type, Icode)]),
VMType =
try
aeso_ast_to_icode:ast_typerep(Type, Icode)
catch _:_ ->
error({EvtName, could_not_resolve_type, Type})
end,
case aeso_syntax:get_ann(indexed, Type, false) of
true when VMType == word -> ok;
false when VMType == string -> ok;
true -> error({EvtName, indexed_field_should_be_word, is, VMType});
false -> error({EvtName, payload_should_be_string, is, VMType})
end.
%% Event primitive (dependent on Event type)
%%
%% We need to switch on the event and prepare the correct #event for icode_to_asm
%% NOTE: we assume all errors are already checked!
builtin_function(Builtin = {event, EventT}) ->
A = fun(X) -> aeb_opcodes:mnemonic(X) end,
VIx = fun(Ix) -> v(lists:concat(["v", Ix])) end,
ArgPats = fun(Ts) -> [ VIx(Ix) || Ix <- lists:seq(0, length(Ts) - 1) ] end,
IsIndexed = fun(T) -> aeso_syntax:get_ann(indexed, T, false) end,
Payload = %% Should put data ptr, length on stack.
fun([]) -> {inline_asm, [A(?PUSH1), 0, A(?PUSH1), 0]};
([V]) -> {seq, [V, {inline_asm, [A(?DUP1), A(?MLOAD), %% length, ptr
A(?SWAP1), A(?PUSH1), 32, A(?ADD)]}]} %% ptr+32, length
end,
Clause =
fun(_Tag, {con, _, Con}, Types) ->
Indexed = [ Var || {Var, Type} <- lists:zip(ArgPats(Types), Types),
IsIndexed(Type) ],
EvtIndex = {unop, 'sha3', str_to_icode(Con)},
{event, lists:reverse(Indexed) ++ [EvtIndex], Payload(ArgPats(Types) -- Indexed)}
end,
Pat = fun(Tag, Types) -> {tuple, [{integer, Tag} | ArgPats(Types)]} end,
{variant_t, Cons} = EventT,
Tags = lists:seq(0, length(Cons) - 1),
{{builtin, Builtin}, [private],
[{"e", event}],
{switch, v(e),
[{Pat(Tag, Types), Clause(Tag, Con, Types)}
|| {Tag, {constr_t, _, Con, Types}} <- lists:zip(Tags, Cons) ]},
{tuple, []}};
%% Abort primitive.
builtin_function(abort) ->
A = fun(X) -> aeb_opcodes:mnemonic(X) end,
{{builtin, abort}, [private],
[{"s", string}],
{inline_asm, [A(?PUSH1),0, %% Push a dummy 0 for the first arg
A(?REVERT)]}, %% Stack: 0,Ptr
{tuple,[]}};
%% Map primitives
builtin_function(Builtin = {map_lookup, Type}) ->
Ret = aeso_icode:option_typerep(Type),
{{builtin, Builtin}, [private],
[{"m", word}, {"k", word}],
prim_call(?PRIM_CALL_MAP_GET, #integer{value = 0},
[#var_ref{name = "m"}, #var_ref{name = "k"}],
[word, word], Ret),
Ret};
builtin_function(Builtin = map_put) ->
%% We don't need the types for put.
{{builtin, Builtin}, [private],
[{"m", word}, {"k", word}, {"v", word}],
prim_call(?PRIM_CALL_MAP_PUT, #integer{value = 0},
[v(m), v(k), v(v)],
[word, word, word], word),
word};
builtin_function(Builtin = map_delete) ->
{{builtin, Builtin}, [private],
[{"m", word}, {"k", word}],
prim_call(?PRIM_CALL_MAP_DELETE, #integer{value = 0},
[v(m), v(k)],
[word, word], word),
word};
builtin_function(Builtin = map_size) ->
Name = {builtin, Builtin},
{Name, [private], [{"m", word}],
prim_call(?PRIM_CALL_MAP_SIZE, #integer{value = 0},
[v(m)], [word], word),
word};
%% Map builtins
builtin_function(Builtin = {map_get, Type}) ->
%% function map_get(m, k) =
%% switch(map_lookup(m, k))
%% Some(v) => v
{{builtin, Builtin}, [private],
[{"m", word}, {"k", word}],
{switch, ?call({map_lookup, Type}, [v(m), v(k)]),
[{option_some(v(v)), v(v)}]},
Type};
builtin_function(Builtin = {map_lookup_default, Type}) ->
%% function map_lookup_default(m, k, default) =
%% switch(map_lookup(m, k))
%% None => default
%% Some(v) => v
{{builtin, Builtin}, [private],
[{"m", word}, {"k", word}, {"default", Type}],
{switch, ?call({map_lookup, Type}, [v(m), v(k)]),
[{option_none(), v(default)},
{option_some(v(v)), v(v)}]},
Type};
builtin_function(Builtin = map_member) ->
%% function map_member(m, k) : bool =
%% switch(Map.lookup(m, k))
%% None => false
%% _ => true
{{builtin, Builtin}, [private],
[{"m", word}, {"k", word}],
{switch, ?call({map_lookup, word}, [v(m), v(k)]),
[{option_none(), {integer, 0}},
{{var_ref, "_"}, {integer, 1}}]},
word};
builtin_function(Builtin = {map_upd, Type}) ->
%% function map_upd(map, key, fun) =
%% map_put(map, key, fun(map_get(map, key)))
{{builtin, Builtin}, [private],
[{"map", word}, {"key", word}, {"valfun", word}],
?call(map_put,
[v(map), v(key),
#funcall{ function = v(valfun),
args = [?call({map_get, Type}, [v(map), v(key)])] }]),
word};
builtin_function(Builtin = {map_upd_default, Type}) ->
%% function map_upd(map, key, val, fun) =
%% map_put(map, key, fun(map_lookup_default(map, key, val)))
{{builtin, Builtin}, [private],
[{"map", word}, {"key", word}, {"val", word}, {"valfun", word}],
?call(map_put,
[v(map), v(key),
#funcall{ function = v(valfun),
args = [?call({map_lookup_default, Type}, [v(map), v(key), v(val)])] }]),
word};
builtin_function(Builtin = map_from_list) ->
%% function map_from_list(xs, acc) =
%% switch(xs)
%% [] => acc
%% (k, v) :: xs => map_from_list(xs, acc { [k] = v })
{{builtin, Builtin}, [private],
[{"xs", {list, {tuple, [word, word]}}}, {"acc", word}],
{switch, v(xs),
[{{list, []}, v(acc)},
{{binop, '::', {tuple, [v(k), v(v)]}, v(ys)},
?call(map_from_list,
[v(ys), ?call(map_put, [v(acc), v(k), v(v)])])}]},
word};
%% list_concat
%%
%% Concatenates two lists.
builtin_function(list_concat) ->
{{builtin, list_concat}, [private],
[{"l1", {list, word}}, {"l2", {list, word}}],
{switch, v(l1),
[{{list, []}, v(l2)},
{{binop, '::', v(hd), v(tl)},
{binop, '::', v(hd), ?call(list_concat, [v(tl), v(l2)])}}
]
},
word};
builtin_function(string_length) ->
%% function length(str) =
%% switch(str)
%% {n} -> n // (ab)use the representation
{{builtin, string_length}, [private],
[{"s", string}],
?DEREF(n, s, ?V(n)),
word};
%% str_concat - concatenate two strings
%%
%% Unless the second string is the empty string, a new string is created at the
%% top of the Heap and the address to it is returned. The tricky bit is when
%% the words from the second string has to be shifted to fit next to the first
%% string.
builtin_function(string_concat) ->
{{builtin, string_concat}, [private],
[{"s1", string}, {"s2", string}],
?DEREF(n1, s1,
?DEREF(n2, s2,
{ifte, ?EQ(n2, 0),
?V(s1), %% Second string is empty return first string
?LET(ret, {inline_asm, [?A(?MSIZE)]},
{seq, [?ADD(n1, n2), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, %% Store total len
?call(string_concat_inner1, [?V(n1), ?NXT(s1), ?V(n2), ?NXT(s2)]),
{inline_asm, [?A(?POP)]}, %% Discard fun ret val
?V(ret) %% Put the actual return value
]})}
)),
word};
builtin_function(string_concat_inner1) ->
%% Copy all whole words from the first string, and set up for word fusion
%% Special case when the length of the first string is divisible by 32.
{{builtin, string_concat_inner1}, [private],
[{"n1", word}, {"p1", pointer}, {"n2", word}, {"p2", pointer}],
?DEREF(w1, p1,
{ifte, ?GT(n1, 32),
{seq, [?V(w1), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
?call(string_concat_inner1, [?SUB(n1, 32), ?NXT(p1), ?V(n2), ?V(p2)])]},
{ifte, ?EQ(n1, 0),
?call(string_concat_inner2, [?I(32), ?I(0), ?V(n2), ?V(p2)]),
?call(string_concat_inner2, [?SUB(32, n1), ?V(w1), ?V(n2), ?V(p2)])}
}),
word};
builtin_function(string_concat_inner2) ->
%% Current "work in progess" word 'x', has 'o' bytes that are "free" - fill them from
%% words of the second string.
{{builtin, string_concat_inner2}, [private],
[{"o", word}, {"x", word}, {"n2", word}, {"p2", pointer}],
{ifte, ?LT(n2, 1),
{seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE), ?A(?MSIZE)]}]}, %% Use MSIZE as dummy return value
?DEREF(w2, p2,
{ifte, ?GT(n2, o),
{seq, [?ADD(x, ?BSR(w2, ?SUB(32, o))),
{inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
?call(string_concat_inner2,
[?V(o), ?BSL(w2, o), ?SUB(n2, 32), ?NXT(p2)])
]},
{seq, [?ADD(x, ?BSR(w2, ?SUB(32, o))),
{inline_asm, [?A(?MSIZE), ?A(?MSTORE), ?A(?MSIZE)]}]} %% Use MSIZE as dummy return value
})
},
word};
builtin_function(str_equal_p) ->
%% function str_equal_p(n, p1, p2) =
%% if(n =< 0) true
%% else
%% let w1 = *p1
%% let w2 = *p2
%% w1 == w2 && str_equal_p(n - 32, p1 + 32, p2 + 32)
{{builtin, str_equal_p}, [private],
[{"n", word}, {"p1", pointer}, {"p2", pointer}],
{ifte, ?LT(n, 1),
?I(1),
?DEREF(w1, p1,
?DEREF(w2, p2,
?AND(?EQ(w1, w2),
?call(str_equal_p, [?SUB(n, 32), ?NXT(p1), ?NXT(p2)]))))},
word};
builtin_function(str_equal) ->
%% function str_equal(s1, s2) =
%% let n1 = length(s1)
%% let n2 = length(s2)
%% n1 == n2 && str_equal_p(n1, s1 + 32, s2 + 32)
{{builtin, str_equal}, [private],
[{"s1", string}, {"s2", string}],
?DEREF(n1, s1,
?DEREF(n2, s2,
?AND(?EQ(n1, n2), ?call(str_equal_p, [?V(n1), ?NXT(s1), ?NXT(s2)]))
)),
word};
builtin_function(int_to_str) ->
{{builtin, int_to_str}, [private],
[{"i0", word}],
{switch, {ifte, ?LT(i0, 0),
{tuple, [?I(2), ?NEG(i0), ?BSL(45, 31)]},
{tuple, [?I(1), ?V(i0), ?I(0)]}},
[{{tuple, [v(off), v(i), v(x)]},
?LET(ret, {inline_asm, [?A(?MSIZE)]},
?LET(n, ?call(int_digits, [?DIV(i, 10), ?I(0)]),
?LET(fac, ?EXP(10, n),
{seq, [?ADD(n, off), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, %% Store str len
?call(int_to_str_,
[?MOD(i, fac), ?ADD(x, ?BSL(?ADD(48, ?DIV(i, fac)), ?SUB(32, off))), ?DIV(fac, 10), ?V(off)]),
{inline_asm, [?A(?POP)]}, ?V(ret)]}
)))}]},
word};
builtin_function(int_to_str_) ->
{{builtin, int_to_str_}, [private],
[{"x", word}, {"y", word}, {"fac", word}, {"n", word}],
{ifte, ?EQ(fac, 0),
{seq, [?V(y), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, ?V(n)]},
{ifte, ?EQ(?MOD(n, 32), 0),
%% We've filled a word, write it and start on new word
{seq, [?V(y), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
?call(int_to_str_,
[?MOD(x, fac), ?BSL(?ADD(48, ?DIV(x, fac)), 31),
?DIV(fac, 10), ?I(1)])]},
?call(int_to_str_,
[?MOD(x, fac), ?ADD(y, ?BSL(?ADD(48, ?DIV(x, fac)), ?SUB(31, n))),
?DIV(fac, 10), ?ADD(n, 1)])}
},
word};
builtin_function(int_digits) ->
{{builtin, int_digits}, [private],
[{"x", word}, {"n", word}],
{ifte, ?EQ(x, 0), ?V(n), ?call(int_digits, [?DIV(x, 10), ?ADD(n, 1)])},
word};
builtin_function(base58_tab) ->
Fst32 = 22252025330403739761829862310514590177935513752035045390683118730099851483225,
Lst26 = 40880219588527126470443504235291962205031881694701834176631306799289575931904,
{{builtin, base58_tab}, [private],
[{"ix", word}],
{ifte, ?LT(ix, 32),
?BYTE(ix, Fst32),
?BYTE(?SUB(ix, 32), Lst26)
}, word};
builtin_function(base58_int) ->
{{builtin, base58_int}, [private],
[{"w", word}],
?LET(str0, ?call(base58_int_encode, [?V(w)]),
?LET(str1, ?call(base58_int_pad, [?V(w), ?I(0), ?I(0)]),
?LET(str2, ?call(string_concat, [?V(str0), ?V(str1)]),
?call(string_reverse, [?V(str2)])
))),
word};
builtin_function(string_reverse) ->
{{builtin, string_reverse}, [private],
[{"s", string}],
?DEREF(n, s,
?LET(ret, {inline_asm, [?A(?MSIZE)]},
{seq, [?V(n), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
?call(string_reverse_, [?NXT(s), ?I(0), ?I(31), ?SUB(?V(n), 1)]),
{inline_asm, [?A(?POP)]}, ?V(ret)]})),
word};
builtin_function(string_reverse_) ->
{{builtin, string_reverse_}, [private],
[{"p", pointer}, {"x", word}, {"i1", word}, {"i2", word}],
{ifte, ?LT(i2, 0),
{seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE), ?A(?MSIZE)]}]},
?LET(p1, ?ADD(p, ?MUL(?DIV(i2, 32), 32)),
?DEREF(w, p1,
?LET(b, ?BYTE(?MOD(i2, 32), w),
{ifte, ?LT(i1, 0),
{seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
?call(string_reverse_,
[?V(p), ?BSL(b, 31), ?I(30), ?SUB(i2, 1)])]},
?call(string_reverse_,
[?V(p), ?ADD(x, ?BSL(b, i1)), ?SUB(i1, 1), ?SUB(i2, 1)])})))},
word};
builtin_function(base58_int_pad) ->
{{builtin, base58_int_pad}, [private],
[{"w", word}, {"i", word}, {"x", word}],
{ifte, ?GT(?BYTE(i, w), 0),
{seq, [?V(i), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
{inline_asm, [?A(?PUSH1), 64, ?A(?MSIZE), ?A(?SUB)]}]},
?call(base58_int_pad, [?V(w), ?ADD(i, 1),
?ADD(x, ?BSL(49, ?SUB(31, i)))])},
word};
builtin_function(base58_int_encode) ->
{{builtin, base58_int_encode}, [private],
[{"w", word}],
?LET(ret, {inline_asm, [?A(?MSIZE), ?A(?PUSH1), 0, ?A(?MSIZE), ?A(?MSTORE)]}, %% write placeholder
?LET(n, ?call(base58_int_encode_, [?V(w), ?I(0), ?I(0), ?I(31)]),
{seq, [?V(ret), {inline_asm, [?A(?DUP2), ?A(?SWAP1), ?A(?MSTORE)]},
?V(ret)]})),
word};
builtin_function(base58_int_encode_) ->
{{builtin, base58_int_encode_}, [private],
[{"w", word}, {"x", word}, {"n", word}, {"i", word}],
{ifte, ?EQ(w, 0),
{seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]}, ?V(n)]},
{ifte, ?LT(i, 0),
{seq, [?V(x), {inline_asm, [?A(?MSIZE), ?A(?MSTORE)]},
?call(base58_int_encode_,
[?DIV(w, 58), ?BSL(?call(base58_tab, [?MOD(w, 58)]), 31),
?ADD(n, 1), ?I(30)])]},
?call(base58_int_encode_,
[?DIV(w, 58), ?ADD(x, ?BSL(?call(base58_tab, [?MOD(w, 58)]), i)),
?ADD(n, 1), ?SUB(i, 1)])}},
word};
builtin_function(addr_to_str) ->
{{builtin, addr_to_str}, [private],
[{"a", word}],
?call(base58_int, [?V(a)]),
word}.
src/aeso_compiler.erl
+259
View File
@@ -0,0 +1,259 @@
%%%-------------------------------------------------------------------
%%% @author Happi (Erik Stenman)
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc
%%% Compiler from Aeterinty Sophia language to the Aeternity VM, aevm.
%%% @end
%%% Created : 12 Dec 2017
%%%-------------------------------------------------------------------
-module(aeso_compiler).
-export([ file/1
, file/2
, from_string/2
, check_call/2
, create_calldata/3
, version/0
, sophia_type_to_typerep/1
]).
-include_lib("aebytecode/include/aeb_opcodes.hrl").
-include("aeso_icode.hrl").
-type option() :: pp_sophia_code | pp_ast | pp_icode | pp_assembler |
pp_bytecode.
-type options() :: [option()].
-export_type([ option/0
, options/0
]).
-define(COMPILER_VERSION_1, 1).
-define(COMPILER_VERSION_2, 2).
-define(COMPILER_VERSION, ?COMPILER_VERSION_2).
-spec version() -> pos_integer().
version() ->
?COMPILER_VERSION.
-spec file(string()) -> map().
file(Filename) ->
file(Filename, []).
-spec file(string(), options()) -> map().
file(Filename, Options) ->
C = read_contract(Filename),
from_string(C, Options).
-spec from_string(string(), options()) -> map().
from_string(ContractString, Options) ->
Ast = parse(ContractString, Options),
ok = pp_sophia_code(Ast, Options),
ok = pp_ast(Ast, Options),
TypedAst = aeso_ast_infer_types:infer(Ast, Options),
%% pp_types is handled inside aeso_ast_infer_types.
ok = pp_typed_ast(TypedAst, Options),
ICode = to_icode(TypedAst, Options),
TypeInfo = extract_type_info(ICode),
ok = pp_icode(ICode, Options),
Assembler = assemble(ICode, Options),
ok = pp_assembler(Assembler, Options),
ByteCodeList = to_bytecode(Assembler, Options),
ByteCode = << << B:8 >> || B <- ByteCodeList >>,
ok = pp_bytecode(ByteCode, Options),
#{byte_code => ByteCode, type_info => TypeInfo,
contract_source => ContractString,
compiler_version => version()}.
-define(CALL_NAME, "__call").
%% Takes a string containing a contract with a declaration/prototype of a
%% function (foo, say) and a function __call() = foo(args) calling this
%% function. Returns the name of the called functions, typereps and Erlang
%% terms for the arguments.
-spec check_call(string(), options()) -> {ok, string(), {[Type], Type | any}, [term()]} | {error, term()}
when Type :: term().
check_call(ContractString, Options) ->
Ast = parse(ContractString, Options),
ok = pp_sophia_code(Ast, Options),
ok = pp_ast(Ast, Options),
TypedAst = aeso_ast_infer_types:infer(Ast, [permissive_address_literals]),
{ok, {FunName, {fun_t, _, _, ArgTypes, RetType}}} = get_call_type(TypedAst),
ok = pp_typed_ast(TypedAst, Options),
Icode = to_icode(TypedAst, Options),
ArgVMTypes = [ aeso_ast_to_icode:ast_typerep(T, Icode) || T <- ArgTypes ],
RetVMType = case RetType of
{id, _, "_"} -> any;
_ -> aeso_ast_to_icode:ast_typerep(RetType, Icode)
end,
ok = pp_icode(Icode, Options),
#{ functions := Funs } = Icode,
ArgIcode = get_arg_icode(Funs),
try [ icode_to_term(T, Arg) || {T, Arg} <- lists:zip(ArgVMTypes, ArgIcode) ] of
ArgTerms ->
{ok, FunName, {ArgVMTypes, RetVMType}, ArgTerms}
catch throw:Err ->
{error, Err}
end.
-spec create_calldata(map(), string(), string()) ->
{ok, aeso_sophia:heap(), aeso_sophia:type(), aeso_sophia:type()}
| {error, argument_syntax_error}.
create_calldata(Contract, "", CallCode) when is_map(Contract) ->
case check_call(CallCode, []) of
{ok, FunName, {ArgTypes, RetType}, Args} ->
aeso_abi:create_calldata(Contract, FunName, Args, ArgTypes, RetType);
{error, _} = Err -> Err
end;
create_calldata(Contract, Function, Argument) when is_map(Contract) ->
%% Slightly hacky shortcut to let you get away without writing the full
%% call contract code.
%% Function should be "foo : type", and
%% Argument should be "Arg1, Arg2, .., ArgN" (no parens)
case string:lexemes(Function, ": ") of
%% If function is a single word fallback to old calldata generation
[FunName] -> aeso_abi:old_create_calldata(Contract, FunName, Argument);
[FunName | _] ->
Args = lists:map(fun($\n) -> 32; (X) -> X end, Argument), %% newline to space
CallContract = lists:flatten(
[ "contract Call =\n"
, " function ", Function, "\n"
, " function __call() = ", FunName, "(", Args, ")"
]),
create_calldata(Contract, "", CallContract)
end.
get_arg_icode(Funs) ->
[Args] = [ Args || {?CALL_NAME, _, _, {funcall, _, Args}, _} <- Funs ],
Args.
get_call_type([{contract, _, _, Defs}]) ->
case [ {FunName, FunType}
|| {letfun, _, {id, _, ?CALL_NAME}, [], _Ret,
{typed, _,
{app, _,
{typed, _, {id, _, FunName}, FunType}, _}, _}} <- Defs ] of
[Call] -> {ok, Call};
[] -> {error, missing_call_function}
end;
get_call_type([_ | Contracts]) ->
%% The __call should be in the final contract
get_call_type(Contracts).
%% Translate an icode value (error if not value) to an Erlang term that can be
%% consumed by aeso_heap:to_binary().
icode_to_term(word, {integer, N}) -> N;
icode_to_term(string, {tuple, [{integer, Len} | Words]}) ->
<<Str:Len/binary, _/binary>> = << <<W:256>> || {integer, W} <- Words >>,
Str;
icode_to_term({list, T}, {list, Vs}) ->
[ icode_to_term(T, V) || V <- Vs ];
icode_to_term({tuple, Ts}, {tuple, Vs}) ->
list_to_tuple(icodes_to_terms(Ts, Vs));
icode_to_term({variant, Cs}, {tuple, [{integer, Tag} | Args]}) ->
Ts = lists:nth(Tag + 1, Cs),
{variant, Tag, icodes_to_terms(Ts, Args)};
icode_to_term(T = {map, KT, VT}, M) ->
%% Maps are compiled to builtin and primop calls, so this gets a little hairy
case M of
{funcall, {var_ref, {builtin, map_put}}, [M1, K, V]} ->
Map = icode_to_term(T, M1),
Key = icode_to_term(KT, K),
Val = icode_to_term(VT, V),
Map#{ Key => Val };
#prim_call_contract{ address = {integer, 0},
arg = {tuple, [{integer, ?PRIM_CALL_MAP_EMPTY}, _, _]} } ->
#{};
_ -> throw({todo, M})
end;
icode_to_term(typerep, _) ->
throw({todo, typerep});
icode_to_term(T, V) ->
throw({not_a_value, T, V}).
icodes_to_terms(Ts, Vs) ->
[ icode_to_term(T, V) || {T, V} <- lists:zip(Ts, Vs) ].
parse(C,_Options) ->
parse_string(C).
to_icode(TypedAst, Options) ->
aeso_ast_to_icode:convert_typed(TypedAst, Options).
assemble(Icode, Options) ->
aeso_icode_to_asm:convert(Icode, Options).
to_bytecode(['COMMENT',_|Rest],_Options) ->
to_bytecode(Rest,_Options);
to_bytecode([Op|Rest], Options) ->
[aeb_opcodes:m_to_op(Op)|to_bytecode(Rest, Options)];
to_bytecode([], _) -> [].
extract_type_info(#{functions := Functions} =_Icode) ->
TypeInfo = [aeso_abi:function_type_info(list_to_binary(Name), Args, TypeRep)
|| {Name, Attrs, Args,_Body, TypeRep} <- Functions,
not is_tuple(Name),
not lists:member(private, Attrs)
],
lists:sort(TypeInfo).
pp_sophia_code(C, Opts)-> pp(C, Opts, pp_sophia_code, fun(Code) ->
io:format("~s\n", [prettypr:format(aeso_pretty:decls(Code))])
end).
pp_ast(C, Opts) -> pp(C, Opts, pp_ast, fun aeso_ast:pp/1).
pp_typed_ast(C, Opts)-> pp(C, Opts, pp_typed_ast, fun aeso_ast:pp_typed/1).
pp_icode(C, Opts) -> pp(C, Opts, pp_icode, fun aeso_icode:pp/1).
pp_assembler(C, Opts)-> pp(C, Opts, pp_assembler, fun aeb_asm:pp/1).
pp_bytecode(C, Opts) -> pp(C, Opts, pp_bytecode, fun aeb_disassemble:pp/1).
pp(Code, Options, Option, PPFun) ->
case proplists:lookup(Option, Options) of
{Option, true} ->
PPFun(Code);
none ->
ok
end.
%% -------------------------------------------------------------------
%% TODO: Tempoary parser hook below...
sophia_type_to_typerep(String) ->
{ok, Ast} = aeso_parser:type(String),
try aeso_ast_to_icode:ast_typerep(Ast) of
Type -> {ok, Type}
catch _:_ -> {error, bad_type}
end.
parse_string(Text) ->
%% Try and return something sensible here!
case aeso_parser:string(Text) of
%% Yay, it worked!
{ok, Contract} -> Contract;
%% Scan errors.
{error, {Pos, scan_error}} ->
parse_error(Pos, "scan error");
{error, {Pos, scan_error_no_state}} ->
parse_error(Pos, "scan error");
%% Parse errors.
{error, {Pos, parse_error, Error}} ->
parse_error(Pos, Error);
{error, {Pos, ambiguous_parse, As}} ->
ErrorString = io_lib:format("Ambiguous ~p", [As]),
parse_error(Pos, ErrorString)
end.
parse_error({Line,Pos}, ErrorString) ->
Error = io_lib:format("line ~p, column ~p: ~s", [Line,Pos,ErrorString]),
error({parse_errors,[Error]}).
read_contract(Name) ->
{ok, Bin} = file:read_file(filename:join(contract_path(), lists:concat([Name, ".aes"]))),
binary_to_list(Bin).
contract_path() ->
"apps/aesophia/test/contracts".
src/aeso_constants.erl
+42
View File
@@ -0,0 +1,42 @@
-module(aeso_constants).
-export([string/1, get_type/1]).
string(Str) ->
case aeso_parser:string("let _ = " ++ Str) of
{ok, [{letval, _, _, _, E}]} -> {ok, E};
{ok, Other} -> error({internal_error, should_be_letval, Other});
Err -> Err
end.
get_type(Str) ->
case aeso_parser:string("let _ = " ++ Str) of
{ok, [Ast]} ->
AstT = aeso_ast_infer_types:infer_constant(Ast),
T = ast_to_type(AstT),
{ok, T};
{ok, Other} -> error({internal_error, should_be_letval, Other});
Err -> Err
end.
ast_to_type({id, _, T}) ->
T;
ast_to_type({tuple_t, _, []}) -> "()";
ast_to_type({tuple_t, _, Ts}) ->
"(" ++ list_ast_to_type(Ts) ++ ")";
ast_to_type({app_t,_, {id, _, "list"}, [T]}) ->
lists:flatten("list(" ++ ast_to_type(T) ++ ")");
ast_to_type({app_t,_, {id, _, "option"}, [T]}) ->
lists:flatten("option(" ++ ast_to_type(T) ++ ")").
list_ast_to_type([T]) ->
ast_to_type(T);
list_ast_to_type([T|Ts]) ->
ast_to_type(T)
++ ", "
++ list_ast_to_type(Ts).
src/aeso_heap.erl
+301
View File
@@ -0,0 +1,301 @@
-module(aeso_heap).
-export([ to_binary/1
, to_binary/2
, from_heap/3
, from_binary/2
, from_binary/3
, maps_with_next_id/1
, set_next_id/2
, heap_fragment/3
, heap_value/3
, heap_value/4
, heap_value_pointer/1
, heap_value_maps/1
, heap_value_offset/1
, heap_value_heap/1
, heap_fragment_maps/1
, heap_fragment_offset/1
, heap_fragment_heap/1
]).
-export_type([binary_value/0, heap_value/0, offset/0, heap_fragment/0]).
-include("aeso_icode.hrl").
-include_lib("aesophia/include/aeso_heap.hrl").
-type word() :: non_neg_integer().
-type pointer() :: word().
-opaque heap_fragment() :: #heap{}.
-type offset() :: non_neg_integer().
-type binary_value() :: binary().
-type heap_value() :: {pointer(), heap_fragment()}.
-spec maps_with_next_id(heap_fragment()) -> #maps{}.
%% Create just a maps value, don't keep rest of Heap
maps_with_next_id(#heap{maps = #maps{next_id = N}}) ->
#maps{ next_id = N }.
-spec set_next_id(heap_fragment(), non_neg_integer()) -> heap_fragment().
set_next_id(Heap, N) ->
Heap#heap{ maps = Heap#heap.maps#maps{ next_id = N } }.
%% -- data type heap_fragment
-spec heap_fragment(binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment().
heap_fragment(Heap) ->
heap_fragment(#maps{ next_id = 0 }, 0, Heap).
-spec heap_fragment(#maps{}, offset(),
binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment().
heap_fragment(Maps, Offset, Heap) ->
#heap{maps = Maps, offset = Offset, heap = Heap}.
-spec heap_fragment_maps(heap_fragment()) -> #maps{}.
heap_fragment_maps(#heap{maps = Maps}) ->
Maps.
-spec heap_fragment_offset(heap_fragment()) -> offset().
heap_fragment_offset(#heap{offset = Offs}) ->
Offs.
-spec heap_fragment_heap(heap_fragment()) -> binary() | #{non_neg_integer() => non_neg_integer()}.
heap_fragment_heap(#heap{heap = Heap}) ->
Heap.
%% -- data type heap_value
-spec heap_value(#maps{}, pointer(),
binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_value().
heap_value(Maps, Ptr, Heap) ->
heap_value(Maps, Ptr, Heap, 0).
-spec heap_value(#maps{}, pointer(),
binary() | #{non_neg_integer() => non_neg_integer()}, offset()) -> heap_value().
heap_value(Maps, Ptr, Heap, Offs) ->
{Ptr, heap_fragment(Maps, Offs, Heap)}.
-spec heap_value_pointer(heap_value()) -> pointer().
heap_value_pointer({Ptr, _}) -> Ptr.
-spec heap_value_maps(heap_value()) -> #maps{}.
heap_value_maps({_, Heap}) -> Heap#heap.maps.
-spec heap_value_offset(heap_value()) -> offset().
heap_value_offset({_, Heap}) -> Heap#heap.offset.
-spec heap_value_heap(heap_value()) ->
binary() | #{non_neg_integer() => non_neg_integer()}.
heap_value_heap({_, Heap}) -> Heap#heap.heap.
%% -- Value to binary --------------------------------------------------------
-spec to_binary(aeso_sophia:data()) -> aeso_sophia:heap().
%% Encode the data as a heap where the first word is the value (for unboxed
%% types) or a pointer to the value (for boxed types).
to_binary(Data) ->
to_binary(Data, 0).
to_binary(Data, BaseAddress) ->
{Address, Memory} = to_binary1(Data, BaseAddress + 32),
R = <<Address:256, Memory/binary>>,
R.
%% Allocate the data in memory, from the given address. Return a pair
%% of memory contents from that address and the value representing the
%% data.
to_binary1(Data,_Address) when is_integer(Data) ->
{Data,<<>>};
to_binary1(Data, Address) when is_binary(Data) ->
%% a string
Words = aeso_memory:binary_to_words(Data),
{Address,<<(size(Data)):256, << <<W:256>> || W <- Words>>/binary>>};
to_binary1(none, Address) -> to_binary1({variant, 0, []}, Address);
to_binary1({some, Value}, Address) -> to_binary1({variant, 1, [Value]}, Address);
to_binary1(word, Address) -> to_binary1({?TYPEREP_WORD_TAG}, Address);
to_binary1(string, Address) -> to_binary1({?TYPEREP_STRING_TAG}, Address);
to_binary1(typerep, Address) -> to_binary1({?TYPEREP_TYPEREP_TAG}, Address);
to_binary1(function, Address) -> to_binary1({?TYPEREP_FUN_TAG}, Address);
to_binary1({list, T}, Address) -> to_binary1({?TYPEREP_LIST_TAG, T}, Address);
to_binary1({option, T}, Address) -> to_binary1({variant, [[], [T]]}, Address);
to_binary1({tuple, Ts}, Address) -> to_binary1({?TYPEREP_TUPLE_TAG, Ts}, Address);
to_binary1({variant, Cons}, Address) -> to_binary1({?TYPEREP_VARIANT_TAG, Cons}, Address);
to_binary1({map, K, V}, Address) -> to_binary1({?TYPEREP_MAP_TAG, K, V}, Address);
to_binary1({variant, Tag, Args}, Address) ->
to_binary1(list_to_tuple([Tag | Args]), Address);
to_binary1(Map, Address) when is_map(Map) ->
Size = maps:size(Map),
%% Sort according to binary ordering
KVs = lists:sort([ {to_binary(K), to_binary(V)} || {K, V} <- maps:to_list(Map) ]),
{Address, <<Size:256, << <<(byte_size(K)):256, K/binary,
(byte_size(V)):256, V/binary>> || {K, V} <- KVs >>/binary >>};
to_binary1({}, _Address) ->
{0, <<>>};
to_binary1(Data, Address) when is_tuple(Data) ->
{Elems,Memory} = to_binaries(tuple_to_list(Data),Address+32*size(Data)),
ElemsBin = << <<W:256>> || W <- Elems>>,
{Address,<< ElemsBin/binary, Memory/binary >>};
to_binary1([],_Address) ->
<<Nil:256>> = <<(-1):256>>,
{Nil,<<>>};
to_binary1([H|T],Address) ->
to_binary1({H,T},Address).
to_binaries([],_Address) ->
{[],<<>>};
to_binaries([H|T],Address) ->
{HRep,HMem} = to_binary1(H,Address),
{TRep,TMem} = to_binaries(T,Address+size(HMem)),
{[HRep|TRep],<<HMem/binary, TMem/binary>>}.
%% Interpret a return value (a binary) using a type rep.
-spec from_heap(Type :: ?Type(), Heap :: binary(), Ptr :: integer()) ->
{ok, term()} | {error, term()}.
from_heap(Type, Heap, Ptr) ->
try {ok, from_binary(#{}, Type, Heap, Ptr)}
catch _:Err ->
%% io:format("** Error: from_heap failed with ~p\n ~p\n", [Err, erlang:get_stacktrace()]),
{error, Err}
end.
%% Base address is the address of the first word of the given heap.
-spec from_binary(T :: ?Type(),
Heap :: binary(),
BaseAddr :: non_neg_integer()) ->
{ok, term()} | {error, term()}.
from_binary(T, Heap = <<V:256, _/binary>>, BaseAddr) ->
from_heap(T, <<0:BaseAddr/unit:8, Heap/binary>>, V);
from_binary(_, Bin, _BaseAddr) ->
{error, {binary_too_short, Bin}}.
-spec from_binary(?Type(), binary()) -> {ok, term()} | {error, term()}.
from_binary(T, Heap) ->
from_binary(T, Heap, 0).
from_binary(_, word, _, V) ->
V;
from_binary(_, signed_word, _, V) ->
<<N:256/signed>> = <<V:256>>,
N;
from_binary(_, bool, _, V) ->
case V of
0 -> false;
1 -> true
end;
from_binary(_, string, Heap, V) ->
StringSize = heap_word(Heap,V),
BitAddr = 8*(V+32),
<<_:BitAddr,Bytes:StringSize/binary,_/binary>> = Heap,
Bytes;
from_binary(_, {tuple, []}, _, _) ->
{};
from_binary(Visited, {tuple,Cpts}, Heap, V) ->
check_circular_refs(Visited, V),
NewVisited = Visited#{V => true},
ElementNums = lists:seq(0, length(Cpts)-1),
TypesAndPointers = lists:zip(Cpts, ElementNums),
ElementAddress = fun(Index) -> V + 32 * Index end,
Element = fun(Index) ->
heap_word(Heap, ElementAddress(Index))
end,
Convert = fun(Type, Index) ->
from_binary(NewVisited, Type, Heap, Element(Index))
end,
Elements = [Convert(T, I) || {T,I} <- TypesAndPointers],
list_to_tuple(Elements);
from_binary(Visited, {list, Elem}, Heap, V) ->
<<Nil:256>> = <<(-1):256>>,
if V==Nil ->
[];
true ->
{H,T} = from_binary(Visited, {tuple,[Elem,{list,Elem}]},Heap,V),
[H|T]
end;
from_binary(Visited, {option, A}, Heap, V) ->
from_binary(Visited, {variant_t, [{none, []}, {some, [A]}]}, Heap, V);
from_binary(Visited, {variant, Cons}, Heap, V) ->
Tag = heap_word(Heap, V),
Args = lists:nth(Tag + 1, Cons),
Visited1 = Visited#{V => true},
{variant, Tag, tuple_to_list(from_binary(Visited1, {tuple, Args}, Heap, V + 32))};
from_binary(Visited, {variant_t, TCons}, Heap, V) -> %% Tagged variants
{Tags, Cons} = lists:unzip(TCons),
{variant, I, Args} = from_binary(Visited, {variant, Cons}, Heap, V),
Tag = lists:nth(I + 1, Tags),
case Args of
[] -> Tag;
_ -> list_to_tuple([Tag | Args])
end;
from_binary(_Visited, {map, A, B}, Heap, Ptr) ->
%% FORMAT: [Size] [KeySize] Key [ValSize] Val .. [KeySize] Key [ValSize] Val
Size = heap_word(Heap, Ptr),
map_binary_to_value(A, B, Size, Heap, Ptr + 32);
from_binary(Visited, typerep, Heap, V) ->
check_circular_refs(Visited, V),
Tag = heap_word(Heap, V),
Arg1 = fun(T, I) -> from_binary(Visited#{V => true}, T, Heap, heap_word(Heap, V + 32 * I)) end,
Arg = fun(T) -> Arg1(T, 1) end,
case Tag of
?TYPEREP_WORD_TAG -> word;
?TYPEREP_STRING_TAG -> string;
?TYPEREP_TYPEREP_TAG -> typerep;
?TYPEREP_LIST_TAG -> {list, Arg(typerep)};
?TYPEREP_TUPLE_TAG -> {tuple, Arg({list, typerep})};
?TYPEREP_VARIANT_TAG -> {variant, Arg({list, {list, typerep}})};
?TYPEREP_MAP_TAG -> {map, Arg(typerep), Arg1(typerep, 2)};
?TYPEREP_FUN_TAG -> function
end.
map_binary_to_value(KeyType, ValType, N, Bin, Ptr) ->
%% Avoid looping on bogus sizes
MaxN = byte_size(Bin) div 64,
Heap = heap_fragment(Bin),
map_from_binary({value, KeyType, ValType}, min(N, MaxN), Heap, Ptr, #{}).
map_from_binary(_, 0, _, _, Map) -> Map;
map_from_binary({value, KeyType, ValType} = Output, I, Heap, Ptr, Map) ->
KeySize = get_word(Heap, Ptr),
KeyPtr = Ptr + 32,
KeyBin = get_chunk(Heap, KeyPtr, KeySize),
ValSize = get_word(Heap, KeyPtr + KeySize),
ValPtr = KeyPtr + KeySize + 32,
ValBin = get_chunk(Heap, ValPtr, ValSize),
%% Keys and values are self contained binaries
{ok, Key} = from_binary(KeyType, KeyBin),
{ok, Val} = from_binary(ValType, ValBin),
map_from_binary(Output, I - 1, Heap, ValPtr + ValSize, Map#{Key => Val}).
check_circular_refs(Visited, V) ->
case maps:is_key(V, Visited) of
true -> exit(circular_references);
false -> ok
end.
heap_word(Heap, Addr) when is_binary(Heap) ->
BitSize = 8*Addr,
<<_:BitSize,W:256,_/binary>> = Heap,
W;
heap_word(Heap, Addr) when is_map(Heap) ->
0 = Addr rem 32, %% Check that it's word aligned.
maps:get(Addr, Heap, 0).
get_word(#heap{offset = Offs, heap = Mem}, Addr) when Addr >= Offs ->
get_word(Mem, Addr - Offs);
get_word(Mem, Addr) when is_binary(Mem) ->
<<_:Addr/unit:8, Word:256, _/binary>> = Mem,
Word.
get_chunk(#heap{offset = Offs, heap = Mem}, Addr, Bytes) when Addr >= Offs ->
get_chunk(Mem, Addr - Offs, Bytes);
get_chunk(Mem, Addr, Bytes) when is_binary(Mem) ->
<<_:Addr/unit:8, Chunk:Bytes/binary, _/binary>> = Mem,
Chunk.
src/aeso_heap.erl~
+301
View File
@@ -0,0 +1,301 @@
-module(aeso_heap).
-export([ to_binary/1
, to_binary/2
, from_heap/3
, from_binary/2
, from_binary/3
, maps_with_next_id/1
, set_next_id/2
, heap_fragment/3
, heap_value/3
, heap_value/4
, heap_value_pointer/1
, heap_value_maps/1
, heap_value_offset/1
, heap_value_heap/1
, heap_fragment_maps/1
, heap_fragment_offset/1
, heap_fragment_heap/1
]).
-export_type([binary_value/0, heap_value/0, offset/0, heap_fragment/0]).
-include("aeso_icode.hrl").
-include_lib("sophia/include/aeso_heap.hrl").
-type word() :: non_neg_integer().
-type pointer() :: word().
-opaque heap_fragment() :: #heap{}.
-type offset() :: non_neg_integer().
-type binary_value() :: binary().
-type heap_value() :: {pointer(), heap_fragment()}.
-spec maps_with_next_id(heap_fragment()) -> #maps{}.
%% Create just a maps value, don't keep rest of Heap
maps_with_next_id(#heap{maps = #maps{next_id = N}}) ->
#maps{ next_id = N }.
-spec set_next_id(heap_fragment(), non_neg_integer()) -> heap_fragment().
set_next_id(Heap, N) ->
Heap#heap{ maps = Heap#heap.maps#maps{ next_id = N } }.
%% -- data type heap_fragment
-spec heap_fragment(binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment().
heap_fragment(Heap) ->
heap_fragment(#maps{ next_id = 0 }, 0, Heap).
-spec heap_fragment(#maps{}, offset(),
binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_fragment().
heap_fragment(Maps, Offset, Heap) ->
#heap{maps = Maps, offset = Offset, heap = Heap}.
-spec heap_fragment_maps(heap_fragment()) -> #maps{}.
heap_fragment_maps(#heap{maps = Maps}) ->
Maps.
-spec heap_fragment_offset(heap_fragment()) -> offset().
heap_fragment_offset(#heap{offset = Offs}) ->
Offs.
-spec heap_fragment_heap(heap_fragment()) -> binary() | #{non_neg_integer() => non_neg_integer()}.
heap_fragment_heap(#heap{heap = Heap}) ->
Heap.
%% -- data type heap_value
-spec heap_value(#maps{}, pointer(),
binary() | #{non_neg_integer() => non_neg_integer()}) -> heap_value().
heap_value(Maps, Ptr, Heap) ->
heap_value(Maps, Ptr, Heap, 0).
-spec heap_value(#maps{}, pointer(),
binary() | #{non_neg_integer() => non_neg_integer()}, offset()) -> heap_value().
heap_value(Maps, Ptr, Heap, Offs) ->
{Ptr, heap_fragment(Maps, Offs, Heap)}.
-spec heap_value_pointer(heap_value()) -> pointer().
heap_value_pointer({Ptr, _}) -> Ptr.
-spec heap_value_maps(heap_value()) -> #maps{}.
heap_value_maps({_, Heap}) -> Heap#heap.maps.
-spec heap_value_offset(heap_value()) -> offset().
heap_value_offset({_, Heap}) -> Heap#heap.offset.
-spec heap_value_heap(heap_value()) ->
binary() | #{non_neg_integer() => non_neg_integer()}.
heap_value_heap({_, Heap}) -> Heap#heap.heap.
%% -- Value to binary --------------------------------------------------------
-spec to_binary(aeso_sophia:data()) -> aeso_sophia:heap().
%% Encode the data as a heap where the first word is the value (for unboxed
%% types) or a pointer to the value (for boxed types).
to_binary(Data) ->
to_binary(Data, 0).
to_binary(Data, BaseAddress) ->
{Address, Memory} = to_binary1(Data, BaseAddress + 32),
R = <<Address:256, Memory/binary>>,
R.
%% Allocate the data in memory, from the given address. Return a pair
%% of memory contents from that address and the value representing the
%% data.
to_binary1(Data,_Address) when is_integer(Data) ->
{Data,<<>>};
to_binary1(Data, Address) when is_binary(Data) ->
%% a string
Words = aeso_memory:binary_to_words(Data),
{Address,<<(size(Data)):256, << <<W:256>> || W <- Words>>/binary>>};
to_binary1(none, Address) -> to_binary1({variant, 0, []}, Address);
to_binary1({some, Value}, Address) -> to_binary1({variant, 1, [Value]}, Address);
to_binary1(word, Address) -> to_binary1({?TYPEREP_WORD_TAG}, Address);
to_binary1(string, Address) -> to_binary1({?TYPEREP_STRING_TAG}, Address);
to_binary1(typerep, Address) -> to_binary1({?TYPEREP_TYPEREP_TAG}, Address);
to_binary1(function, Address) -> to_binary1({?TYPEREP_FUN_TAG}, Address);
to_binary1({list, T}, Address) -> to_binary1({?TYPEREP_LIST_TAG, T}, Address);
to_binary1({option, T}, Address) -> to_binary1({variant, [[], [T]]}, Address);
to_binary1({tuple, Ts}, Address) -> to_binary1({?TYPEREP_TUPLE_TAG, Ts}, Address);
to_binary1({variant, Cons}, Address) -> to_binary1({?TYPEREP_VARIANT_TAG, Cons}, Address);
to_binary1({map, K, V}, Address) -> to_binary1({?TYPEREP_MAP_TAG, K, V}, Address);
to_binary1({variant, Tag, Args}, Address) ->
to_binary1(list_to_tuple([Tag | Args]), Address);
to_binary1(Map, Address) when is_map(Map) ->
Size = maps:size(Map),
%% Sort according to binary ordering
KVs = lists:sort([ {to_binary(K), to_binary(V)} || {K, V} <- maps:to_list(Map) ]),
{Address, <<Size:256, << <<(byte_size(K)):256, K/binary,
(byte_size(V)):256, V/binary>> || {K, V} <- KVs >>/binary >>};
to_binary1({}, _Address) ->
{0, <<>>};
to_binary1(Data, Address) when is_tuple(Data) ->
{Elems,Memory} = to_binaries(tuple_to_list(Data),Address+32*size(Data)),
ElemsBin = << <<W:256>> || W <- Elems>>,
{Address,<< ElemsBin/binary, Memory/binary >>};
to_binary1([],_Address) ->
<<Nil:256>> = <<(-1):256>>,
{Nil,<<>>};
to_binary1([H|T],Address) ->
to_binary1({H,T},Address).
to_binaries([],_Address) ->
{[],<<>>};
to_binaries([H|T],Address) ->
{HRep,HMem} = to_binary1(H,Address),
{TRep,TMem} = to_binaries(T,Address+size(HMem)),
{[HRep|TRep],<<HMem/binary, TMem/binary>>}.
%% Interpret a return value (a binary) using a type rep.
-spec from_heap(Type :: ?Type(), Heap :: binary(), Ptr :: integer()) ->
{ok, term()} | {error, term()}.
from_heap(Type, Heap, Ptr) ->
try {ok, from_binary(#{}, Type, Heap, Ptr)}
catch _:Err ->
%% io:format("** Error: from_heap failed with ~p\n ~p\n", [Err, erlang:get_stacktrace()]),
{error, Err}
end.
%% Base address is the address of the first word of the given heap.
-spec from_binary(T :: ?Type(),
Heap :: binary(),
BaseAddr :: non_neg_integer()) ->
{ok, term()} | {error, term()}.
from_binary(T, Heap = <<V:256, _/binary>>, BaseAddr) ->
from_heap(T, <<0:BaseAddr/unit:8, Heap/binary>>, V);
from_binary(_, Bin, _BaseAddr) ->
{error, {binary_too_short, Bin}}.
-spec from_binary(?Type(), binary()) -> {ok, term()} | {error, term()}.
from_binary(T, Heap) ->
from_binary(T, Heap, 0).
from_binary(_, word, _, V) ->
V;
from_binary(_, signed_word, _, V) ->
<<N:256/signed>> = <<V:256>>,
N;
from_binary(_, bool, _, V) ->
case V of
0 -> false;
1 -> true
end;
from_binary(_, string, Heap, V) ->
StringSize = heap_word(Heap,V),
BitAddr = 8*(V+32),
<<_:BitAddr,Bytes:StringSize/binary,_/binary>> = Heap,
Bytes;
from_binary(_, {tuple, []}, _, _) ->
{};
from_binary(Visited, {tuple,Cpts}, Heap, V) ->
check_circular_refs(Visited, V),
NewVisited = Visited#{V => true},
ElementNums = lists:seq(0, length(Cpts)-1),
TypesAndPointers = lists:zip(Cpts, ElementNums),
ElementAddress = fun(Index) -> V + 32 * Index end,
Element = fun(Index) ->
heap_word(Heap, ElementAddress(Index))
end,
Convert = fun(Type, Index) ->
from_binary(NewVisited, Type, Heap, Element(Index))
end,
Elements = [Convert(T, I) || {T,I} <- TypesAndPointers],
list_to_tuple(Elements);
from_binary(Visited, {list, Elem}, Heap, V) ->
<<Nil:256>> = <<(-1):256>>,
if V==Nil ->
[];
true ->
{H,T} = from_binary(Visited, {tuple,[Elem,{list,Elem}]},Heap,V),
[H|T]
end;
from_binary(Visited, {option, A}, Heap, V) ->
from_binary(Visited, {variant_t, [{none, []}, {some, [A]}]}, Heap, V);
from_binary(Visited, {variant, Cons}, Heap, V) ->
Tag = heap_word(Heap, V),
Args = lists:nth(Tag + 1, Cons),
Visited1 = Visited#{V => true},
{variant, Tag, tuple_to_list(from_binary(Visited1, {tuple, Args}, Heap, V + 32))};
from_binary(Visited, {variant_t, TCons}, Heap, V) -> %% Tagged variants
{Tags, Cons} = lists:unzip(TCons),
{variant, I, Args} = from_binary(Visited, {variant, Cons}, Heap, V),
Tag = lists:nth(I + 1, Tags),
case Args of
[] -> Tag;
_ -> list_to_tuple([Tag | Args])
end;
from_binary(_Visited, {map, A, B}, Heap, Ptr) ->
%% FORMAT: [Size] [KeySize] Key [ValSize] Val .. [KeySize] Key [ValSize] Val
Size = heap_word(Heap, Ptr),
map_binary_to_value(A, B, Size, Heap, Ptr + 32);
from_binary(Visited, typerep, Heap, V) ->
check_circular_refs(Visited, V),
Tag = heap_word(Heap, V),
Arg1 = fun(T, I) -> from_binary(Visited#{V => true}, T, Heap, heap_word(Heap, V + 32 * I)) end,
Arg = fun(T) -> Arg1(T, 1) end,
case Tag of
?TYPEREP_WORD_TAG -> word;
?TYPEREP_STRING_TAG -> string;
?TYPEREP_TYPEREP_TAG -> typerep;
?TYPEREP_LIST_TAG -> {list, Arg(typerep)};
?TYPEREP_TUPLE_TAG -> {tuple, Arg({list, typerep})};
?TYPEREP_VARIANT_TAG -> {variant, Arg({list, {list, typerep}})};
?TYPEREP_MAP_TAG -> {map, Arg(typerep), Arg1(typerep, 2)};
?TYPEREP_FUN_TAG -> function
end.
map_binary_to_value(KeyType, ValType, N, Bin, Ptr) ->
%% Avoid looping on bogus sizes
MaxN = byte_size(Bin) div 64,
Heap = heap_fragment(Bin),
map_from_binary({value, KeyType, ValType}, min(N, MaxN), Heap, Ptr, #{}).
map_from_binary(_, 0, _, _, Map) -> Map;
map_from_binary({value, KeyType, ValType} = Output, I, Heap, Ptr, Map) ->
KeySize = get_word(Heap, Ptr),
KeyPtr = Ptr + 32,
KeyBin = get_chunk(Heap, KeyPtr, KeySize),
ValSize = get_word(Heap, KeyPtr + KeySize),
ValPtr = KeyPtr + KeySize + 32,
ValBin = get_chunk(Heap, ValPtr, ValSize),
%% Keys and values are self contained binaries
{ok, Key} = from_binary(KeyType, KeyBin),
{ok, Val} = from_binary(ValType, ValBin),
map_from_binary(Output, I - 1, Heap, ValPtr + ValSize, Map#{Key => Val}).
check_circular_refs(Visited, V) ->
case maps:is_key(V, Visited) of
true -> exit(circular_references);
false -> ok
end.
heap_word(Heap, Addr) when is_binary(Heap) ->
BitSize = 8*Addr,
<<_:BitSize,W:256,_/binary>> = Heap,
W;
heap_word(Heap, Addr) when is_map(Heap) ->
0 = Addr rem 32, %% Check that it's word aligned.
maps:get(Addr, Heap, 0).
get_word(#heap{offset = Offs, heap = Mem}, Addr) when Addr >= Offs ->
get_word(Mem, Addr - Offs);
get_word(Mem, Addr) when is_binary(Mem) ->
<<_:Addr/unit:8, Word:256, _/binary>> = Mem,
Word.
get_chunk(#heap{offset = Offs, heap = Mem}, Addr, Bytes) when Addr >= Offs ->
get_chunk(Mem, Addr - Offs, Bytes);
get_chunk(Mem, Addr, Bytes) when is_binary(Mem) ->
<<_:Addr/unit:8, Chunk:Bytes/binary, _/binary>> = Mem,
Chunk.
src/aeso_icode.erl
+103
View File
@@ -0,0 +1,103 @@
%%%-------------------------------------------------------------------
%%% @author Happi (Erik Stenman)
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc
%%% Intermediate Code for Aeterinty Sophia language.
%%% @end
%%% Created : 21 Dec 2017
%%%
%%%-------------------------------------------------------------------
-module(aeso_icode).
-export([new/1, pp/1, set_name/2, set_functions/2, map_typerep/2, option_typerep/1, get_constructor_tag/2]).
-export_type([icode/0]).
-include("aeso_icode.hrl").
-type type_def() :: fun(([aeso_sophia:type()]) -> aeso_sophia:type()).
-type bindings() :: any().
-type fun_dec() :: { string()
, [modifier()]
, arg_list()
, expr()
, aeso_sophia:type()}.
-type modifier() :: private | stateful.
-type type_name() :: string() | [string()].
-type icode() :: #{ contract_name => string()
, functions => [fun_dec()]
, env => [bindings()]
, state_type => aeso_sophia:type()
, event_type => aeso_sophia:type()
, types => #{ type_name() => type_def() }
, type_vars => #{ string() => aeso_sophia:type() }
, constructors => #{ string() => integer() } %% name to tag
, options => [any()]
}.
pp(Icode) ->
%% TODO: Actually do *Pretty* printing.
io:format("~p~n", [Icode]).
-spec new([any()]) -> icode().
new(Options) ->
#{ contract_name => ""
, functions => []
, env => new_env()
%% Default to unit type for state and event
, state_type => {tuple, []}
, event_type => {tuple, []}
, types => builtin_types()
, type_vars => #{}
, constructors => builtin_constructors()
, options => Options}.
builtin_types() ->
Word = fun([]) -> word end,
#{ "bool" => Word
, "int" => Word
, "string" => fun([]) -> string end
, "address" => Word
, "hash" => Word
, "signature" => fun([]) -> {tuple, [word, word]} end
, "oracle" => fun([_, _]) -> word end
, "oracle_query" => fun([_, _]) -> word end
, "list" => fun([A]) -> {list, A} end
, "option" => fun([A]) -> {variant, [[], [A]]} end
, "map" => fun([K, V]) -> map_typerep(K, V) end
, ["Chain", "ttl"] => fun([]) -> {variant, [[word], [word]]} end
}.
builtin_constructors() ->
#{ "RelativeTTL" => 0
, "FixedTTL" => 1
, "None" => 0
, "Some" => 1 }.
map_typerep(K, V) ->
{map, K, V}.
option_typerep(A) ->
{variant, [[], [A]]}.
new_env() ->
[].
-spec set_name(string(), icode()) -> icode().
set_name(Name, Icode) ->
maps:put(contract_name, Name, Icode).
-spec set_functions([fun_dec()], icode()) -> icode().
set_functions(NewFuns, Icode) ->
maps:put(functions, NewFuns, Icode).
-spec get_constructor_tag(string(), icode()) -> integer().
get_constructor_tag(Name, #{constructors := Constructors}) ->
case maps:get(Name, Constructors, undefined) of
undefined -> error({undefined_constructor, Name});
Tag -> Tag
end.
src/aeso_icode.hrl
+68
View File
@@ -0,0 +1,68 @@
-define(Type(), aeso_sophia:type()).
-define(TYPEREP_WORD_TAG, 0).
-define(TYPEREP_STRING_TAG, 1).
-define(TYPEREP_LIST_TAG, 2).
-define(TYPEREP_TUPLE_TAG, 3).
-define(TYPEREP_VARIANT_TAG, 4).
-define(TYPEREP_TYPEREP_TAG, 5).
-define(TYPEREP_MAP_TAG, 6).
-define(TYPEREP_FUN_TAG, 7).
-record(arg, {name::string(), type::?Type()}).
-type expr() :: term().
-type arg() :: #arg{name::string(), type::?Type()}.
-type arg_list() :: [arg()].
-record(fun_dec, { name :: string()
, args :: arg_list()
, body :: expr()}).
-record(var_ref, { name :: string() | {builtin, atom() | tuple()}}).
-record(prim_call_contract,
{ gas :: expr()
, address :: expr()
, value :: expr()
, arg :: expr()
, type_hash:: expr()
}).
-record(prim_balance, { address :: expr() }).
-record(prim_block_hash, { height :: expr() }).
-record(prim_put, { state :: expr() }).
-record(integer, {value :: integer()}).
-record(tuple, {cpts :: [expr()]}).
-record(list, {elems :: [expr()]}).
-record(unop, { op :: term()
, rand :: expr()}).
-record(binop, { op :: term()
, left :: expr()
, right :: expr()}).
-record(ifte, { decision :: expr()
, then :: expr()
, else :: expr()}).
-record(switch, { expr :: expr()
, cases :: [{expr(),expr()}]}).
-record(funcall, { function :: expr()
, args :: [expr()]}).
-record(lambda, { args :: arg_list(),
body :: expr()}).
-record(missing_field, { format :: string()
, args :: [term()]}).
-record(seq, {exprs :: [expr()]}).
-record(event, {topics :: [expr()], payload :: expr()}).
src/aeso_icode_to_asm.erl
+979
View File
@@ -0,0 +1,979 @@
%%%-------------------------------------------------------------------
%%% @author Happi (Erik Stenman)
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc
%%% Translator from Aesophia Icode to Aevm Assebly
%%% @end
%%% Created : 21 Dec 2017
%%%
%%%-------------------------------------------------------------------
-module(aeso_icode_to_asm).
-export([convert/2]).
-include_lib("aebytecode/include/aeb_opcodes.hrl").
-include("aeso_icode.hrl").
i(Code) -> aeb_opcodes:mnemonic(Code).
%% We don't track purity or statefulness in the type checker yet.
is_stateful({FName, _, _, _, _}) -> FName /= "init".
is_public({_Name, Attrs, _Args, _Body, _Type}) -> not lists:member(private, Attrs).
convert(#{ contract_name := _ContractName
, state_type := StateType
, functions := Functions
},
_Options) ->
%% Create a function dispatcher
DispatchFun = {"_main", [], [{"arg", "_"}],
{switch, {var_ref, "arg"},
[{{tuple, [fun_hash(Fun),
{tuple, make_args(Args)}]},
icode_seq([ hack_return_address(Fun, length(Args) + 1) ] ++
[ {funcall, {var_ref, FName}, make_args(Args)}]
)}
|| Fun={FName, _, Args, _,_TypeRep} <- Functions, is_public(Fun) ]},
word},
NewFunctions = Functions ++ [DispatchFun],
%% Create a function environment
Funs = [{Name, length(Args), make_ref()}
|| {Name, _Attrs, Args, _Body, _Type} <- NewFunctions],
%% Create dummy code to call the main function with one argument
%% taken from the stack
StopLabel = make_ref(),
StatefulStopLabel = make_ref(),
MainFunction = lookup_fun(Funs, "_main"),
StateTypeValue = aeso_ast_to_icode:type_value(StateType),
DispatchCode = [%% push two return addresses to stop, one for stateful
%% functions and one for non-stateful functions.
push_label(StatefulStopLabel),
push_label(StopLabel),
%% The calldata is already on the stack when we start. Put
%% it on top (also reorders StatefulStop and Stop).
swap(2),
jump(MainFunction),
jumpdest(StatefulStopLabel),
%% We need to encode the state type and put it
%% underneath the return value.
assemble_expr(Funs, [], nontail, StateTypeValue), %% StateT Ret
swap(1), %% Ret StateT
%% We should also change the state value at address 0 to a
%% pointer to the state value (to allow 0 to represent an
%% unchanged state).
i(?MSIZE), %% Ptr
push(0), i(?MLOAD), %% Val Ptr
i(?MSIZE), i(?MSTORE), %% Ptr Mem[Ptr] := Val
push(0), i(?MSTORE), %% Mem[0] := Ptr
%% The pointer to the return value is on top of
%% the stack, but the return instruction takes two
%% stack arguments.
push(0),
i(?RETURN),
jumpdest(StopLabel),
%% Set state pointer to 0 to indicate that we didn't change state
push(0), dup(1), i(?MSTORE),
%% Same as StatefulStopLabel above
push(0),
i(?RETURN)
],
%% Code is a deep list of instructions, containing labels and
%% references to them. Labels take the form {'JUMPDEST', Ref}, and
%% references take the form {push_label, Ref}, which is translated
%% into a PUSH instruction.
Code = [assemble_function(Funs, Name, Args, Body)
|| {Name, _, Args, Body, _Type} <- NewFunctions],
resolve_references(
[%% i(?COMMENT), "CONTRACT: " ++ ContractName,
DispatchCode,
Code]).
%% Generate error on correct format.
gen_error(Error) ->
error({code_errors, [Error]}).
make_args(Args) ->
[{var_ref, [I-1 + $a]} || I <- lists:seq(1, length(Args))].
fun_hash({FName, _, Args, _, TypeRep}) ->
ArgType = {tuple, [T || {_, T} <- Args]},
<<Hash:256>> = aeso_abi:function_type_hash(list_to_binary(FName), ArgType, TypeRep),
{integer, Hash}.
%% Expects two return addresses below N elements on the stack. Picks the top
%% one for stateful functions and the bottom one for non-stateful.
hack_return_address(Fun, N) ->
case is_stateful(Fun) of
true -> {inline_asm, [i(?MSIZE)]};
false ->
{inline_asm, %% X1 .. XN State NoState
[ dup(N + 2) %% NoState X1 .. XN State NoState
, swap(N + 1) %% State X1 .. XN NoState NoState
]} %% Top of the stack will be discarded.
end.
assemble_function(Funs, Name, Args, Body) ->
[jumpdest(lookup_fun(Funs, Name)),
assemble_expr(Funs, lists:reverse(Args), tail, Body),
%% swap return value and first argument
pop_args(length(Args)),
swap(1),
i(?JUMP)].
%% {seq, Es} - should be "one" operation in terms of stack content
%% i.e. after the `seq` there should be one new element on the stack.
assemble_expr(Funs, Stack, Tail, {seq, [E]}) ->
assemble_expr(Funs, Stack, Tail, E);
assemble_expr(Funs, Stack, Tail, {seq, [E | Es]}) ->
[assemble_expr(Funs, Stack, nontail, E),
assemble_expr(Funs, Stack, Tail, {seq, Es})];
assemble_expr(_Funs, _Stack, _Tail, {inline_asm, Code}) ->
Code; %% Unsafe! Code should take care to respect the stack!
assemble_expr(Funs, Stack, _TailPosition, {var_ref, Id}) ->
case lists:keymember(Id, 1, Stack) of
true ->
dup(lookup_var(Id, Stack));
false ->
%% Build a closure
%% When a top-level fun is called directly, we do not
%% reach this case.
Eta = make_ref(),
Continue = make_ref(),
[i(?MSIZE),
push_label(Eta),
dup(2),
i(?MSTORE),
jump(Continue),
%% the code of the closure
jumpdest(Eta),
%% pop the pointer to the function
pop(1),
jump(lookup_fun(Funs, Id)),
jumpdest(Continue)]
end;
assemble_expr(_, _, _, {missing_field, Format, Args}) ->
io:format(Format, Args),
gen_error(missing_field);
assemble_expr(_Funs, _Stack, _, {integer, N}) ->
push(N);
assemble_expr(Funs, Stack, _, {tuple, Cpts}) ->
%% We build tuples right-to-left, so that the first write to the
%% tuple extends the memory size. Because we use ?MSIZE as the
%% heap pointer, we must allocate the tuple AFTER computing the
%% first element.
%% We store elements into the tuple as soon as possible, to avoid
%% keeping them for a long time on the stack.
case lists:reverse(Cpts) of
[] ->
i(?MSIZE);
[Last|Rest] ->
[assemble_expr(Funs, Stack, nontail, Last),
%% allocate the tuple memory
i(?MSIZE),
%% compute address of last word
push(32 * (length(Cpts) - 1)), i(?ADD),
%% Stack: <last-value> <pointer>
%% Write value to memory (allocates the tuple)
swap(1), dup(2), i(?MSTORE),
%% Stack: pointer to last word written
[[%% Update pointer to next word to be written
push(32), swap(1), i(?SUB),
%% Compute element
assemble_expr(Funs, [pointer|Stack], nontail, A),
%% Write element to memory
dup(2), i(?MSTORE)]
%% And we leave a pointer to the last word written on
%% the stack
|| A <- Rest]]
%% The pointer to the entire tuple is on the stack
end;
assemble_expr(_Funs, _Stack, _, {list, []}) ->
%% Use Erik's value of -1 for []
[push(0), i(?NOT)];
assemble_expr(Funs, Stack, _, {list, [A|B]}) ->
assemble_expr(Funs, Stack, nontail, {tuple, [A, {list, B}]});
assemble_expr(Funs, Stack, _, {unop, '!', A}) ->
case A of
{binop, Logical, _, _} when Logical=='&&'; Logical=='||' ->
assemble_expr(Funs, Stack, nontail, {ifte, A, {integer, 0}, {integer, 1}});
_ ->
[assemble_expr(Funs, Stack, nontail, A),
i(?ISZERO)
]
end;
assemble_expr(Funs, Stack, _, {event, Topics, Payload}) ->
[assemble_exprs(Funs, Stack, Topics ++ [Payload]),
case length(Topics) of
0 -> i(?LOG0);
1 -> i(?LOG1);
2 -> i(?LOG2);
3 -> i(?LOG3);
4 -> i(?LOG4)
end, i(?MSIZE)];
assemble_expr(Funs, Stack, _, {unop, Op, A}) ->
[assemble_expr(Funs, Stack, nontail, A),
assemble_prefix(Op)];
assemble_expr(Funs, Stack, Tail, {binop, '&&', A, B}) ->
assemble_expr(Funs, Stack, Tail, {ifte, A, B, {integer, 0}});
assemble_expr(Funs, Stack, Tail, {binop, '||', A, B}) ->
assemble_expr(Funs, Stack, Tail, {ifte, A, {integer, 1}, B});
assemble_expr(Funs, Stack, Tail, {binop, '::', A, B}) ->
%% Take advantage of optimizations in tuple construction.
assemble_expr(Funs, Stack, Tail, {tuple, [A, B]});
assemble_expr(Funs, Stack, _, {binop, Op, A, B}) ->
%% EEVM binary instructions take their first argument from the top
%% of the stack, so to get operands on the stack in the right
%% order, we evaluate from right to left.
[assemble_expr(Funs, Stack, nontail, B),
assemble_expr(Funs, [dummy|Stack], nontail, A),
assemble_infix(Op)];
assemble_expr(Funs, Stack, _, {lambda, Args, Body}) ->
Function = make_ref(),
FunBody = make_ref(),
Continue = make_ref(),
NoMatch = make_ref(),
FreeVars = free_vars({lambda, Args, Body}),
{NewVars, MatchingCode} = assemble_pattern(FunBody, NoMatch, {tuple, [{var_ref, "_"}|FreeVars]}),
BodyCode = assemble_expr(Funs, NewVars ++ lists:reverse([ {Arg#arg.name, Arg#arg.type} || Arg <- Args ]), tail, Body),
[assemble_expr(Funs, Stack, nontail, {tuple, [{label, Function}|FreeVars]}),
jump(Continue), %% will be optimized away
jumpdest(Function),
%% A pointer to the closure is on the stack
MatchingCode,
jumpdest(FunBody),
BodyCode,
pop_args(length(Args)+length(NewVars)),
swap(1),
i(?JUMP),
jumpdest(NoMatch), %% dead code--raise an exception just in case
push(0),
i(?NOT),
i(?MLOAD),
i(?STOP),
jumpdest(Continue)];
assemble_expr(_, _, _, {label, Label}) ->
push_label(Label);
assemble_expr(Funs, Stack, nontail, {funcall, Fun, Args}) ->
Return = make_ref(),
%% This is the obvious code:
%% [{push_label, Return},
%% assemble_exprs(Funs, [return_address|Stack], Args++[Fun]),
%% 'JUMP',
%% {'JUMPDEST', Return}];
%% Its problem is that it stores the return address on the stack
%% while the arguments are computed, which is unnecessary. To
%% avoid that, we compute the last argument FIRST, and replace it
%% with the return address using a SWAP.
%%
%% assemble_function leaves the code pointer of the function to
%% call on top of the stack, and--if the function is not a
%% top-level name--a pointer to its tuple of free variables. In
%% either case a JUMP is the right way to call it.
case Args of
[] ->
[push_label(Return),
assemble_function(Funs, [return_address|Stack], Fun),
i(?JUMP),
jumpdest(Return)];
_ ->
{Init, [Last]} = lists:split(length(Args) - 1, Args),
[assemble_exprs(Funs, Stack, [Last|Init]),
%% Put the return address in the right place, which also
%% reorders the args correctly.
push_label(Return),
swap(length(Args)),
assemble_function(Funs, [dummy || _ <- Args] ++ [return_address|Stack], Fun),
i(?JUMP),
jumpdest(Return)]
end;
assemble_expr(Funs, Stack, tail, {funcall, Fun, Args}) ->
IsTopLevel = is_top_level_fun(Stack, Fun),
%% If the fun is not top-level, then it may refer to local
%% variables and must be computed before stack shuffling.
ArgsAndFun = Args++[Fun || not IsTopLevel],
ComputeArgsAndFun = assemble_exprs(Funs, Stack, ArgsAndFun),
%% Copy arguments back down the stack to the start of the frame
ShuffleSpec = lists:seq(length(ArgsAndFun), 1, -1) ++ [discard || _ <- Stack],
Shuffle = shuffle_stack(ShuffleSpec),
[ComputeArgsAndFun, Shuffle,
if IsTopLevel ->
%% still need to compute function
assemble_function(Funs, [], Fun);
true ->
%% need to unpack a closure
[dup(1), i(?MLOAD)]
end,
i(?JUMP)];
assemble_expr(Funs, Stack, Tail, {ifte, Decision, Then, Else}) ->
%% This compilation scheme introduces a lot of labels and
%% jumps. Unnecessary ones are removed later in
%% resolve_references.
Close = make_ref(),
ThenL = make_ref(),
ElseL = make_ref(),
[assemble_decision(Funs, Stack, Decision, ThenL, ElseL),
jumpdest(ElseL),
assemble_expr(Funs, Stack, Tail, Else),
jump(Close),
jumpdest(ThenL),
assemble_expr(Funs, Stack, Tail, Then),
jumpdest(Close)
];
assemble_expr(Funs, Stack, Tail, {switch, A, Cases}) ->
Close = make_ref(),
[assemble_expr(Funs, Stack, nontail, A),
assemble_cases(Funs, Stack, Tail, Close, Cases),
{'JUMPDEST', Close}];
%% State primitives
%% (A pointer to) the contract state is stored at address 0.
assemble_expr(_Funs, _Stack, _Tail, prim_state) ->
[push(0), i(?MLOAD)];
assemble_expr(Funs, Stack, _Tail, #prim_put{ state = State }) ->
[assemble_expr(Funs, Stack, nontail, State),
push(0), i(?MSTORE), %% We need something for the unit value on the stack,
i(?MSIZE)]; %% MSIZE is the cheapest instruction.
%% Environment primitives
assemble_expr(_Funs, _Stack, _Tail, prim_contract_address) ->
[i(?ADDRESS)];
assemble_expr(_Funs, _Stack, _Tail, prim_call_origin) ->
[i(?ORIGIN)];
assemble_expr(_Funs, _Stack, _Tail, prim_caller) ->
[i(?CALLER)];
assemble_expr(_Funs, _Stack, _Tail, prim_call_value) ->
[i(?CALLVALUE)];
assemble_expr(_Funs, _Stack, _Tail, prim_gas_price) ->
[i(?GASPRICE)];
assemble_expr(_Funs, _Stack, _Tail, prim_gas_left) ->
[i(?GAS)];
assemble_expr(_Funs, _Stack, _Tail, prim_coinbase) ->
[i(?COINBASE)];
assemble_expr(_Funs, _Stack, _Tail, prim_timestamp) ->
[i(?TIMESTAMP)];
assemble_expr(_Funs, _Stack, _Tail, prim_block_height) ->
[i(?NUMBER)];
assemble_expr(_Funs, _Stack, _Tail, prim_difficulty) ->
[i(?DIFFICULTY)];
assemble_expr(_Funs, _Stack, _Tail, prim_gas_limit) ->
[i(?GASLIMIT)];
assemble_expr(Funs, Stack, _Tail, #prim_balance{ address = Addr }) ->
[assemble_expr(Funs, Stack, nontail, Addr),
i(?BALANCE)];
assemble_expr(Funs, Stack, _Tail, #prim_block_hash{ height = Height }) ->
[assemble_expr(Funs, Stack, nontail, Height),
i(?BLOCKHASH)];
assemble_expr(Funs, Stack, _Tail,
#prim_call_contract{ gas = Gas
, address = To
, value = Value
, arg = Arg
, type_hash= TypeHash
}) ->
%% ?CALL takes (from the top)
%% Gas, To, Value, Arg, TypeHash, _OOffset,_OSize
%% So assemble these in reverse order.
[ assemble_exprs(Funs, Stack, [ {integer, 0}, {integer, 0}, TypeHash
, Arg, Value, To, Gas ])
, i(?CALL)
].
assemble_exprs(_Funs, _Stack, []) ->
[];
assemble_exprs(Funs, Stack, [E|Es]) ->
[assemble_expr(Funs, Stack, nontail, E),
assemble_exprs(Funs, [dummy|Stack], Es)].
assemble_decision(Funs, Stack, {binop, '&&', A, B}, Then, Else) ->
Label = make_ref(),
[assemble_decision(Funs, Stack, A, Label, Else),
jumpdest(Label),
assemble_decision(Funs, Stack, B, Then, Else)];
assemble_decision(Funs, Stack, {binop, '||', A, B}, Then, Else) ->
Label = make_ref(),
[assemble_decision(Funs, Stack, A, Then, Label),
jumpdest(Label),
assemble_decision(Funs, Stack, B, Then, Else)];
assemble_decision(Funs, Stack, {unop, '!', A}, Then, Else) ->
assemble_decision(Funs, Stack, A, Else, Then);
assemble_decision(Funs, Stack, {ifte, A, B, C}, Then, Else) ->
TrueL = make_ref(),
FalseL = make_ref(),
[assemble_decision(Funs, Stack, A, TrueL, FalseL),
jumpdest(TrueL), assemble_decision(Funs, Stack, B, Then, Else),
jumpdest(FalseL), assemble_decision(Funs, Stack, C, Then, Else)];
assemble_decision(Funs, Stack, Decision, Then, Else) ->
[assemble_expr(Funs, Stack, nontail, Decision),
jump_if(Then), jump(Else)].
%% Entered with value to switch on on top of the stack
%% Evaluate selected case, then jump to Close with result on the
%% stack.
assemble_cases(_Funs, _Stack, _Tail, _Close, []) ->
%% No match! What should be do? There's no real way to raise an
%% exception, except consuming all the gas.
%% There should not be enough gas to do this:
[push(1), i(?NOT),
i(?MLOAD),
%% now stop, so that jump optimizer realizes we will not fall
%% through this code.
i(?STOP)];
assemble_cases(Funs, Stack, Tail, Close, [{Pattern, Body}|Cases]) ->
Succeed = make_ref(),
Fail = make_ref(),
{NewVars, MatchingCode} =
assemble_pattern(Succeed, Fail, Pattern),
%% In the code that follows, if this is NOT the last case, then we
%% save the value being switched on, and discard it on
%% success. The code is simpler if this IS the last case.
[[dup(1) || Cases /= []], %% save value for next case, if there is one
MatchingCode,
jumpdest(Succeed),
%% Discard saved value, if we saved one
[case NewVars of
[] ->
pop(1);
[_] ->
%% Special case for peep-hole optimization
pop_args(1);
_ ->
[swap(length(NewVars)), pop(1)]
end
|| Cases/=[]],
assemble_expr(Funs,
case Cases of
[] -> NewVars;
_ -> reorder_vars(NewVars)
end
++Stack, Tail, Body),
%% If the Body makes a tail call, then we will not return
%% here--but it doesn't matter, because
%% (a) the NewVars will be popped before the tailcall
%% (b) the code below will be deleted since it is dead
pop_args(length(NewVars)),
jump(Close),
jumpdest(Fail),
assemble_cases(Funs, Stack, Tail, Close, Cases)].
%% Entered with value to match on top of the stack.
%% Generated code removes value, and
%% - jumps to Fail if no match, or
%% - binds variables, leaves them on the stack, and jumps to Succeed
%% Result is a list of variables to add to the stack, and the matching
%% code.
assemble_pattern(Succeed, Fail, {integer, N}) ->
{[], [push(N),
i(?EQ),
jump_if(Succeed),
jump(Fail)]};
assemble_pattern(Succeed, _Fail, {var_ref, "_"}) ->
{[], [i(?POP), jump(Succeed)]};
assemble_pattern(Succeed, Fail, {missing_field, _, _}) ->
%% Missing record fields are quite ok in patterns.
assemble_pattern(Succeed, Fail, {var_ref, "_"});
assemble_pattern(Succeed, _Fail, {var_ref, Id}) ->
{[{Id, "_"}], jump(Succeed)};
assemble_pattern(Succeed, _Fail, {tuple, []}) ->
{[], [pop(1), jump(Succeed)]};
assemble_pattern(Succeed, Fail, {tuple, [A]}) ->
%% Treat this case specially, because we don't need to save the
%% pointer to the tuple.
{AVars, ACode} = assemble_pattern(Succeed, Fail, A),
{AVars, [i(?MLOAD),
ACode]};
assemble_pattern(Succeed, Fail, {tuple, [A|B]}) ->
%% Entered with the address of the tuple on the top of the
%% stack. We will duplicate the address before matching on A.
Continue = make_ref(), %% the label for matching B
Pop1Fail = make_ref(), %% pop 1 word and goto Fail
PopNFail = make_ref(), %% pop length(AVars) words and goto Fail
{AVars, ACode} =
assemble_pattern(Continue, Pop1Fail, A),
{BVars, BCode} =
assemble_pattern(Succeed, PopNFail, {tuple, B}),
{BVars ++ reorder_vars(AVars),
[%% duplicate the pointer so we don't lose it when we match on A
dup(1),
i(?MLOAD),
ACode,
jumpdest(Continue),
%% Bring the pointer to the top of the stack--this reorders AVars!
swap(length(AVars)),
push(32),
i(?ADD),
BCode,
case AVars of
[] ->
[jumpdest(Pop1Fail), pop(1),
jumpdest(PopNFail),
jump(Fail)];
_ ->
[{'JUMPDEST', PopNFail}, pop(length(AVars)-1),
{'JUMPDEST', Pop1Fail}, pop(1),
{push_label, Fail}, 'JUMP']
end]};
assemble_pattern(Succeed, Fail, {list, []}) ->
%% [] is represented by -1.
{[], [push(1),
i(?ADD),
jump_if(Fail),
jump(Succeed)]};
assemble_pattern(Succeed, Fail, {list, [A|B]}) ->
assemble_pattern(Succeed, Fail, {binop, '::', A, {list, B}});
assemble_pattern(Succeed, Fail, {binop, '::', A, B}) ->
%% Make sure it's not [], then match as tuple.
NotNil = make_ref(),
{Vars, Code} = assemble_pattern(Succeed, Fail, {tuple, [A, B]}),
{Vars, [dup(1), push(1), i(?ADD), %% Check for [] without consuming the value
jump_if(NotNil), %% so it's still there when matching the tuple.
pop(1), %% It was [] so discard the saved value.
jump(Fail),
jumpdest(NotNil),
Code]}.
%% When Vars are on the stack, with a value we want to discard
%% below them, then we swap the top variable with that value and pop.
%% This reorders the variables on the stack, as follows:
reorder_vars([]) ->
[];
reorder_vars([V|Vs]) ->
Vs ++ [V].
assemble_prefix('sha3') -> [i(?DUP1), i(?MLOAD), %% length, ptr
i(?SWAP1), push(32), i(?ADD), %% ptr+32, length
i(?SHA3)];
assemble_prefix('-') -> [push(0), i(?SUB)];
assemble_prefix('bnot') -> i(?NOT).
assemble_infix('+') -> i(?ADD);
assemble_infix('-') -> i(?SUB);
assemble_infix('*') -> i(?MUL);
assemble_infix('/') -> i(?SDIV);
assemble_infix('div') -> i(?DIV);
assemble_infix('mod') -> i(?MOD);
assemble_infix('^') -> i(?EXP);
assemble_infix('bor') -> i(?OR);
assemble_infix('band') -> i(?AND);
assemble_infix('bxor') -> i(?XOR);
assemble_infix('<') -> i(?SLT); %% comparisons are SIGNED
assemble_infix('>') -> i(?SGT);
assemble_infix('==') -> i(?EQ);
assemble_infix('<=') -> [i(?SGT), i(?ISZERO)];
assemble_infix('=<') -> [i(?SGT), i(?ISZERO)];
assemble_infix('>=') -> [i(?SLT), i(?ISZERO)];
assemble_infix('!=') -> [i(?EQ), i(?ISZERO)];
assemble_infix('!') -> [i(?ADD), i(?MLOAD)];
assemble_infix('byte') -> i(?BYTE).
%% assemble_infix('::') -> [i(?MSIZE), write_word(0), write_word(1)].
%% a function may either refer to a top-level function, in which case
%% we fetch the code label from Funs, or it may be a lambda-expression
%% (including a top-level function passed as a parameter). In the
%% latter case, the function value is a pointer to a tuple of the code
%% pointer and the free variables: we keep the pointer and push the
%% code pointer onto the stack. In either case, we are ready to enter
%% the function with JUMP.
assemble_function(Funs, Stack, Fun) ->
case is_top_level_fun(Stack, Fun) of
true ->
{var_ref, Name} = Fun,
{push_label, lookup_fun(Funs, Name)};
false ->
[assemble_expr(Funs, Stack, nontail, Fun),
dup(1),
i(?MLOAD)]
end.
free_vars(V={var_ref, _}) ->
[V];
free_vars({switch, E, Cases}) ->
lists:umerge(free_vars(E),
lists:umerge([free_vars(Body)--free_vars(Pattern)
|| {Pattern, Body} <- Cases]));
free_vars({lambda, Args, Body}) ->
free_vars(Body) -- [{var_ref, Arg#arg.name} || Arg <- Args];
free_vars(T) when is_tuple(T) ->
free_vars(tuple_to_list(T));
free_vars([H|T]) ->
lists:umerge(free_vars(H), free_vars(T));
free_vars(_) ->
[].
%% shuffle_stack reorders the stack, for example before a tailcall. It is called
%% with a description of the current stack, and how the final stack
%% should appear. The argument is a list containing
%% a NUMBER for each element that should be kept, the number being
%% the position this element should occupy in the final stack
%% discard, for elements that can be discarded.
%% The positions start at 1, referring to the variable to be placed at
%% the bottom of the stack, and ranging up to the size of the final stack.
shuffle_stack([]) ->
[];
shuffle_stack([discard|Stack]) ->
[i(?POP) | shuffle_stack(Stack)];
shuffle_stack([N|Stack]) ->
case length(Stack) + 1 - N of
0 ->
%% the job should be finished
CorrectStack = lists:seq(N - 1, 1, -1),
CorrectStack = Stack,
[];
MoveBy ->
{Pref, [_|Suff]} = lists:split(MoveBy - 1, Stack),
[swap(MoveBy) | shuffle_stack([lists:nth(MoveBy, Stack) | Pref ++ [N|Suff]])]
end.
lookup_fun(Funs, Name) ->
case [Ref || {Name1, _, Ref} <- Funs,
Name == Name1] of
[Ref] -> Ref;
[] -> gen_error({undefined_function, Name})
end.
is_top_level_fun(Stack, {var_ref, Id}) ->
not lists:keymember(Id, 1, Stack);
is_top_level_fun(_, _) ->
false.
lookup_var(Id, Stack) ->
lookup_var(1, Id, Stack).
lookup_var(N, Id, [{Id, _Type}|_]) ->
N;
lookup_var(N, Id, [_|Stack]) ->
lookup_var(N + 1, Id, Stack);
lookup_var(_, Id, []) ->
gen_error({var_not_in_scope, Id}).
%% Smart instruction generation
%% TODO: handle references to the stack beyond depth 16. Perhaps the
%% best way is to repush variables that will be needed in
%% subexpressions before evaluating he subexpression... i.e. fix the
%% problem in assemble_expr, rather than here. A fix here would have
%% to save the top elements of the stack in memory, duplicate the
%% targetted element, and then repush the values from memory.
dup(N) when 1 =< N, N =< 16 ->
i(?DUP1 + N - 1).
push(N) ->
Bytes = binary:encode_unsigned(N),
true = size(Bytes) =< 32,
[i(?PUSH1 + size(Bytes) - 1) |
binary_to_list(Bytes)].
%% Pop N values from UNDER the top element of the stack.
%% This is a pseudo-instruction so peephole optimization can
%% combine pop_args(M), pop_args(N) to pop_args(M+N)
pop_args(0) ->
[];
pop_args(N) ->
{pop_args, N}.
%% [swap(N), pop(N)].
pop(N) ->
[i(?POP) || _ <- lists:seq(1, N)].
swap(0) ->
%% Doesn't exist, but is logically a no-op.
[];
swap(N) when 1 =< N, N =< 16 ->
i(?SWAP1 + N - 1).
jumpdest(Label) -> {i(?JUMPDEST), Label}.
push_label(Label) -> {push_label, Label}.
jump(Label) -> [push_label(Label), i(?JUMP)].
jump_if(Label) -> [push_label(Label), i(?JUMPI)].
%% ICode utilities (TODO: move to separate module)
icode_noname() -> #var_ref{name = "_"}.
icode_seq([A]) -> A;
icode_seq([A | As]) ->
icode_seq(A, icode_seq(As)).
icode_seq(A, B) ->
#switch{ expr = A, cases = [{icode_noname(), B}] }.
%% Stack: <N elements> ADDR
%% Write elements at addresses ADDR, ADDR+32, ADDR+64...
%% Stack afterwards: ADDR
% write_words(N) ->
% [write_word(I) || I <- lists:seq(N-1, 0, -1)].
%% Unused at the moment. Comment out to please dialyzer.
%% write_word(I) ->
%% [%% Stack: elements e ADDR
%% swap(1),
%% dup(2),
%% %% Stack: elements ADDR e ADDR
%% push(32*I),
%% i(?ADD),
%% %% Stack: elements ADDR e ADDR+32I
%% i(?MSTORE)].
%% Resolve references, and convert code from deep list to flat list.
%% List elements are:
%% Opcodes
%% Byte values
%% {'JUMPDEST', Ref} -- assembles to ?JUMPDEST and sets Ref
%% {push_label, Ref} -- assembles to ?PUSHN address bytes
%% For now, we assemble all code addresses as three bytes.
resolve_references(Code) ->
Peephole = peep_hole(lists:flatten(Code)),
%% WARNING: Optimizing jumps reorders the code and deletes
%% instructions. When debugging the assemble_ functions, it can be
%% useful to replace the next line by:
%% Instrs = lists:flatten(Code),
%% thus disabling the optimization.
OptimizedJumps = optimize_jumps(Peephole),
Instrs = lists:reverse(peep_hole_backwards(lists:reverse(OptimizedJumps))),
Labels = define_labels(0, Instrs),
lists:flatten([use_labels(Labels, I) || I <- Instrs]).
define_labels(Addr, [{'JUMPDEST', Lab}|More]) ->
[{Lab, Addr}|define_labels(Addr + 1, More)];
define_labels(Addr, [{push_label, _}|More]) ->
define_labels(Addr + 4, More);
define_labels(Addr, [{pop_args, N}|More]) ->
define_labels(Addr + N + 1, More);
define_labels(Addr, [_|More]) ->
define_labels(Addr + 1, More);
define_labels(_, []) ->
[].
use_labels(_, {'JUMPDEST', _}) ->
'JUMPDEST';
use_labels(Labels, {push_label, Ref}) ->
case proplists:get_value(Ref, Labels) of
undefined ->
gen_error({undefined_label, Ref});
Addr when is_integer(Addr) ->
[i(?PUSH3),
Addr div 65536, (Addr div 256) rem 256, Addr rem 256]
end;
use_labels(_, {pop_args, N}) ->
[swap(N), pop(N)];
use_labels(_, I) ->
I.
%% Peep-hole optimization.
%% The compilation of conditionals can introduce jumps depending on
%% constants 1 and 0. These are removed by peep-hole optimization.
peep_hole(['PUSH1', 0, {push_label, _}, 'JUMPI'|More]) ->
peep_hole(More);
peep_hole(['PUSH1', 1, {push_label, Lab}, 'JUMPI'|More]) ->
[{push_label, Lab}, 'JUMP'|peep_hole(More)];
peep_hole([{pop_args, M}, {pop_args, N}|More]) when M + N =< 16 ->
peep_hole([{pop_args, M + N}|More]);
peep_hole([I|More]) ->
[I|peep_hole(More)];
peep_hole([]) ->
[].
%% Peep-hole optimization on reversed instructions lists.
peep_hole_backwards(Code) ->
NewCode = peep_hole_backwards1(Code),
if Code == NewCode -> Code;
true -> peep_hole_backwards(NewCode)
end.
peep_hole_backwards1(['ADD', 0, 'PUSH1'|Code]) ->
peep_hole_backwards1(Code);
peep_hole_backwards1(['POP', UnOp|Code]) when UnOp=='MLOAD';UnOp=='ISZERO';UnOp=='NOT' ->
peep_hole_backwards1(['POP'|Code]);
peep_hole_backwards1(['POP', BinOp|Code]) when
%% TODO: more binary operators
BinOp=='ADD';BinOp=='SUB';BinOp=='MUL';BinOp=='SDIV' ->
peep_hole_backwards1(['POP', 'POP'|Code]);
peep_hole_backwards1(['POP', _, 'PUSH1'|Code]) ->
peep_hole_backwards1(Code);
peep_hole_backwards1([I|Code]) ->
[I|peep_hole_backwards1(Code)];
peep_hole_backwards1([]) ->
[].
%% Jump optimization:
%% Replaces a jump to a jump with a jump to the final destination
%% Moves basic blocks to eliminate an unconditional jump to them.
%% The compilation of conditionals generates a lot of labels and
%% jumps, some of them unnecessary. This optimization phase reorders
%% code so that as many jumps as possible can be eliminated, and
%% replaced by just falling through to the destination label. This
%% both optimizes the code generated by conditionals, and converts one
%% call of a function into falling through into its code--so it
%% reorders code quite aggressively. Function returns are indirect
%% jumps, however, and are never optimized away.
%% IMPORTANT: since execution begins at address zero, then the first
%% block of code must never be moved elsewhere. The code below has
%% this property, because it processes blocks from left to right, and
%% because the first block does not begin with a label, and so can
%% never be jumped to--hence no code can be inserted before it.
%% The optimization works by taking one block of code at a time, and
%% then prepending blocks that jump directly to it, and appending
%% blocks that it jumps directly to, resulting in a jump-free sequence
%% that is as long as possible. To do so, we store blocks in the form
%% {OptionalLabel, Body, OptionalJump} which represents the code block
%% OptionalLabel++Body++OptionalJump; the optional parts are the empty
%% list of instructions if not present. Two blocks can be merged if
%% the first ends in an OptionalJump to the OptionalLabel beginning
%% the second; the OptionalJump can then be removed (and the
%% OptionalLabel if there are no other references to it--this happens
%% during dead code elimination.
%% TODO: the present implementation is QUADRATIC, because we search
%% repeatedly for matching blocks to merge with the first one, storing
%% the blocks in a list. A near linear time implementation could use
%% two ets tables, one keyed on the labels, and the other keyed on the
%% final jumps.
optimize_jumps(Code) ->
JJs = jumps_to_jumps(Code),
ShortCircuited = [short_circuit_jumps(JJs, Instr) || Instr <- Code],
NoDeadCode = eliminate_dead_code(ShortCircuited),
MovedCode = merge_blocks(moveable_blocks(NoDeadCode)),
%% Moving code may have made some labels superfluous.
eliminate_dead_code(MovedCode).
jumps_to_jumps([{'JUMPDEST', Label}, {push_label, Target}, 'JUMP'|More]) ->
[{Label, Target}|jumps_to_jumps(More)];
jumps_to_jumps([{'JUMPDEST', Label}, {'JUMPDEST', Target}|More]) ->
[{Label, Target}|jumps_to_jumps([{'JUMPDEST', Target}|More])];
jumps_to_jumps([_|More]) ->
jumps_to_jumps(More);
jumps_to_jumps([]) ->
[].
short_circuit_jumps(JJs, {push_label, Lab}) ->
case proplists:get_value(Lab, JJs) of
undefined ->
{push_label, Lab};
Target ->
%% I wonder if this will ever loop infinitely?
short_circuit_jumps(JJs, {push_label, Target})
end;
short_circuit_jumps(_JJs, Instr) ->
Instr.
eliminate_dead_code(Code) ->
Jumps = lists:usort([Lab || {push_label, Lab} <- Code]),
NewCode = live_code(Jumps, Code),
if Code==NewCode ->
Code;
true ->
eliminate_dead_code(NewCode)
end.
live_code(Jumps, ['JUMP'|More]) ->
['JUMP'|dead_code(Jumps, More)];
live_code(Jumps, ['STOP'|More]) ->
['STOP'|dead_code(Jumps, More)];
live_code(Jumps, [{'JUMPDEST', Lab}|More]) ->
case lists:member(Lab, Jumps) of
true ->
[{'JUMPDEST', Lab}|live_code(Jumps, More)];
false ->
live_code(Jumps, More)
end;
live_code(Jumps, [I|More]) ->
[I|live_code(Jumps, More)];
live_code(_, []) ->
[].
dead_code(Jumps, [{'JUMPDEST', Lab}|More]) ->
case lists:member(Lab, Jumps) of
true ->
[{'JUMPDEST', Lab}|live_code(Jumps, More)];
false ->
dead_code(Jumps, More)
end;
dead_code(Jumps, [_I|More]) ->
dead_code(Jumps, More);
dead_code(_, []) ->
[].
%% Split the code into "moveable blocks" that control flow only
%% reaches via jumps.
moveable_blocks([]) ->
[];
moveable_blocks([I]) ->
[[I]];
moveable_blocks([Jump|More]) when Jump=='JUMP'; Jump=='STOP' ->
[[Jump]|moveable_blocks(More)];
moveable_blocks([I|More]) ->
[Block|MoreBlocks] = moveable_blocks(More),
[[I|Block]|MoreBlocks].
%% Merge blocks to eliminate jumps where possible.
merge_blocks(Blocks) ->
BlocksAndTargets = [label_and_jump(B) || B <- Blocks],
[I || {Pref, Body, Suff} <- merge_after(BlocksAndTargets),
I <- Pref++Body++Suff].
%% Merge the first block with other blocks that come after it
merge_after(All=[{Label, Body, [{push_label, Target}, 'JUMP']}|BlocksAndTargets]) ->
case [{B, J} || {[{'JUMPDEST', L}], B, J} <- BlocksAndTargets,
L == Target] of
[{B, J}|_] ->
merge_after([{Label, Body ++ [{'JUMPDEST', Target}] ++ B, J}|
lists:delete({[{'JUMPDEST', Target}], B, J},
BlocksAndTargets)]);
[] ->
merge_before(All)
end;
merge_after(All) ->
merge_before(All).
%% The first block cannot be merged with any blocks that it jumps
%% to... but maybe it can be merged with a block that jumps to it!
merge_before([Block={[{'JUMPDEST', Label}], Body, Jump}|BlocksAndTargets]) ->
case [{L, B, T} || {L, B, [{push_label, T}, 'JUMP']} <- BlocksAndTargets,
T == Label] of
[{L, B, T}|_] ->
merge_before([{L, B ++ [{'JUMPDEST', Label}] ++ Body, Jump}
|lists:delete({L, B, [{push_label, T}, 'JUMP']}, BlocksAndTargets)]);
_ ->
[Block | merge_after(BlocksAndTargets)]
end;
merge_before([Block|BlocksAndTargets]) ->
[Block | merge_after(BlocksAndTargets)];
merge_before([]) ->
[].
%% Convert each block to a PREFIX, which is a label or empty, a
%% middle, and a SUFFIX which is a JUMP to a label, or empty.
label_and_jump(B) ->
{Label, B1} = case B of
[{'JUMPDEST', L}|More1] ->
{[{'JUMPDEST', L}], More1};
_ ->
{[], B}
end,
{Target, B2} = case lists:reverse(B1) of
['JUMP', {push_label, T}|More2] ->
{[{push_label, T}, 'JUMP'], lists:reverse(More2)};
_ ->
{[], B1}
end,
{Label, B2, Target}.
src/aeso_memory.erl
+19
View File
@@ -0,0 +1,19 @@
%%%-------------------------------------------------------------------
%%% @copyright (C) 2018, Aeternity Anstalt
%%% @doc
%%% Memory speifics that compiler and VM need to agree upon
%%% @end
%%% Created : 19 Dec 2018
%%%-------------------------------------------------------------------
-module(aeso_memory).
-export([binary_to_words/1]).
binary_to_words(<<>>) ->
[];
binary_to_words(<<N:256,Bin/binary>>) ->
[N|binary_to_words(Bin)];
binary_to_words(Bin) ->
binary_to_words(<<Bin/binary,0>>).
src/aeso_parse_lib.erl
+413
View File
@@ -0,0 +1,413 @@
%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*-
%%%-------------------------------------------------------------------
%%% @copyright (C) 2018, Aeternity Anstalt
%%% @doc Parser combinators for the Sophia parser. Based on
%%% Koen Claessen. 2004. Parallel Parsing Processes. J. Functional
%%% Programming 14, 6 (November 2004)
%%% @end
%%%-------------------------------------------------------------------
-module(aeso_parse_lib).
-export([parse/2,
return/1, fail/0, fail/1, map/2, bind/2,
lazy/1, choice/1, choice/2, tok/1, layout/0,
left/2, right/2, between/3, optional/1,
many/1, many1/1, sep/2, sep1/2,
infixl/2, infixr/2]).
%% -- Types ------------------------------------------------------------------
-export_type([parser/1, parser_expr/1, pos/0, token/0, tokens/0]).
-type pos() :: {integer(), integer()}.
-type token() :: {atom(), pos(), term()} | {atom(), pos()}.
-type tokens() :: [token()].
-type error() :: {pos(), string() | no_error}.
-define(lazy(F), {aeso_parse_lazy, F}).
-define(fail(Err), {aeso_parse_fail, Err}).
-define(choice(Ps), {aeso_parse_choice, Ps}).
-define(bind(P, F), {aeso_parse_bind, P, F}).
-define(right(P, Q), {aeso_parse_right, P, Q}).
-define(left(P, Q), {aeso_parse_left, P, Q}).
-define(map(F, P), {aeso_parse_map, F, P}).
-define(layout, aeso_parse_layout).
-define(tok(Atom), {aeso_parse_tok, Atom}).
-define(return(X), {aeso_parse_return, X}).
%% Type synonyms since you can't have function types as macro arguments for some reason.
-type delayed(A) :: fun(() -> A).
-type continuation(A, B) :: fun((A) -> parser(B)).
-type function(A, B) :: fun((A) -> B).
%% The representation of parsers that the user writes. These get compiled down to a lower-level
%% representation before parsing (parser1/1).
-opaque parser_expr(A)
:: ?lazy(delayed(parser(A)))
| ?fail(term())
| ?choice([parser(A)])
| ?bind(parser(B), continuation(B, A))
| ?map(function(B, A), parser(B))
| ?left(parser(A), parser(A))
| ?right(parser(A), parser(A)).
%% Lists, tuples and maps of parsers are valid parsers. These are applied in left-to-right order and
%% a list/tuple/map is built out of the results. For maps only the values (and not the keys) can be
%% parsers.
-type parser(A) :: parser_expr(A)
| maybe_improper_list(parser(_), parser(_))
| tuple() %% A = tuple()
| term(). %% Interpreted as a parser that returns the term without consuming input
%% The low level parser representation. This is what's used when doing the
%% actual parsing (see parse1/2).
-type parser1(A) :: {tok_bind, #{atom() => fun((token()) -> parser1(A))}}
%% ^ Consume a token and dispatch on its tag.
| {fail, term()}
%% ^ Fail with the given error
| {return_plus, A, parser1(A)}
%% ^ Choice between returning a value and continue parsing
| {layout, fun((integer()) -> parser1(A)), parser1(A)}.
%% ^ Parse a layout block. If a layout block can be started, it commits to the
%% first argument. I.e. no backtracking to the second argument if the first
%% fails.
%% Apply a parser to its continuation. This compiles a parser to its low-level representation.
-spec apply_p(parser(A), fun((A) -> parser1(B))) -> parser1(B).
apply_p(?lazy(F), K) -> apply_p(F(), K);
apply_p(?fail(Err), _) -> {fail, Err};
apply_p(?choice([P | Ps]), K) -> lists:foldl(fun(Q, R) -> choice1(apply_p(Q, K), R) end,
apply_p(P, K), Ps);
apply_p(?bind(P, F), K) -> apply_p(P, fun(X) -> apply_p(F(X), K) end);
apply_p(?right(P, Q), K) -> apply_p(P, fun(_) -> apply_p(Q, K) end);
apply_p(?left(P, Q), K) -> apply_p(P, fun(X) -> apply_p(Q, fun(_) -> K(X) end) end);
apply_p(?map(F, P), K) -> apply_p(P, fun(X) -> K(F(X)) end);
apply_p(?layout, K) -> {layout, K, {fail, {expected, layout_block}}};
apply_p(?tok(Atom), K) -> {tok_bind, #{Atom => K}};
apply_p(?return(X), K) -> K(X);
apply_p([P | Q], K) -> apply_p(P, fun(H) -> apply_p(Q, fun(T) -> K([H | T]) end) end);
apply_p(T, K) when is_tuple(T) -> apply_p(tuple_to_list(T), fun(Xs) -> K(list_to_tuple(Xs)) end);
apply_p(M, K) when is_map(M) ->
{Keys, Ps} = lists:unzip(maps:to_list(M)),
apply_p(Ps, fun(Vals) -> K(maps:from_list(lists:zip(Keys, Vals))) end);
apply_p(X, K) -> K(X).
%% -- Primitive combinators --------------------------------------------------
%% @doc Create a delayed parser. Required when building recursive parsers to avoid looping.
-spec lazy(fun(() -> parser(A))) -> parser(A).
lazy(Delayed) -> ?lazy(Delayed).
%% @doc A parser that always fails.
-spec fail(term()) -> parser(none()).
fail(Err) -> ?fail(Err).
%% @doc Fail with no error message.
-spec fail() -> parser(none()).
fail() -> fail(no_error).
%% @doc A choice between two parsers. Succeeds if either parser succeeds.
-spec choice(parser(A), parser(A)) -> parser(A).
choice(?choice(Ps), ?choice(Qs)) -> ?choice(Ps ++ Qs);
choice(?choice(Ps), Q) -> ?choice([Q | Ps]);
choice(P, ?choice(Qs)) -> ?choice([P | Qs]);
choice(P, Q) -> ?choice([P, Q]).
%% @doc A choice between a list of parsers. Applies 'choice/2' repeatedly.
-spec choice([parser(A)]) -> parser(A).
choice([]) -> fail(empty_choice);
choice([P]) -> P;
choice([P | Ps]) -> choice(P, choice(Ps)).
%% @doc Parse a single token with the given tag.
-spec tok(atom()) -> parser(token()).
tok(Atom) -> ?tok(Atom).
%% @doc Apply two parsers in sequence and return the result from the first one.
-spec left(parser(A), parser(_)) -> parser(A).
left(P, Q) -> ?left(P, Q).
%% @doc Apply two parsers in sequence and return the result from the second one.
-spec right(parser(_), parser(A)) -> parser(A).
right(P, Q) -> ?right(P, Q).
%% @doc A parser that always succeeds with the given value.
-spec return(A) -> parser(A).
return(X) -> ?return(X).
%% @doc Monadic bind. Lets you inspect the result of the first parser before deciding on what to
%% parse next.
-spec bind(parser(A), fun((A) -> parser(B))) -> parser(B).
bind(?return(X), F) -> F(X);
bind(P, F) -> ?bind(P, F).
%% @doc Apply a function to the result of a parser.
-spec map(fun((A) -> B), parser(A)) -> parser(B).
map(Fun, P) -> ?map(Fun, P).
%% @doc Parse the start of a layout block. A layout block can start if the next token is not on the
%% same line as the previous token and it is indented further than the current layout block (if
%% any). The result is the column of the new layout block (i.e. the column of the next token).
-spec layout() -> parser(integer()).
layout() -> ?layout.
%% @doc Parse a sequence of tokens using a parser. Fails if the parse is ambiguous.
-spec parse(parser(A), tokens()) -> {ok, A} | {error, term()}.
parse(P, S) ->
case parse1(apply_p(P, fun(X) -> {return_plus, X, {fail, no_error}} end), S) of
{[], {Pos, Err}} -> {error, {Pos, parse_error, flatten_error(Err)}};
{[A], _} -> {ok, A};
{As, _} -> {error, {{1, 1}, ambiguous_parse, As}}
end.
-spec flatten_error(iolist() | no_error) -> string().
flatten_error(no_error) -> "Unspecified error";
flatten_error(Err) -> lists:flatten(Err).
%% -- Derived combinators ----------------------------------------------------
%% @doc Parse zero or more A's.
-spec many(parser(A)) -> parser([A]).
many(P) -> choice([], many1(P)).
-dialyzer({nowarn_function, many1/1}). %% Silence improper_list warning.
%% @doc Parse one or more A's.
-spec many1(parser(A)) -> parser([A]).
many1(P) -> [P | lazy(fun() -> many(P) end)].
%% @doc Parse zero or more A's, separated by Sep.
-spec sep(parser(A), parser(_)) -> parser([A]).
sep(P, Sep) -> choice([], sep1(P, Sep)).
-dialyzer({nowarn_function, sep1/2}). %% Silence improper_list warning.
%% @doc Parse one or more A's, separated by Sep.
-spec sep1(parser(A), parser(_)) -> parser([A]).
sep1(P, Sep) -> [P | many(right(Sep, P))].
%% @doc Parse a left-associative operator. <p>
%% <tt>infixl(Elem, Op) ::= Elem | infixl(Elem, Op) Op Elem</tt>
%% </p>
-spec infixl(parser(A), parser(fun((A, A) -> A))) -> parser(A).
infixl(Elem, Op) ->
bind(Elem, fun(A) ->
bind(many({Op, Elem}), fun(Ops) ->
return(build_infixl(A, Ops)) end) end).
%% @doc Parse a right-associative operator. <p>
%% <tt>infixr(Elem, Op) ::= Elem | Elem Op infixl(Elem, Op)</tt>
%% </p>
-spec infixr(parser(A), parser(fun((A, A) -> A))) -> parser(A).
infixr(Elem, Op) ->
bind(Elem, fun(A) ->
bind(many({Op, Elem}), fun(Ops) ->
return(build_infixr(A, Ops)) end) end).
build_infixl(A, []) -> A;
build_infixl(A, [{Op, B} | Ops]) -> build_infixl(Op(A, B), Ops).
build_infixr(A, []) -> A;
build_infixr(A, [{Op, B} | Ops]) -> Op(A, build_infixr(B, Ops)).
%% @doc Parse an A between two other things (typically brackets of some kind).
-spec between(parser(_), parser(A), parser(_)) -> parser(A).
between(L, P, R) ->
right(L, left(P, R)).
-spec optional(parser(A)) -> parser(none | {ok, A}).
optional(P) -> choice(none, {ok, P}).
%% -- Internal functions -----------------------------------------------------
-spec tag(token()) -> atom().
tag(T) when is_tuple(T) -> element(1, T).
-spec pos(token()) -> pos().
pos(T) when is_tuple(T) -> element(2, T).
-spec line(token()) -> integer().
line(T) when is_tuple(T) -> element(1, pos(T)).
-spec col(token()) -> integer().
col(T) when is_tuple(T) -> element(2, pos(T)).
%% Choice on low-level parsers.
-spec choice1(parser1(A), parser1(A)) -> parser1(A).
%% If both parsers want the next token we grab it and merge the continuations.
choice1({tok_bind, Map1}, {tok_bind, Map2}) ->
{tok_bind, merge_with(fun(F, G) -> fun(T) -> choice1(F(T), G(T)) end end, Map1, Map2)};
%% If both parsers fail we combine the error messages. If only one fails we discard it.
choice1({fail, E1}, {fail, E2}) -> {fail, add_error(E1, E2)};
choice1({fail, _}, Q) -> Q;
choice1(P, {fail, _}) -> P;
%% If either side can deliver a value, then so can the choice.
choice1({return_plus, X, P}, Q) -> {return_plus, X, choice1(P, Q)};
choice1(P, {return_plus, X, Q}) -> {return_plus, X, choice1(P, Q)};
%% If both sides want a layout block we combine them. If only one side wants a layout block we
%% will commit to a layout block is there is one.
choice1({layout, F, P}, {layout, G, Q}) ->
{layout, fun(N) -> choice1(F(N), G(N)) end, choice1(P, Q)};
choice1({layout, F, P}, Q) -> {layout, F, choice1(P, Q)};
choice1(P, {layout, G, Q}) -> {layout, G, choice1(P, Q)}.
%% Token stream representation. This is the state of the parse function.
-record(ts, {layout :: [integer()], %% Column numbers of the current layout blocks.
last :: token(), %% The previously consumed token.
inserted :: tokens(), %% Inserted layout tokens, consumed before 'tokens'.
tokens :: tokens()}). %% The remaining tokens to be parsed.
%% The initial token stream.
ts(S) ->
#ts{ layout = [], last = {bof, {0, 0}}, inserted = [], tokens = S }.
%% The parse function. Parses a token stream returning a list of results and an error message in
%% case of failure.
-spec parse1(parser1(A), tokens()) -> {[A], term()}.
parse1(P, S) ->
parse1(P, ts(S), [], no_error).
%% The main work horse. Returns a list of possible parses and an error message in case parsing
%% fails.
-spec parse1(parser1(A), #ts{}, [A], term()) -> {[A], error()}.
parse1({tok_bind, Map}, Ts, Acc, Err) ->
case next_token(Ts) of
{T, Ts1} ->
case maps:get(tag(T), Map, '$not_found') of
'$not_found' ->
%% Insert a vclose (if required) on unexpected tokens. This lets you have layout
%% blocks inside parens without having to put the closing paren on a separate
%% line. Example:
%% ((x) =>
%% let y = x + 1
%% y + y)(4)
case maps:get(vclose, Map, '$not_found') of
'$not_found' ->
{Acc, unexpected_token_error(Ts, T)};
F ->
VClose = {vclose, pos(T)},
Ts2 = pop_layout(VClose, Ts#ts{ last = VClose }),
parse1(F(VClose), Ts2, Acc, Err)
end;
F -> parse1(F(T), Ts1, Acc, Err)
end;
false ->
{Acc, mk_error(Ts, io_lib:format("Unexpected end of file. Expected one of ~p.",
[maps:keys(Map)]))}
end;
parse1({layout, F, P}, Ts, Acc, Err) ->
case start_layout(Ts) of
{Col, Ts1} -> parse1(F(Col), Ts1, Acc, Err);
false -> parse1(P, Ts, Acc, mk_error(Ts, "Expected layout block."))
end;
parse1({return_plus, X, P}, Ts, Acc, Err) ->
case next_token(Ts) of
false -> parse1(P, Ts, [X | Acc], Err);
{T, _} -> parse1(P, Ts, Acc, unexpected_token_error(Ts, T))
end;
parse1({fail, Err}, Ts, Acc, Err1) ->
Err2 = case next_token(Ts) of
{T, _} -> unexpected_token_error(Ts, T);
_ -> no_error
end,
{Acc, add_error(add_error(mk_error(Ts, Err), Err2), Err1)}.
%% Get the current position of the token stream. This is the position of the next token if any, and
%% the line after the last token if at the end of the stream.
-spec current_pos(#ts{}) -> pos().
current_pos(#ts{ inserted = [T | _] }) -> pos(T);
current_pos(#ts{ tokens = [T | _] }) -> pos(T);
current_pos(#ts{ last = T }) -> end_pos(pos(T)).
-spec mk_error(#ts{}, term()) -> error().
mk_error(Ts, Err) ->
{current_pos(Ts), Err}.
-spec unexpected_token_error(#ts{}, token()) -> error().
unexpected_token_error(Ts, T) ->
mk_error(Ts, io_lib:format("Unexpected token ~p", [tag(T)])).
%% Get the next token from a token stream. Inserts layout tokens if necessary.
-spec next_token(#ts{}) -> false | {token(), #ts{}}.
next_token(Ts) ->
case insert_layout_tokens(Ts) of
Ts1 = #ts{ inserted = [L | Ls] } -> {L, pop_layout(L, Ts1#ts{ last = L, inserted = Ls })};
Ts1 = #ts{ tokens = [T | S] } -> {T, Ts1#ts{ last = T, tokens = S }};
#ts{ inserted = [], tokens = [] } -> false
end.
%% Pop a layout block on an inserted 'vclose' token.
-spec pop_layout(token(), #ts{}) -> #ts{}.
pop_layout({vclose, _}, Ts = #ts{ layout = [_ | Layout] }) -> Ts#ts{ layout = Layout };
pop_layout(_, Ts) -> Ts.
%% Attempt to start a new layout block. Requires the next token to be on a new line and indented
%% more than any existing layout block. Sets the previous token to 'vopen'.
-spec start_layout(#ts{}) -> false | {integer(), #ts{}}.
start_layout(#ts{ inserted = [_ | _] }) -> false; %% Can't start a layout block before consuming all layout tokens
start_layout(#ts{ tokens = [] }) -> false; %% No more tokens
start_layout(Ts = #ts{ layout = Layout, last = Last, tokens = [T | _] }) ->
Col = col(T),
Valid = case Layout of
[] -> line(Last) < line(T);
[C1 | _] -> line(Last) < line(T) andalso C1 < Col
end,
Valid andalso {Col, Ts#ts{ layout = [Col | Layout], last = {vopen, pos(T)} }}.
%% Insert layout tokens. If the next token is on the same line as the current layout block we insert
%% a 'vsemi' token. If the next token is indented less, we insert a 'vclose' token.
-spec insert_layout_tokens(#ts{}) -> #ts{}.
insert_layout_tokens(Ts = #ts{ inserted = [_ | _] }) ->
Ts; %% already inserted layout tokens
insert_layout_tokens(Ts = #ts{ layout = Layout, last = Last, tokens = S }) ->
ToInsert = insert_layout_tokens(Layout, Last, S, []),
Ts#ts{ inserted = ToInsert }.
%% Compute the layout tokens to be inserted.
-spec insert_layout_tokens([integer()], token(), tokens(), tokens()) -> tokens().
insert_layout_tokens([_ | Layout], Last, [], Acc) ->
%% End of the file. Insert vclose tokens for all layout blocks.
Vclose = {vclose, end_pos(pos(Last))},
insert_layout_tokens(Layout, Last, [], [Vclose | Acc]);
insert_layout_tokens([N | Layout1], Last, S = [T | _], Acc) ->
Col = col(T),
%% Don't insert a vsemi if the previous token was a vopen or a vsemi. The former to avoid a
%% vsemi for the first token of the block and the latter to avoid inserting infinite vsemis.
AlreadySemi = lists:member(tag(Last), [vsemi, vopen]) andalso col(Last) == N,
if Col == N, not AlreadySemi ->
lists:reverse([{vsemi, pos(T)} | Acc]);
Col < N ->
Vclose = {vclose, pos(T)},
insert_layout_tokens(Layout1, Vclose, S, [Vclose | Acc]);
true ->
lists:reverse(Acc)
end;
insert_layout_tokens([], _Last, _S, Acc) ->
lists:reverse(Acc).
%% The end-of-file position. Beginning of the line after the last token.
end_pos({L, _}) -> {L + 1, 1}.
%% Combine two error messages. Discard no_error's otherwise pick the first error.
add_error(no_error, Err) -> Err;
add_error({_, no_error}, Err) -> Err;
add_error(Err, no_error) -> Err;
add_error(Err, {_, no_error}) -> Err;
add_error(Err, _Err1) -> Err.
%% For some unfathomable reason the maps module does not have a merge_with function.
-spec merge_with(fun((term(), term()) -> term()), map(), map()) -> map().
merge_with(Fun, Map1, Map2) ->
case maps:size(Map1) > maps:size(Map2) of
true ->
lists:foldl(fun({K, R}, M) ->
maps:update_with(K, fun(L) -> Fun(L, R) end, R, M)
end, Map1, maps:to_list(Map2));
false ->
lists:foldl(fun({K, L}, M) ->
maps:update_with(K, fun(R) -> Fun(L, R) end, L, M)
end, Map2, maps:to_list(Map1))
end.
src/aeso_parse_lib.hrl
+25
View File
@@ -0,0 +1,25 @@
-define(LET_P(X, P, Q), aeso_parse_lib:bind(P, fun(X) -> Q end)).
-define(LAZY_P(P), aeso_parse_lib:lazy(fun() -> P end)).
-define(MEMO_P(P), aeso_parse_lib:lazy(aeso_parse_lib:memoised(fun() -> P end))).
-define(GUARD_P(G, P),
case G of
true -> P;
false -> fail()
end).
-define(RULE(A, Do), map(fun(_1) -> Do end, A )).
-define(RULE(A, B, Do), map(fun({_1, _2}) -> Do end, {A, B} )).
-define(RULE(A, B, C, Do), map(fun({_1, _2, _3}) -> Do end, {A, B, C} )).
-define(RULE(A, B, C, D, Do), map(fun({_1, _2, _3, _4}) -> Do end, {A, B, C, D} )).
-define(RULE(A, B, C, D, E, Do), map(fun({_1, _2, _3, _4, _5}) -> Do end, {A, B, C, D, E} )).
-define(RULE(A, B, C, D, E, F, Do), map(fun({_1, _2, _3, _4, _5, _6}) -> Do end, {A, B, C, D, E, F})).
-import(aeso_parse_lib,
[tok/1, tok/2, between/3, many/1, many1/1, sep/2, sep1/2,
infixl/1, infixr/1, choice/1, choice/2, return/1, layout/0,
fail/0, fail/1, map/2, infixl/2, infixr/2, infixl1/2, infixr1/2,
left/2, right/2, optional/1]).
src/aeso_parser.erl
+457
View File
@@ -0,0 +1,457 @@
%%% File : aeso_parser.erl
%%% Author : Ulf Norell
%%% Description :
%%% Created : 1 Mar 2018 by Ulf Norell
-module(aeso_parser).
-export([string/1,
type/1]).
-include("aeso_parse_lib.hrl").
-spec string(string()) ->
{ok, aeso_syntax:ast()}
| {error, {aeso_parse_lib:pos(),
atom(),
term()}}
| {error, {aeso_parse_lib:pos(),
atom()}}.
string(String) ->
parse_and_scan(file(), String).
type(String) ->
parse_and_scan(type(), String).
parse_and_scan(P, S) ->
case aeso_scan:scan(S) of
{ok, Tokens} -> aeso_parse_lib:parse(P, Tokens);
Error -> Error
end.
%% -- Parsing rules ----------------------------------------------------------
file() -> choice([], block(decl())).
decl() ->
?LAZY_P(
choice(
%% Contract declaration
[ ?RULE(keyword(contract), con(), tok('='), maybe_block(decl()), {contract, _1, _2, _4})
%% Type declarations TODO: format annotation for "type bla" vs "type bla()"
, ?RULE(keyword(type), id(), {type_decl, _1, _2, []})
, ?RULE(keyword(type), id(), type_vars(), {type_decl, _1, _2, _3})
, ?RULE(keyword(type), id(), tok('='), typedef(type), {type_def, _1, _2, [], _4})
, ?RULE(keyword(type), id(), type_vars(), tok('='), typedef(type), {type_def, _1, _2, _3, _5})
, ?RULE(keyword(record), id(), tok('='), typedef(record), {type_def, _1, _2, [], _4})
, ?RULE(keyword(record), id(), type_vars(), tok('='), typedef(record), {type_def, _1, _2, _3, _5})
, ?RULE(keyword(datatype), id(), tok('='), typedef(variant), {type_def, _1, _2, [], _4})
, ?RULE(keyword(datatype), id(), type_vars(), tok('='), typedef(variant), {type_def, _1, _2, _3, _5})
%% Function declarations
, ?RULE(modifiers(), keyword(function), id(), tok(':'), type(), add_modifiers(_1, {fun_decl, _2, _3, _5}))
, ?RULE(modifiers(), keyword(function), fundef(), add_modifiers(_1, set_pos(get_pos(_2), _3)))
, ?RULE(keyword('let'), valdef(), set_pos(get_pos(_1), _2))
])).
modifiers() ->
many(choice([token(stateful), token(public), token(private), token(internal)])).
add_modifiers(Mods, Node) ->
lists:foldl(fun({Mod, _}, X) -> set_ann(Mod, true, X) end,
Node, Mods).
%% -- Type declarations ------------------------------------------------------
typedef(type) -> ?RULE(type(), {alias_t, _1});
typedef(record) -> ?RULE(brace_list(field_type()), {record_t, _1});
typedef(variant) -> ?RULE(constructors(), {variant_t, _1}).
constructors() ->
sep1(constructor(), tok('|')).
constructor() -> %% TODO: format for Con() vs Con
choice(?RULE(con(), {constr_t, get_ann(_1), _1, []}),
?RULE(con(), con_args(), {constr_t, get_ann(_1), _1, _2})).
con_args() -> paren_list(con_arg()).
type_args() -> paren_list(type()).
field_type() -> ?RULE(id(), tok(':'), type(), {field_t, get_ann(_1), _1, _3}).
con_arg() -> choice(type(), ?RULE(keyword(indexed), type(), set_ann(indexed, true, _2))).
%% -- Let declarations -------------------------------------------------------
letdecl() ->
choice(
?RULE(keyword('let'), letdef(), set_pos(get_pos(_1), _2)),
?RULE(keyword('let'), tok(rec), sep1(letdef(), tok('and')), {letrec, _1, _3})).
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})).
fundef() ->
choice(
[ ?RULE(id(), args(), tok('='), body(), {letfun, [], _1, _2, type_wildcard(), _4})
, ?RULE(id(), args(), tok(':'), type(), tok('='), body(), {letfun, [], _1, _2, _4, _6})
]).
args() -> paren_list(arg()).
arg() -> choice(
?RULE(id(), {arg, get_ann(_1), _1, type_wildcard()}),
?RULE(id(), tok(':'), type(), {arg, get_ann(_1), _1, _3})).
%% -- Types ------------------------------------------------------------------
type_vars() -> paren_list(tvar()).
type() -> ?LAZY_P(type100()).
type100() -> type200().
type200() ->
?RULE(many({fun_domain(), keyword('=>')}), type300(), fun_t(_1, _2)).
type300() -> type400().
type400() ->
?RULE(typeAtom(), optional(type_args()),
case _2 of
none -> _1;
{ok, Args} -> {app_t, get_ann(_1), _1, Args}
end).
typeAtom() ->
?LAZY_P(choice(
[ id(), token(con), token(qcon), token(qid), tvar()
, ?RULE(keyword('('), comma_sep(type()), tok(')'), tuple_t(_1, _2))
])).
fun_domain() -> ?RULE(?LAZY_P(type300()), fun_domain(_1)).
%% -- Statements -------------------------------------------------------------
body() ->
?LET_P(Stmts, maybe_block(stmt()), block_e(Stmts)).
stmt() ->
?LAZY_P(choice(
[ expr()
, letdecl()
, {switch, keyword(switch), parens(expr()), maybe_block(branch())}
, {'if', keyword('if'), parens(expr()), body()}
, {elif, keyword(elif), parens(expr()), body()}
, {else, keyword(else), body()}
])).
branch() ->
?RULE(pattern(), keyword('=>'), body(), {'case', _2, _1, _3}).
pattern() ->
?LET_P(E, expr500(), parse_pattern(E)).
%% -- Expressions ------------------------------------------------------------
expr() -> expr100().
expr100() ->
Expr100 = ?LAZY_P(expr100()),
Expr200 = ?LAZY_P(expr200()),
choice(
[ ?RULE(args(), keyword('=>'), body(), {lam, _2, _1, _3}) %% TODO: better location
, {'if', keyword('if'), parens(Expr100), Expr200, right(tok(else), Expr100)}
, ?RULE(Expr200, optional(right(tok(':'), type())),
case _2 of
none -> _1;
{ok, Type} -> {typed, get_ann(_1), _1, Type}
end)
]).
expr200() -> infixr(expr300(), binop('||')).
expr300() -> infixr(expr400(), binop('&&')).
expr400() -> infix(expr500(), binop(['<', '>', '=<', '>=', '==', '!='])).
expr500() -> infixr(expr600(), binop(['::', '++'])).
expr600() -> infixl(expr650(), binop(['+', '-', 'bor', 'bxor', 'bsr', 'bsl'])).
expr650() -> ?RULE(many(token('-')), expr700(), prefixes(_1, _2)).
expr700() -> infixl(expr750(), binop(['*', '/', mod, 'band'])).
expr750() -> infixl(expr800(), binop(['^'])).
expr800() -> ?RULE(many(choice(token('!'), token('bnot'))), expr900(), prefixes(_1, _2)).
expr900() -> ?RULE(exprAtom(), many(elim()), elim(_1, _2)).
exprAtom() ->
?LAZY_P(begin
Expr = ?LAZY_P(expr()),
choice(
[ id(), con(), token(qid), token(qcon)
, token(hash), token(string), token(char)
, token(int)
, ?RULE(token(hex), set_ann(format, hex, setelement(1, _1, int)))
, {bool, keyword(true), true}
, {bool, keyword(false), false}
, ?RULE(brace_list(?LAZY_P(field_assignment())), record(_1))
, {list, [], bracket_list(Expr)}
, ?RULE(tok('['), Expr, binop('..'), Expr, tok(']'), _3(_2, _4))
, ?RULE(keyword('('), comma_sep(Expr), tok(')'), tuple_e(_1, _2))
])
end).
arg_expr() ->
?LAZY_P(
choice([ ?RULE(id(), tok('='), expr(), {named_arg, [], _1, _3})
, expr() ])).
elim() ->
?LAZY_P(
choice(
[ {proj, keyword('.'), id()}
, ?RULE(paren_list(arg_expr()), {app, [], _1})
, ?RULE(keyword('{'), comma_sep(field_assignment()), tok('}'), {rec_upd, _1, _2})
, ?RULE(keyword('['), map_key(), keyword(']'), map_get(_1, _2))
])).
map_get(Ann, {map_key, Key}) -> {map_get, Ann, Key};
map_get(Ann, {map_key, Key, Val}) -> {map_get, Ann, Key, Val}.
map_key() ->
?RULE(expr(), optional({tok('='), expr()}), map_key(_1, _2)).
map_key(Key, none) -> {map_key, Key};
map_key(Key, {ok, {_, Val}}) -> {map_key, Key, Val}.
elim(E, []) -> E;
elim(E, [{proj, Ann, P} | Es]) -> elim({proj, Ann, E, P}, Es);
elim(E, [{app, Ann, Args} | Es]) -> elim({app, Ann, E, Args}, Es);
elim(E, [{rec_upd, Ann, Flds} | Es]) -> elim(record_update(Ann, E, Flds), Es);
elim(E, [{map_get, Ann, Key} | Es]) -> elim({map_get, Ann, E, Key}, Es);
elim(E, [{map_get, Ann, Key, Val} | Es]) -> elim({map_get, Ann, E, Key, Val}, Es).
record_update(Ann, E, Flds) ->
{record_or_map(Flds), Ann, E, Flds}.
record([]) -> {map, [], []};
record(Fs) ->
case record_or_map(Fs) of
record -> {record, get_ann(hd(Fs)), Fs};
map ->
Ann = get_ann(hd(Fs ++ [{empty, []}])), %% TODO: source location for empty maps
KV = fun({field, _, [{map_get, _, Key}], Val}) -> {Key, Val};
({field, _, LV, Id, _}) ->
bad_expr_err("Cannot use '@' in map construction", infix(LV, {op, Ann, '@'}, Id));
({field, _, LV, _}) ->
bad_expr_err("Cannot use nested fields or keys in map construction", LV) end,
{map, Ann, lists:map(KV, Fs)}
end.
record_or_map(Fields) ->
Kind = fun(Fld) -> case element(3, Fld) of
[{proj, _, _} | _] -> proj;
[{map_get, _, _} | _] -> map_get;
[{map_get, _, _, _} | _] -> map_get
end end,
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})
end.
field_assignment() ->
?RULE(lvalue(), optional({tok('@'), id()}), tok('='), expr(), field_assignment(get_ann(_3), _1, _2, _4)).
field_assignment(Ann, LV, none, E) ->
{field, Ann, LV, E};
field_assignment(Ann, LV, {ok, {_, Id}}, E) ->
{field, Ann, LV, Id, E}.
lvalue() ->
?RULE(lvalueAtom(), many(elim()), lvalue(elim(_1, _2))).
lvalueAtom() ->
?LAZY_P(choice([ id()
, ?RULE(keyword('['), map_key(), keyword(']'), _2)
])).
lvalue(E) -> lvalue(E, []).
lvalue(X = {id, Ann, _}, LV) -> [{proj, Ann, X} | LV];
lvalue({map_key, K}, LV) -> [{map_get, get_ann(K), K} | LV];
lvalue({map_key, K, V}, LV) -> [{map_get, get_ann(K), K, V} | LV];
lvalue({proj, Ann, E, P}, LV) -> lvalue(E, [{proj, Ann, P} | LV]);
lvalue({map_get, Ann, E, K}, LV) -> lvalue(E, [{map_get, Ann, K} | LV]);
lvalue({map_get, Ann, E, K, V}, LV) -> lvalue(E, [{map_get, Ann, K, V} | LV]);
lvalue(E, _) -> bad_expr_err("Not a valid lvalue", E).
infix(E, Op) ->
?RULE(E, optional({Op, E}),
case _2 of
none -> _1;
{ok, {F, Arg}} -> F(_1, Arg)
end).
binop(Op) when is_atom(Op) -> binop([Op]);
binop(Ops) ->
?RULE(choice([ token(Op) || Op <- Ops ]), fun(A, B) -> infix(A, _1, B) end).
con() -> token(con).
id() -> token(id).
tvar() -> token(tvar).
token(Tag) ->
?RULE(tok(Tag),
case _1 of
{Tok, {Line, Col}} -> {Tok, pos_ann(Line, Col)};
{Tok, {Line, Col}, Val} -> {Tok, pos_ann(Line, Col), Val}
end).
%% -- Helpers ----------------------------------------------------------------
keyword(K) -> ann(tok(K)).
ann(P) -> map(fun get_ann/1, P).
block(P) ->
between(layout(), sep1(P, tok(vsemi)), tok(vclose)).
maybe_block(P) ->
choice(block(P), [P]).
parens(P) -> between(tok('('), P, tok(')')).
braces(P) -> between(tok('{'), P, tok('}')).
brackets(P) -> between(tok('['), P, tok(']')).
comma_sep(P) -> sep(P, tok(',')).
paren_list(P) -> parens(comma_sep(P)).
brace_list(P) -> braces(comma_sep(P)).
bracket_list(P) -> brackets(comma_sep(P)).
%% -- Annotations ------------------------------------------------------------
-type ann() :: aeso_syntax:ann().
-type ann_line() :: aeso_syntax:ann_line().
-type ann_col() :: aeso_syntax:ann_col().
-spec pos_ann(ann_line(), ann_col()) -> ann().
pos_ann(Line, Col) -> [{line, Line}, {col, Col}].
ann_pos(Ann) ->
{proplists:get_value(line, Ann),
proplists:get_value(col, Ann)}.
get_ann(Ann) when is_list(Ann) -> Ann;
get_ann(Node) ->
case element(2, Node) of
{Line, Col} when is_integer(Line), is_integer(Col) -> pos_ann(Line, Col);
Ann -> Ann
end.
get_ann(Key, Node) ->
proplists:get_value(Key, get_ann(Node)).
set_ann(Key, Val, Node) ->
Ann = get_ann(Node),
setelement(2, Node, lists:keystore(Key, 1, Ann, {Key, Val})).
get_pos(Node) ->
{get_ann(line, Node), get_ann(col, Node)}.
set_pos({L, C}, Node) ->
set_ann(line, L, set_ann(col, C, Node)).
infix(L, Op, R) -> set_ann(format, infix, {app, get_ann(L), Op, [L, R]}).
prefixes(Ops, E) -> lists:foldr(fun prefix/2, E, Ops).
prefix(Op, E) -> set_ann(format, prefix, {app, get_ann(Op), Op, [E]}).
type_wildcard() ->
{id, [{origin, system}], "_"}.
block_e(Stmts) ->
group_ifs(Stmts, []).
group_ifs([], [Stmt]) -> return(Stmt);
group_ifs([], Acc) ->
Stmts = [Stmt | _] = lists:reverse(Acc),
{block, get_ann(Stmt), Stmts};
group_ifs([{'if', Ann, Cond, Then} | Stmts], Acc) ->
{Elses, Rest} = else_branches(Stmts, []),
group_ifs(Rest, [build_if(Ann, Cond, Then, Elses) | Acc]);
group_ifs([{else, Ann, _} | _], _) ->
fail({Ann, "No matching 'if' for 'else'"});
group_ifs([{elif, Ann, _, _} | _], _) ->
fail({Ann, "No matching 'if' for 'elif'"});
group_ifs([Stmt | Stmts], Acc) ->
group_ifs(Stmts, [Stmt | Acc]).
build_if(Ann, Cond, Then, [{elif, Ann1, Cond1, Then1} | Elses]) ->
{'if', Ann, Cond, Then,
set_ann(format, elif, build_if(Ann1, Cond1, Then1, Elses))};
build_if(Ann, Cond, Then, [{else, _Ann, Else}]) ->
{'if', Ann, Cond, Then, Else};
build_if(Ann, Cond, Then, []) ->
{'if', Ann, Cond, Then, {unit, [{origin, system}]}}.
else_branches([Elif = {elif, _, _, _} | Stmts], Acc) ->
else_branches(Stmts, [Elif | Acc]);
else_branches([Else = {else, _, _} | Stmts], Acc) ->
{lists:reverse([Else | Acc]), Stmts};
else_branches(Stmts, Acc) ->
{lists:reverse(Acc), Stmts}.
tuple_t(_Ann, [Type]) -> Type; %% Not a tuple
tuple_t(Ann, Types) -> {tuple_t, Ann, Types}.
fun_t(Domains, Type) ->
lists:foldr(fun({Dom, Ann}, T) -> {fun_t, Ann, [], Dom, T} end,
Type, Domains).
tuple_e(Ann, []) -> {unit, Ann};
tuple_e(_Ann, [Expr]) -> Expr; %% Not a tuple
tuple_e(Ann, Exprs) -> {tuple, Ann, Exprs}.
%% TODO: not nice
fun_domain({tuple_t, _, Args}) -> Args;
fun_domain(T) -> [T].
-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}) ->
{app, Ann, Con, lists:map(fun parse_pattern/1, Es)};
parse_pattern({tuple, Ann, Es}) ->
{tuple, Ann, lists:map(fun parse_pattern/1, Es)};
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(E = {con, _, _}) -> E;
parse_pattern(E = {id, _, _}) -> E;
parse_pattern(E = {unit, _}) -> E;
parse_pattern(E = {int, _, _}) -> E;
parse_pattern(E = {bool, _, _}) -> E;
parse_pattern(E = {hash, _, _}) -> E;
parse_pattern(E = {string, _, _}) -> E;
parse_pattern(E = {char, _, _}) -> E;
parse_pattern(E) -> bad_expr_err("Not a valid pattern", E).
-spec parse_field_pattern(aeso_syntax:field(aeso_syntax:expr())) -> aeso_parse_lib:parser(aeso_syntax:field(aeso_syntax:pat())).
parse_field_pattern({field, Ann, F, E}) ->
{field, Ann, F, parse_pattern(E)}.
return_error({L, C}, Err) ->
fail(io_lib:format("~p:~p:\n~s", [L, C, Err])).
-spec ret_doc_err(ann(), prettypr:document()) -> no_return().
ret_doc_err(Ann, Doc) ->
return_error(ann_pos(Ann), prettypr:format(Doc)).
-spec bad_expr_err(string(), aeso_syntax:expr()) -> no_return().
bad_expr_err(Reason, E) ->
ret_doc_err(get_ann(E),
prettypr:sep([prettypr:text(Reason ++ ":"),
prettypr:nest(2, aeso_pretty:expr(E))])).
src/aeso_pretty.erl
+441
View File
@@ -0,0 +1,441 @@
%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*-
%%%-------------------------------------------------------------------
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc Pretty printer for Sophia.
%%%
%%% @end
%%%-------------------------------------------------------------------
-module(aeso_pretty).
-import(prettypr, [text/1, sep/1, above/2, beside/2, nest/2, empty/0]).
-export([decls/1, decls/2, decl/1, decl/2, expr/1, expr/2, type/1, type/2]).
-export_type([options/0]).
-type doc() :: prettypr:document().
-type options() :: [{indent, non_neg_integer()} | show_generated].
%% More options:
%% Newline before open curly
%% Space before ':'
%% -- Options ----------------------------------------------------------------
-define(aeso_pretty_opts, aeso_pretty_opts).
-spec options() -> options().
options() ->
case get(?aeso_pretty_opts) of
undefined -> [];
Opts -> Opts
end.
-spec option(atom(), any()) -> any().
option(Key, Default) ->
proplists:get_value(Key, options(), Default).
-spec show_generated() -> boolean().
show_generated() -> option(show_generated, false).
-spec indent() -> non_neg_integer().
indent() -> option(indent, 2).
-spec with_options(options(), fun(() -> A)) -> A.
with_options(Options, Fun) ->
put(?aeso_pretty_opts, Options),
Res = Fun(),
erase(?aeso_pretty_opts),
Res.
%% -- Pretty printing helpers ------------------------------------------------
-spec par([doc()]) -> doc().
par(Ds) -> par(Ds, indent()).
-spec par([doc()], non_neg_integer()) -> doc().
par([], _) -> empty();
par(Ds, N) -> prettypr:par(Ds, N).
-spec follow(doc(), doc(), non_neg_integer()) -> doc().
follow(A, B, N) ->
sep([A, nest(N, B)]).
-spec follow(doc(), doc()) -> doc().
follow(A, B) -> follow(A, B, indent()).
-spec above([doc()]) -> doc().
above([]) -> empty();
above([D]) -> D;
above([D | Ds]) -> lists:foldl(fun(X, Y) -> above(Y, X) end, D, Ds).
-spec beside([doc()]) -> doc().
beside([]) -> empty();
beside([D]) -> D;
beside([D | Ds]) -> lists:foldl(fun(X, Y) -> beside(Y, X) end, D, Ds).
-spec hsep([doc()]) -> doc().
hsep(Ds) -> beside(punctuate(text(" "), [ D || D <- Ds, D /= empty() ])).
-spec hsep(doc(), doc()) -> doc().
hsep(D1, D2) -> hsep([D1, D2]).
-spec punctuate(doc(), [doc()]) -> [doc()].
punctuate(_Sep, []) -> [];
punctuate(_Sep, [D]) -> [D];
punctuate(Sep, [D | Ds]) -> [beside(D, Sep) | punctuate(Sep, Ds)].
-spec paren(doc()) -> doc().
paren(D) -> beside([text("("), D, text(")")]).
-spec paren(boolean(), doc()) -> doc().
paren(false, D) -> D;
paren(true, D) -> paren(D).
-spec indent(doc()) -> doc().
indent(D) -> nest(indent(), D).
%% block(Header, Body) ->
%% Header
%% Body
-spec block(doc(), doc()) -> doc().
block(Header, Body) ->
sep([ Header, indent(Body) ]).
-spec comma_brackets(string(), string(), [doc()]) -> doc().
comma_brackets(Open, Close, Ds) ->
beside([text(Open), par(punctuate(text(","), Ds), 0), text(Close)]).
-spec tuple([doc()]) -> doc().
tuple(Ds) ->
comma_brackets("(", ")", Ds).
-spec list([doc()]) -> doc().
list(Ds) ->
comma_brackets("[", "]", Ds).
-spec record([doc()]) -> doc().
record(Ds) ->
comma_brackets("{", "}", Ds).
%% equals(A, B) -> A = B
-spec equals(doc(), doc()) -> doc().
equals(A, B) -> follow(hsep(A, text("=")), B).
%% typed(A, B) -> A : B.
-spec typed(doc(), aeso_syntax:type()) -> doc().
typed(A, Type) ->
case aeso_syntax:get_ann(origin, Type) == system andalso
not show_generated() of
true -> A;
false -> follow(hsep(A, text(":")), type(Type))
end.
%% -- Exports ----------------------------------------------------------------
-spec decls([aeso_syntax:decl()], options()) -> doc().
decls(Ds, Options) ->
with_options(Options, fun() -> decls(Ds) end).
-spec decls([aeso_syntax:decl()]) -> doc().
decls(Ds) -> above([ decl(D) || D <- Ds ]).
-spec decl(aeso_syntax:decl(), options()) -> doc().
decl(D, Options) ->
with_options(Options, fun() -> decl(D) end).
-spec decl(aeso_syntax:decl()) -> doc().
decl({contract, _, C, Ds}) ->
block(follow(text("contract"), hsep(name(C), text("="))), decls(Ds));
decl({type_decl, _, T, Vars}) -> typedecl(alias_t, T, Vars);
decl({type_def, _, T, Vars, Def}) ->
Kind = element(1, Def),
equals(typedecl(Kind, T, Vars), typedef(Def));
decl({fun_decl, _, F, T}) ->
hsep(text("function"), typed(name(F), T));
decl(D = {letfun, Attrs, _, _, _, _}) ->
Mod = fun({Mod, true}) when Mod == private; Mod == internal; Mod == public; Mod == stateful ->
text(atom_to_list(Mod));
(_) -> empty() end,
hsep(lists:map(Mod, Attrs) ++ [letdecl("function", D)]);
decl(D = {letval, _, _, _, _}) -> letdecl("let", D);
decl(D = {letrec, _, _}) -> letdecl("let", D).
-spec expr(aeso_syntax:expr(), options()) -> doc().
expr(E, Options) ->
with_options(Options, fun() -> expr(E) end).
-spec expr(aeso_syntax:expr()) -> doc().
expr(E) -> expr_p(0, E).
%% -- Not exported -----------------------------------------------------------
-spec name(aeso_syntax:id() | aeso_syntax:con() | aeso_syntax:tvar()) -> doc().
name({id, _, Name}) -> text(Name);
name({con, _, Name}) -> text(Name);
name({qid, _, Names}) -> text(string:join(Names, "."));
name({qcon, _, Names}) -> text(string:join(Names, "."));
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, {letfun, _, F, Args, T, E}) ->
block_expr(0, hsep([text(Let), typed(beside(name(F), args(Args)), T), text("=")]), E);
letdecl(Let, {letrec, _, [D | Ds]}) ->
hsep(text(Let), above([ letdecl("rec", D) | [ letdecl("and", D1) || D1 <- Ds ] ])).
-spec args([aeso_syntax:arg()]) -> doc().
args(Args) ->
tuple(lists:map(fun arg/1, Args)).
-spec arg(aeso_syntax:arg()) -> doc().
arg({arg, _, X, T}) -> typed(name(X), T).
-spec typedecl(alias_t | record_t | variant_t, aeso_syntax:id(), [aeso_syntax:tvar()]) -> doc().
typedecl(Kind, T, Vars) ->
KW = case Kind of
alias_t -> text("type");
record_t -> text("record");
variant_t -> text("datatype")
end,
case Vars of
[] -> hsep(KW, name(T));
_ -> beside(hsep(KW, name(T)),
tuple(lists:map(fun name/1, Vars)))
end.
-spec typedef(aeso_syntax:typedef()) -> doc().
typedef({alias_t, Type}) -> type(Type);
typedef({record_t, Fields}) ->
record(lists:map(fun field_t/1, Fields));
typedef({variant_t, Constructors}) ->
par(punctuate(text(" |"), lists:map(fun constructor_t/1, Constructors))).
-spec constructor_t(aeso_syntax:constructor_t()) -> doc().
constructor_t({constr_t, _, C, []}) -> name(C);
constructor_t({constr_t, _, C, Args}) -> beside(name(C), tuple_type(Args)).
-spec field_t(aeso_syntax:field_t()) -> doc().
field_t({field_t, _, Name, Type}) ->
typed(name(Name), Type).
-spec type(aeso_syntax:type(), options()) -> doc().
type(Type, Options) ->
with_options(Options, fun() -> type(Type) end).
-spec type(aeso_syntax:type()) -> doc().
type({fun_t, _, Named, Args, Ret}) ->
follow(hsep(tuple_type(Named ++ Args), text("=>")), type(Ret));
type({app_t, _, Type, []}) ->
type(Type);
type({app_t, _, Type, Args}) ->
beside(type(Type), tuple_type(Args));
type({tuple_t, _, Args}) ->
tuple_type(Args);
type({named_arg_t, _, Name, Type, Default}) ->
follow(hsep(typed(name(Name), Type), text("=")), expr(Default));
type(R = {record_t, _}) -> typedef(R);
type(T = {id, _, _}) -> name(T);
type(T = {qid, _, _}) -> name(T);
type(T = {con, _, _}) -> name(T);
type(T = {qcon, _, _}) -> name(T);
type(T = {tvar, _, _}) -> name(T).
-spec tuple_type([aeso_syntax:type()]) -> doc().
tuple_type(Args) ->
tuple(lists:map(fun type/1, Args)).
-spec arg_expr(aeso_syntax:arg_expr()) -> doc().
arg_expr({named_arg, _, Name, E}) ->
follow(hsep(expr(Name), text("=")), expr(E));
arg_expr(E) -> expr(E).
-spec expr_p(integer(), aeso_syntax:expr()) -> doc().
expr_p(P, {lam, _, Args, E}) ->
paren(P > 100, follow(hsep(args(Args), text("=>")), expr_p(100, E)));
expr_p(P, If = {'if', Ann, Cond, Then, Else}) ->
Format = aeso_syntax:get_ann(format, If),
if Format == '?:' ->
paren(P > 100,
follow(expr_p(200, Cond),
follow(hsep(text("?"), expr_p(100, Then)),
hsep(text(":"), expr_p(100, Else)), 0)));
true ->
{Elifs, Else1} = get_elifs(Else),
above([ stmt_p(Stmt) || Stmt <- [{'if', Ann, Cond, Then} | Elifs] ++ [Else1]])
end;
expr_p(_P, {switch, _, E, Cases}) ->
block(beside(text("switch"), paren(expr(E))),
above(lists:map(fun alt/1, Cases)));
expr_p(_, {tuple, _, Es}) ->
tuple(lists:map(fun expr/1, Es));
expr_p(_, {list, _, Es}) ->
list(lists:map(fun expr/1, Es));
expr_p(_, {record, _, Fs}) ->
record(lists:map(fun field/1, Fs));
expr_p(_, {map, Ann, KVs}) ->
record([ field({field, Ann, [{map_get, [], K}], V}) || {K, V} <- KVs ]);
expr_p(P, {map, Ann, E, Flds}) ->
expr_p(P, {record, Ann, E, Flds});
expr_p(P, {record, Ann, E, Fs}) ->
paren(P > 900, hsep(expr_p(900, E), expr({record, Ann, Fs})));
expr_p(_, {block, _, Ss}) ->
block(empty(), statements(Ss));
expr_p(P, {proj, _, E, X}) ->
paren(P > 900, beside([expr_p(900, E), text("."), name(X)]));
expr_p(P, {map_get, _, E, Key}) ->
paren(P > 900, beside([expr_p(900, E), list([expr(Key)])]));
expr_p(P, {map_get, Ann, E, Key, Val}) ->
paren(P > 900, beside([expr_p(900, E), list([expr(equals(Ann, Key, Val))])]));
expr_p(P, {typed, _, E, T}) ->
paren(P > 0, typed(expr(E), T));
expr_p(P, {assign, _, LV, E}) ->
paren(P > 0, equals(expr_p(900, LV), expr(E)));
%% -- Operators
expr_p(_, {app, _, {'..', _}, [A, B]}) ->
list([infix(0, '..', A, B)]);
expr_p(P, E = {app, _, F = {Op, _}, Args}) when is_atom(Op) ->
case {aeso_syntax:get_ann(format, E), Args} of
{infix, [A, B]} -> infix(P, Op, A, B);
{prefix, [A]} -> prefix(P, Op, A);
_ -> app(P, F, Args)
end;
expr_p(P, {app, _, F, Args}) ->
app(P, F, Args);
%% -- Constants
expr_p(_, E = {int, _, N}) ->
S = case aeso_syntax:get_ann(format, E) of
hex -> "0x" ++ integer_to_list(N, 16);
_ -> integer_to_list(N)
end,
text(S);
expr_p(_, {bool, _, B}) -> text(atom_to_list(B));
expr_p(_, {hash, _, <<N:256>>}) -> text("#" ++ integer_to_list(N, 16));
expr_p(_, {unit, _}) -> text("()");
expr_p(_, {string, _, S}) -> term(binary_to_list(S));
expr_p(_, {char, _, C}) ->
case C of
$' -> text("'\\''");
$" -> text("'\"'");
_ -> S = lists:flatten(io_lib:format("~p", [[C]])),
text("'" ++ tl(lists:droplast(S)) ++ "'")
end;
%% -- Names
expr_p(_, E = {id, _, _}) -> name(E);
expr_p(_, E = {con, _, _}) -> name(E);
expr_p(_, E = {qid, _, _}) -> name(E);
expr_p(_, E = {qcon, _, _}) -> name(E);
%% -- For error messages
expr_p(_, {Op, _}) when is_atom(Op) ->
paren(text(atom_to_list(Op)));
expr_p(_, {lvalue, _, LV}) -> lvalue(LV).
stmt_p({'if', _, Cond, Then}) ->
block_expr(200, beside(text("if"), paren(expr(Cond))), Then);
stmt_p({elif, _, Cond, Then}) ->
block_expr(200, beside(text("elif"), paren(expr(Cond))), Then);
stmt_p({else, Else}) ->
HideGenerated = not show_generated(),
case aeso_syntax:get_ann(origin, Else) of
system when HideGenerated -> empty();
_ -> block_expr(200, text("else"), Else)
end.
-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 '[ ]'
bin_prec('||') -> {200, 300, 200};
bin_prec('&&') -> {300, 400, 300};
bin_prec('<') -> {400, 500, 500};
bin_prec('>') -> {400, 500, 500};
bin_prec('=<') -> {400, 500, 500};
bin_prec('>=') -> {400, 500, 500};
bin_prec('==') -> {400, 500, 500};
bin_prec('!=') -> {400, 500, 500};
bin_prec('++') -> {500, 600, 500};
bin_prec('::') -> {500, 600, 500};
bin_prec('+') -> {600, 600, 650};
bin_prec('-') -> {600, 600, 650};
bin_prec('bor') -> {600, 600, 650};
bin_prec('bxor') -> {600, 600, 650};
bin_prec('bsl') -> {600, 600, 650};
bin_prec('bsr') -> {600, 600, 650};
bin_prec('*') -> {700, 700, 750};
bin_prec('/') -> {700, 700, 750};
bin_prec(mod) -> {700, 700, 750};
bin_prec('band') -> {700, 700, 750};
bin_prec('^') -> {750, 750, 800}.
-spec un_prec(aeso_syntax:un_op()) -> {integer(), integer()}.
un_prec('-') -> {650, 650};
un_prec('!') -> {800, 800};
un_prec('bnot') -> {800, 800}.
equals(Ann, A, B) ->
{app, [{format, infix} | Ann], {'=', Ann}, [A, B]}.
-spec infix(integer(), aeso_syntax:bin_op(), aeso_syntax:expr(), aeso_syntax:expr()) -> doc().
infix(P, Op, A, B) ->
{Top, L, R} = bin_prec(Op),
paren(P > Top,
follow(hsep(expr_p(L, A), text(atom_to_list(Op))),
expr_p(R, B))).
prefix(P, Op, A) ->
{Top, Inner} = un_prec(Op),
paren(P > Top, hsep(text(atom_to_list(Op)), expr_p(Inner, A))).
app(P, F, Args) ->
paren(P > 900,
beside(expr_p(900, F),
tuple(lists:map(fun arg_expr/1, Args)))).
field({field, _, LV, E}) ->
follow(hsep(lvalue(LV), text("=")), expr(E));
field({field, _, LV, Id, E}) ->
follow(hsep([lvalue(LV), text("@"), name(Id), text("=")]), expr(E));
field({field_upd, _, LV, Fun}) ->
follow(hsep(lvalue(LV), text("~")), expr(Fun)). %% Not valid syntax
lvalue([E | Es]) ->
beside([elim(E) | lists:map(fun elim1/1, Es)]).
elim({proj, _, X}) -> name(X);
elim({map_get, Ann, K}) -> expr_p(0, {list, Ann, [K]});
elim({map_get, Ann, K, V}) -> expr_p(0, {list, Ann, [equals(Ann, K, V)]}).
elim1(Proj={proj, _, _}) -> beside(text("."), elim(Proj));
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(_, Header, {block, _, Ss}) ->
block(Header, statements(Ss));
block_expr(P, Header, E) ->
follow(Header, expr_p(P, E)).
statements(Stmts) ->
above([ statement(S) || S <- Stmts ]).
statement(S = {letval, _, _, _, _}) -> letdecl("let", S);
statement(S = {letfun, _, _, _, _, _}) -> letdecl("let", S);
statement(S = {letrec, _, _}) -> letdecl("let", S);
statement(E) -> expr(E).
get_elifs(Expr) -> get_elifs(Expr, []).
get_elifs(If = {'if', Ann, Cond, Then, Else}, Elifs) ->
case aeso_syntax:get_ann(format, If) of
elif -> get_elifs(Else, [{elif, Ann, Cond, Then} | Elifs]);
_ -> {lists:reverse(Elifs), If}
end;
get_elifs(Else, Elifs) -> {lists:reverse(Elifs), {else, Else}}.
fmt(Fmt, Args) -> text(lists:flatten(io_lib:format(Fmt, Args))).
term(X) -> fmt("~p", [X]).
src/aeso_scan.erl
+127
View File
@@ -0,0 +1,127 @@
%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*-
%%%-------------------------------------------------------------------
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc The Sophia lexer.
%%%
%%% @end
%%%-------------------------------------------------------------------
-module(aeso_scan).
-export([scan/1]).
-import(aeso_scan_lib, [token/1, token/2, symbol/0, skip/0,
override/2, push/2, pop/1]).
lexer() ->
DIGIT = "[0-9]",
HEXDIGIT = "[0-9a-fA-F]",
LOWER = "[a-z_]",
UPPER = "[A-Z]",
CON = [UPPER, "[a-zA-Z0-9_]*"],
INT = [DIGIT, "+"],
HEX = ["0x", HEXDIGIT, "+"],
HASH = ["#", HEXDIGIT, "+"],
WS = "[\\000-\\ ]+",
ID = [LOWER, "[a-zA-Z0-9_']*"],
TVAR = ["'", ID],
QID = ["(", CON, "\\.)+", ID],
QCON = ["(", CON, "\\.)+", CON],
OP = "[=!<>+\\-*/:&|?~@^]+",
CHAR = "'([^'\\\\]|(\\\\.))'",
STRING = "\"([^\"\\\\]|(\\\\.))*\"",
CommentStart = {"/\\*", push(comment, skip())},
CommentRules =
[ CommentStart
, {"\\*/", pop(skip())}
, {"[^/*]+|[/*]", skip()} ],
Keywords = ["contract", "import", "let", "rec", "switch", "type", "record", "datatype", "if", "elif", "else", "function",
"stateful", "true", "false", "and", "mod", "public", "private", "indexed", "internal",
"band", "bor", "bxor", "bsl", "bsr", "bnot"],
KW = string:join(Keywords, "|"),
Rules =
%% Comments and whitespace
[ CommentStart
, {"//.*", skip()}
, {WS, skip()}
%% Special characters
, {"\\.\\.|[,.;()\\[\\]{}]", symbol()}
%% Literals
, {CHAR, token(char, fun parse_char/1)}
, {STRING, token(string, fun parse_string/1)}
, {HEX, token(hex, fun parse_hex/1)}
, {INT, token(int, fun list_to_integer/1)}
, {HASH, token(hash, fun parse_hash/1)}
%% Identifiers (qualified first!)
, {QID, token(qid, fun(S) -> string:tokens(S, ".") end)}
, {QCON, token(qcon, fun(S) -> string:tokens(S, ".") end)}
, {TVAR, token(tvar)}
, override({ID, token(id)}, {KW, symbol()}) %% Keywords override identifiers. Need to
, {CON, token(con)} %% use override to avoid lexing "lettuce"
%% as ['let', {id, "tuce"}].
%% Operators
, {OP, symbol()}
],
[{code, Rules}, {comment, CommentRules}].
scan(String) ->
Lexer = aeso_scan_lib:compile(lexer()),
aeso_scan_lib:string(Lexer, code, String).
%% -- Helpers ----------------------------------------------------------------
parse_string([$" | Chars]) ->
unescape(Chars).
parse_char([$', $\\, Code, $']) ->
case Code of
$' -> $';
$\\ -> $\\;
$b -> $\b;
$e -> $\e;
$f -> $\f;
$n -> $\n;
$r -> $\r;
$t -> $\t;
$v -> $\v;
_ -> {error, "Bad control sequence: \\" ++ [Code]}
end;
parse_char([$', C, $']) -> C.
unescape(Str) -> unescape(Str, []).
%% TODO: numeric escapes
unescape([$"], Acc) ->
list_to_binary(lists:reverse(Acc));
unescape([$\\, Code | Chars], Acc) ->
Ok = fun(C) -> unescape(Chars, [C | Acc]) end,
case Code of
$" -> Ok($");
$\\ -> Ok($\\);
$b -> Ok($\b);
$e -> Ok($\e);
$f -> Ok($\f);
$n -> Ok($\n);
$r -> Ok($\r);
$t -> Ok($\t);
$v -> Ok($\v);
_ -> error("Bad control sequence: \\" ++ [Code]) %% TODO
end;
unescape([C | Chars], Acc) ->
unescape(Chars, [C | Acc]).
parse_hex("0x" ++ Chars) -> list_to_integer(Chars, 16).
parse_hash("#" ++ Chars) ->
N = list_to_integer(Chars, 16),
case length(Chars) > 64 of %% 64 hex digits = 32 bytes
true -> <<N:64/unit:8>>; %% signature
false -> <<N:32/unit:8>> %% address
end.
src/aeso_scan_lib.erl
+147
View File
@@ -0,0 +1,147 @@
%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*-
%%%-------------------------------------------------------------------
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc A customisable lexer.
%%% @end
%%%-------------------------------------------------------------------
-module(aeso_scan_lib).
-export([compile/1, string/3,
token/1, token/2, symbol/0, skip/0,
override/2, push/2, pop/1]).
-export_type([lexer/0, token_spec/0, token_action/0, token/0, pos/0, regex/0]).
%% -- Exported types --
-type regex() :: iodata() | unicode:charlist().
-type pos() :: {integer(), integer()}.
-type lex_state() :: atom().
-type token() :: {atom(), pos(), term()} | {atom(), pos()}.
-type token_spec() :: {regex(), token_action()}.
-opaque token_action() :: fun((string(), pos()) -> {tok_result(), state_change()}).
-opaque lexer() :: [{lex_state(),
fun((string(), pos()) -> {ok, tok_result(), string(), pos()}
| end_of_file | error)}].
%% -- Internal types --
-type tok_result() :: {token, token()} | skip.
-type state_change() :: none | pop | {push, lex_state()}.
%% @doc Compile a lexer specification. Takes the regexps for each state and
%% combines them into a single big regexp that is then compiled with re:compile/1.
%% Note: contrary to lexer generators like leex, we don't have longest match
%% semantics (since this isn't supported by re). Use override/2 instead.
-spec compile([{lex_state(), [token_spec()]}]) -> lexer().
compile(TokenSpecs) ->
[{S, compile_spec(Spec)} || {S, Spec} <- TokenSpecs].
compile_spec(TokenSpecs) ->
WithIxs = lists:zip(lists:seq(1, length(TokenSpecs)), TokenSpecs),
{ok, Regex} = re:compile(["^(", name(0), string:join([ ["(", name(I), R, ")"] || {I, {R, _}} <- WithIxs ], "|"),")"]),
Actions = [ Fun || {_, Fun} <- TokenSpecs ],
fun ("", _Pos) -> end_of_file;
(S, Pos) ->
case re:run(S, Regex, [{capture, all_names}]) of
{match, [{0, N} | Capture]} ->
Index = 1 + length(lists:takewhile(fun({P, _}) -> P == -1 end, Capture)),
Action = lists:nth(Index, Actions),
{TokS, Rest} = lists:split(N, S),
Tok = Action(TokS, Pos),
{ok, Tok, Rest, next_pos(TokS, Pos)};
nomatch ->
error
end
end.
%% @doc Produce a token with the given tag and the matched string as the
%% value.
-spec token(atom()) -> token_action().
token(Tag) ->
token(Tag, fun(X) -> X end).
%% @doc Produce a token with the given tag and the value computed from the
%% matched string using the function.
-spec token(atom(), fun((string()) -> term())) -> token_action().
token(Tag, Fun) ->
fun(S, P) -> {{token, {Tag, P, Fun(S)}}, none} end.
%% @doc Produce a token with the matched string (converted to an atom) as the
%% tag and no value.
-spec symbol() -> token_action().
symbol() ->
fun(S, P) -> {{token, {list_to_atom(S), P}}, none} end.
%% @doc Skip the matched string, producing no token.
-spec skip() -> token_action().
skip() ->
fun(_, _) -> {skip, none} end.
%% @doc Enter the given state and perform the given action. The argument action
%% should not change the state.
-spec push(lex_state(), token_action()) -> token_action().
push(State, Action) ->
fun(S, P) -> {Res, _} = Action(S, P), {Res, {push, State}} end.
%% @doc Exit from the current state and perform the given action. The argument
%% action should not change the state.
-spec pop(token_action()) -> token_action().
pop(Action) ->
fun(S, P) -> {Res, _} = Action(S, P), {Res, pop} end.
%% @doc Match using the first spec, but if the second spec also matches use
%% that one instead. Use this for overlapping tokens (like identifiers and
%% keywords), since matching does not have longest-match semantics.
-spec override(token_spec(), token_spec()) -> token_spec().
override({Re1, Action1}, {Re2, Action2}) ->
{ok, Compiled} = re:compile(["^(", Re2, ")$"]),
{Re1, fun(S, P) ->
case re:run(S, Compiled, [{capture, none}]) of
match -> Action2(S, P);
nomatch -> Action1(S, P)
end end}.
%% @doc Run a lexer. Takes the starting state and the string to lex.
-spec string(lexer(), lex_state(), string()) -> {ok, [token()]} | {error, term()}.
string(Lexer, State, String) -> string(Lexer, [State], String, {1, 1}).
string(Lexer, Stack, String, Pos) ->
Lines = string:split(String, "\n", all),
string(Lexer, Stack, Lines, Pos, []).
string(_Lexers, [], [Line | _Rest], Pos, _Acc) ->
{error, {{Line,Pos}, scan_error_no_state}};
string(_Lexers, _Stack, [], _Pos, Acc) ->
{ok, lists:reverse(Acc)};
string(Lexers, [State | Stack], [Line | Lines], Pos, Acc) ->
Lexer = proplists:get_value(State, Lexers, State),
case Lexer(Line, Pos) of
{ok, {Res, StateChange}, Line1, Pos1} ->
Acc1 = case Res of
{token, Tok} -> [Tok | Acc];
skip -> Acc
end,
Stack1 = case StateChange of
none -> [State | Stack];
pop -> Stack;
{push, State1} -> [State1, State | Stack]
end,
string(Lexers, Stack1, [Line1 | Lines], Pos1, Acc1);
end_of_file -> string(Lexers, [State | Stack], Lines, next_pos("\n", Pos), Acc);
error -> {error, {{Line,Pos}, scan_error}}
end.
%% -- Internal functions -----------------------------------------------------
name(I) ->
io_lib:format("?<A~3.10.0b>", [I]).
-define(TAB_SIZE, 8).
next_pos([], P) -> P;
next_pos([$\n | S], {L, _}) -> next_pos(S, {L + 1, 1});
next_pos([$\t | S], {L, C}) -> next_pos(S, {L, (C + ?TAB_SIZE - 1) div ?TAB_SIZE * ?TAB_SIZE + 1});
next_pos([_ | S], {L, C}) -> next_pos(S, {L, C + 1}).
src/aeso_sophia.erl
+30
View File
@@ -0,0 +1,30 @@
-module(aeso_sophia).
-export_type([data/0,
type/0,
heap/0]).
-type type() :: word | signed_word | string | typerep | function
| {list, type()}
| {option, type()}
| {tuple, [type()]}
| {variant, [[type()]]}.
-type data() :: none
| {some, data()}
| {option, data()}
| word
| string
| {list, data()}
| {tuple, [data()]}
| {variant, integer(), [data()]}
| integer()
| binary()
| [data()]
| {}
| {data()}
| {data(), data()}.
-type heap() :: binary().
src/aeso_syntax.erl
+142
View File
@@ -0,0 +1,142 @@
%%% -*- erlang-indent-level:4; indent-tabs-mode: nil -*-
%%%-------------------------------------------------------------------
%%% @copyright (C) 2017, Aeternity Anstalt
%%% @doc Sophia abstract syntax types.
%%%
%%% @end
%%%-------------------------------------------------------------------
-module(aeso_syntax).
-export([get_ann/1, get_ann/2, get_ann/3, set_ann/2]).
-export_type([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]).
-export_type([arg/0, field_t/0, constructor_t/0]).
-export_type([type/0, constant/0, expr/0, arg_expr/0, field/1, stmt/0, alt/0, lvalue/0, pat/0]).
-export_type([ast/0]).
-type ast() :: [decl()].
-type ann_line() :: integer().
-type ann_col() :: integer().
-type ann_origin() :: system | user.
-type ann_format() :: '?:' | hex | infix | prefix | elif.
-type ann() :: [{line, ann_line()} | {col, ann_col()} | {format, ann_format()} | {origin, ann_origin()}].
-type name() :: string().
-type id() :: {id, ann(), name()}.
-type con() :: {con, ann(), name()}.
-type qid() :: {qid, ann(), [name()]}.
-type qcon() :: {qcon, ann(), [name()]}.
-type tvar() :: {tvar, ann(), name()}.
-type decl() :: {contract, ann(), con(), [decl()]}
| {type_decl, ann(), id(), [tvar()]}
| {type_def, ann(), id(), [tvar()], typedef()}
| {fun_decl, ann(), id(), type()}
| letbind().
-type letbind()
:: {letval, ann(), id(), type(), expr()}
| {letfun, ann(), id(), [arg()], type(), expr()}
| {letrec, ann(), [letbind()]}.
-type arg() :: {arg, ann(), id(), type()}.
-type typedef()
:: {alias_t, type()}
| {record_t, [field_t()]}
| {variant_t, [constructor_t()]}.
-type field_t() :: {field_t, ann(), id(), type()}.
-type constructor_t() :: {constr_t, ann(), con(), [type()]}.
-type type() :: {fun_t, ann(), [named_arg_t()], [type()], type()}
| {app_t, ann(), type(), [type()]}
| {tuple_t, ann(), [type()]}
| id() | qid()
| con() | qcon() %% contracts
| tvar().
-type named_arg_t() :: {named_arg_t, ann(), id(), type(), expr()}.
-type constant()
:: {int, ann(), integer()}
| {bool, ann(), true | false}
| {hash, ann(), binary()}
| {unit, ann()}
| {string, ann(), binary()}
| {char, ann(), integer()}.
-type op() :: bin_op() | un_op().
-type bin_op() :: '+' | '-' | '*' | '/' | mod | '^' | 'band' | 'bor' | 'bsl' | 'bsr' | 'bxor'
| '++' | '::' | '<' | '>' | '=<' | '>=' | '==' | '!='
| '||' | '&&' | '..'.
-type un_op() :: '-' | '!' | 'bnot'.
-type expr()
:: {lam, ann(), [arg()], expr()}
| {'if', ann(), expr(), expr(), expr()}
| {switch, ann(), expr(), [alt()]}
| {app, ann(), expr(), [arg_expr()]}
| {proj, ann(), expr(), id()}
| {tuple, ann(), [expr()]}
| {list, ann(), [expr()]}
| {typed, ann(), expr(), type()}
| {record, ann(), [field(expr())]}
| {record, ann(), expr(), [field(expr())]} %% record update
| {map, ann(), expr(), [field(expr())]} %% map update
| {map, ann(), [{expr(), expr()}]}
| {map_get, ann(), expr(), expr()}
| {map_get, ann(), expr(), expr(), expr()}
| {block, ann(), [stmt()]}
| {op(), ann()}
| id() | qid() | con() | qcon()
| constant().
-type arg_expr() :: expr() | {named_arg, ann(), id(), expr()}.
%% When lvalue is a projection this is sugar for accessing fields in nested
%% records. For instance,
%% r { x.y: 5 }
%% is the same as
%% r { x: r.x { y: 5 } }
-type field(E) :: {field, ann(), lvalue(), E}
| {field, ann(), lvalue(), id(), E}. %% modifying a field (id is previous value)
-type stmt() :: letbind()
| expr().
-type alt() :: {'case', ann(), pat(), expr()}.
-type lvalue() :: nonempty_list(elim()).
-type elim() :: {proj, ann(), id()}
| {map_get, ann(), expr()}
| {map_get, ann(), expr(), expr()}.
-type pat() :: {app, ann(), con() | op(), [pat()]}
| {tuple, ann(), [pat()]}
| {list, ann(), [pat()]}
| {record, ann(), [field(pat())]}
| constant()
| con()
| id().
get_ann(Node) when is_tuple(Node) -> element(2, Node);
get_ann(Ann) when is_list(Ann) -> Ann.
set_ann(Ann1, Node) when is_tuple(Node) -> setelement(2, Node, Ann1);
set_ann(Ann1, Ann) when is_list(Ann) -> Ann1.
get_ann(Key, Node) ->
proplists:get_value(Key, get_ann(Node)).
get_ann(Key, Node, Default) ->
proplists:get_value(Key, get_ann(Node), Default).
src/aeso_syntax_utils.erl
+94
View File
@@ -0,0 +1,94 @@
%%%-------------------------------------------------------------------
%%% @copyright (C) 2018, Aeternity Anstalt
%%% @doc
%%% Sophia syntax utilities.
%%% @end
%%%-------------------------------------------------------------------
-module(aeso_syntax_utils).
-export([used_ids/1, used_types/1]).
%% Var set combinators
none() -> [].
one(X) -> [X].
union_map(F, Xs) -> lists:umerge(lists:map(F, Xs)).
minus(Xs, Ys) -> Xs -- Ys.
%% Compute names used by a definition or expression.
used_ids(Es) when is_list(Es) ->
union_map(fun used_ids/1, Es);
used_ids({bind, A, B}) ->
minus(used_ids(B), used_ids(A));
%% Declarations
used_ids({contract, _, _, Decls}) -> used_ids(Decls);
used_ids({type_decl, _, _, _}) -> none();
used_ids({type_def, _, _, _, _}) -> none();
used_ids({fun_decl, _, _, _}) -> none();
used_ids({letval, _, _, _, E}) -> used_ids(E);
used_ids({letfun, _, _, Args, _, E}) -> used_ids({bind, Args, E});
used_ids({letrec, _, Decls}) -> used_ids(Decls);
%% Args
used_ids({arg, _, X, _}) -> used_ids(X);
used_ids({named_arg, _, _, E}) -> used_ids(E);
%% Constants
used_ids({int, _, _}) -> none();
used_ids({bool, _, _}) -> none();
used_ids({hash, _, _}) -> none();
used_ids({unit, _}) -> none();
used_ids({string, _, _}) -> none();
used_ids({char, _, _}) -> none();
%% Expressions
used_ids({lam, _, Args, E}) -> used_ids({bind, Args, E});
used_ids({'if', _, A, B, C}) -> used_ids([A, B, C]);
used_ids({switch, _, E, Bs}) -> used_ids([E, Bs]);
used_ids({app, _, E, Es}) -> used_ids([E | Es]);
used_ids({proj, _, E, _}) -> used_ids(E);
used_ids({tuple, _, Es}) -> used_ids(Es);
used_ids({list, _, Es}) -> used_ids(Es);
used_ids({typed, _, E, _}) -> used_ids(E);
used_ids({record, _, Fs}) -> used_ids(Fs);
used_ids({record, _, E, Fs}) -> used_ids([E, Fs]);
used_ids({map, _, E, Fs}) -> used_ids([E, Fs]);
used_ids({map, _, KVs}) -> used_ids([ [K, V] || {K, V} <- KVs ]);
used_ids({map_get, _, M, K}) -> used_ids([M, K]);
used_ids({map_get, _, M, K, V}) -> used_ids([M, K, V]);
used_ids({block, _, Ss}) -> used_ids_s(Ss);
used_ids({Op, _}) when is_atom(Op) -> none();
used_ids({id, _, X}) -> [X];
used_ids({qid, _, _}) -> none();
used_ids({con, _, _}) -> none();
used_ids({qcon, _, _}) -> none();
%% Switch branches
used_ids({'case', _, P, E}) -> used_ids({bind, P, E});
%% Fields
used_ids({field, _, LV, E}) -> used_ids([LV, E]);
used_ids({field, _, LV, X, E}) -> used_ids([LV, {bind, X, E}]);
used_ids({proj, _, _}) -> none();
used_ids({map_get, _, E}) -> used_ids(E).
%% Statements
used_ids_s([]) -> none();
used_ids_s([S | Ss]) ->
used_ids([S, {bind, bound_ids(S), {block, [], Ss}}]).
bound_ids({letval, _, X, _, _}) -> one(X);
bound_ids({letfun, _, X, _, _, _}) -> one(X);
bound_ids({letrec, _, Decls}) -> union_map(fun bound_ids/1, Decls);
bound_ids(_) -> none().
used_types(Ts) when is_list(Ts) -> union_map(fun used_types/1, Ts);
used_types({type_def, _, _, _, T}) -> used_types(T);
used_types({alias_t, T}) -> used_types(T);
used_types({record_t, Fs}) -> used_types(Fs);
used_types({variant_t, Cs}) -> used_types(Cs);
used_types({field_t, _, _, T}) -> used_types(T);
used_types({constr_t, _, _, Ts}) -> used_types(Ts);
used_types({fun_t, _, Named, Args, T}) -> used_types([T | Named ++ Args]);
used_types({named_arg_t, _, _, T, _}) -> used_types(T);
used_types({app_t, _, T, Ts}) -> used_types([T | Ts]);
used_types({tuple_t, _, Ts}) -> used_types(Ts);
used_types({id, _, X}) -> one(X);
used_types({qid, _, _}) -> none();
used_types({con, _, _}) -> none();
used_types({qcon, _, _}) -> none();
used_types({tvar, _, _}) -> none().
src/aeso_utils.erl
+68
View File
@@ -0,0 +1,68 @@
%%%-------------------------------------------------------------------
%%% @copyright (C) 2018, Aeternity Anstalt
%%% @doc
%%% Sophia utility functions.
%%% @end
%%%-------------------------------------------------------------------
-module(aeso_utils).
-export([scc/1]).
-export_type([graph/1]).
%% -- Topological sort
-type graph(Node) :: #{Node => [Node]}. %% List of incoming edges (dependencies).
%% Topologically sorted strongly-connected components of a graph.
-spec scc(graph(Node)) -> [{cyclic, [Node]} | {acyclic, Node}].
scc(Graph) ->
Trees = dfs(Graph, lists:reverse(postorder(dff(reverse_graph(Graph))))),
Decode = fun(T) ->
case postorder(T) of
[I] -> case lists:member(I, maps:get(I, Graph, [])) of
true -> {cyclic, [I]};
false -> {acyclic, I}
end;
Is -> {cyclic, Is}
end end,
lists:map(Decode, Trees).
%% Depth first spanning forest of a graph.
dff(Graph) ->
dfs(Graph, maps:keys(Graph)).
dfs(Graph, Vs) ->
{_, Trees} = dfs(Graph, #{}, Vs, []),
Trees.
dfs(_Graph, Visited, [], Trees) -> {Visited, lists:reverse(Trees)};
dfs(Graph, Visited, [V | Vs], Trees) ->
case maps:is_key(V, Visited) of
true -> dfs(Graph, Visited, Vs, Trees);
false ->
{Visited1, Tree} = dfs1(Graph, Visited#{ V => true }, V),
dfs(Graph, Visited1, Vs, [Tree | Trees])
end.
dfs1(Graph, Visited, V) ->
Ws = maps:get(V, Graph, []),
{Visited1, Trees} = dfs(Graph, Visited, Ws, []),
{Visited1, {V, Trees}}.
%% Post-order traversal of a tree/forest.
postorder(Tree = {_, _}) -> postorder([Tree]);
postorder(Trees) when is_list(Trees) -> postorder(Trees, []).
postorder([], Acc) -> Acc;
postorder([{V, Trees1} | Trees], Acc) ->
postorder(Trees1, [V | postorder(Trees, Acc)]).
from_edges(Is, Es) ->
lists:foldl(fun({I, J}, G) ->
maps:update_with(I, fun(Js) -> lists:umerge([J], Js) end, [J], G)
end, maps:from_list([ {I, []} || I <- Is ]), Es).
reverse_graph(G) ->
from_edges(maps:keys(G), [ {J, I} || {I, Js} <- maps:to_list(G), J <- Js ]).
src/aesophia.app.src
+18
View File
@@ -0,0 +1,18 @@
{application, aesophia,
[{description, "Contract Language for Aethernity"},
{vsn, "0.0.1"},
{registered, []},
{applications,
[kernel,
stdlib,
lager,
aebytecode
]},
{env,[]},
{modules, []},
{maintainers, []},
{licenses, []},
{links, []}
]}.